diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -1,35 +1,108 @@ -- Arbitrary.hs: QuickCheck instances --- Copyright © 2014-2019 Clint Adams +-- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} + module Codec.Encryption.OpenPGP.Arbitrary ( ) where import Codec.Encryption.OpenPGP.Types +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI) import Test.QuickCheck ( Arbitrary(..) + , Gen , choose , elements , frequency , getPositive , listOf1 , oneof + , sized + , suchThat , vector ) import Test.QuickCheck.Instances () -instance Arbitrary PKESK where +instance Arbitrary (PKESK 'PKESKV3) where arbitrary = do - pv <- arbitrary eoki <- arbitrary pka <- arbitrary - PKESK pv eoki pka <$> arbitrary + mpis <- + case pka of + RSA -> (\mpi -> mpi NE.:| []) <$> arbitrary + DeprecatedRSAEncryptOnly -> (\mpi -> mpi NE.:| []) <$> arbitrary + ElgamalEncryptOnly -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + ForbiddenElgamal -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + ECDH -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + _ -> arbitrary + pure (PKESK3Packet 3 eoki pka mpis) +instance Arbitrary (PKESK 'PKESKV6) where + arbitrary = do + rid <- + oneof + [ pure BL.empty + , BL.pack <$> vector 20 + , BL.pack . (4 :) <$> vector 20 + , BL.pack <$> vector 32 + , BL.pack . (6 :) <$> vector 32 + ] + pka <- arbitrary + esk <- BL.pack <$> listOf1 arbitrary + pure (PKESK6Packet rid pka esk) + +instance Arbitrary (SKESK 'SKESKV4) where + arbitrary = do + sa <- elements [AES128, AES192, AES256] + s2k <- arbitrarySKESKv4S2K + esk <- oneof [pure Nothing, Just . BL.pack <$> listOf1 arbitrary] + pure (SKESK4Packet sa s2k esk) + +instance Arbitrary (SKESK 'SKESKV6) where + arbitrary = do + sa <- elements [AES128, AES192, AES256] + aead <- elements [EAX, OCB, GCM] + s2k <- arbitrarySKESKv6S2K + iv <- BL.pack <$> vector 16 + esk <- BL.pack <$> listOf1 arbitrary + tag <- BL.pack <$> vector 16 + pure (SKESK6Packet sa aead s2k iv esk tag) + +arbitrarySKESKv4S2K :: Gen S2K +arbitrarySKESKv4S2K = + oneof + [ Simple <$> elements supportedSKESKHashAlgorithms + , Salted <$> elements supportedSKESKHashAlgorithms <*> (Salt8 . B.pack <$> vector 8) + ] + +arbitrarySKESKv6S2K :: Gen S2K +arbitrarySKESKv6S2K = + Argon2 <$> + (Salt16 . B.pack <$> vector 16) <*> + choose (1, 4) <*> + choose (1, 4) <*> + choose (3, 31) + +supportedSKESKHashAlgorithms :: [HashAlgorithm] +supportedSKESKHashAlgorithms = [SHA1, SHA256, SHA384, SHA512] + instance Arbitrary Signature where arbitrary = fmap Signature arbitrary @@ -57,7 +130,7 @@ w16 <- arbitrary SigV4 st pka ha has uhas w16 <$> arbitrary other = do - v <- choose (5, maxBound) + v <- oneof [pure 5, choose (7, maxBound)] SigVOther v <$> arbitrary instance Arbitrary SigSubPacket where @@ -67,32 +140,34 @@ instance Arbitrary SigSubPacketPayload where arbitrary = - oneof - [ sct - , set - , ec - , ts - , re - , ket - , psa - , rk - , i - , nd - , phas - , pcas - , ksps - , pks - , puid - , purl - , kfs - , suid - , rfr - , fs - , st - , udss - , oss - , ifp - ] {-, es -} + sized $ \n -> + oneof + ([ sct + , set + , ec + , ts + , re + , ket + , psa + , rk + , i + , nd + , phas + , pcas + , ksps + , pks + , puid + , purl + , kfs + , suid + , rfr + , fs + , st + , udss + , oss + , ifp + ] ++ + [es n | n > 0]) where sct = fmap SigCreationTime arbitrary set = fmap SigExpirationTime arbitrary @@ -105,7 +180,7 @@ rk = arbitrary >>= \rcs -> arbitrary >>= \pka -> - arbitrary >>= \tof -> return (RevocationKey rcs pka tof) + fmap (RevocationKey rcs pka . Fingerprint . BL.pack) (vector 20) i = fmap Issuer arbitrary nd = arbitrary >>= \nfs -> @@ -127,19 +202,49 @@ arbitrary >>= \pka -> arbitrary >>= \ha -> arbitrary >>= \sh -> return (SignatureTarget pka ha sh) - es = fmap EmbeddedSignature arbitrary -- FIXME: figure out why EmbeddedSignature fails to serialize properly + es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty)) ifp = - choose (4, 5) >>= \v -> + elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> fmap (IssuerFingerprint v) - (if v == 4 - then arbitrary - else fmap (TwentyOctetFingerprint . BL.pack) (vector 32)) + (if v == IssuerFingerprintV6 + then fmap (Fingerprint . BL.pack) (vector 32) + else fmap (Fingerprint . BL.pack) (vector 20)) udss = choose (100, 110) >>= \a -> arbitrary >>= \b -> return (UserDefinedSigSub a b) oss = - choose (111, 127) >>= \a -> arbitrary >>= \b -> return (OtherSigSub a b) -- FIXME: more comprehensive range + suchThat arbitrary isOtherSigSubType >>= \a -> + arbitrary >>= \b -> return (OtherSigSub a b) + isOtherSigSubType a = + a <= 127 && + a `notElem` + [ 2 + , 3 + , 4 + , 5 + , 6 + , 7 + , 9 + , 11 + , 12 + , 16 + , 20 + , 21 + , 22 + , 23 + , 24 + , 25 + , 26 + , 27 + , 28 + , 29 + , 30 + , 31 + , 32 + , 33 + ] && + (a < 100 || a > 110) -- instance Arbitrary PubKeyAlgorithm where @@ -148,8 +253,13 @@ instance Arbitrary EightOctetKeyId where arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) -instance Arbitrary TwentyOctetFingerprint where - arbitrary = fmap (TwentyOctetFingerprint . BL.pack) (vector 20) +instance Arbitrary Fingerprint where + arbitrary = + oneof + [ fmap (Fingerprint . BL.pack) (vector 16) -- v3 + , fmap (Fingerprint . BL.pack) (vector 20) -- v4 + , fmap (Fingerprint . BL.pack) (vector 32) -- v6 + ] instance Arbitrary MPI where arbitrary = fmap (MPI . getPositive) arbitrary @@ -176,7 +286,17 @@ instance Arbitrary HashAlgorithm where arbitrary = - elements [DeprecatedMD5, SHA1, RIPEMD160, SHA256, SHA384, SHA512, SHA224] + elements + [ DeprecatedMD5 + , SHA1 + , RIPEMD160 + , SHA256 + , SHA384 + , SHA512 + , SHA224 + , SHA3_256 + , SHA3_512 + ] instance Arbitrary SymmetricAlgorithm where arbitrary = @@ -201,13 +321,13 @@ arbitrary = frequency [(9, srk), (1, rco)] where srk = return SensitiveRK - rco = fmap RClOther (choose (2, 7)) + rco = fmap mkRevocationClass (choose (2, 6)) instance Arbitrary NotationFlag where arbitrary = frequency [(9, hr), (1, onf)] where hr = return HumanReadable - onf = fmap OtherNF (choose (1, 31)) + onf = fmap mkNotationFlag (choose (1, 15)) instance Arbitrary CompressionAlgorithm where arbitrary = elements [Uncompressed, ZIP, ZLIB, BZip2] @@ -241,10 +361,11 @@ ] instance Arbitrary FeatureFlag where - arbitrary = frequency [(9, md), (1, fo)] + arbitrary = frequency [(8, seipdV1), (1, seipdV2), (1, fo)] where - md = return ModificationDetection - fo = fmap FeatureOther (choose (8, 63)) + seipdV1 = return FeatureSEIPDv1 + seipdV2 = return FeatureSEIPDv2 + fo = fmap FeatureOther (suchThat (choose (0, 63)) (`notElem` [4, 7])) instance Arbitrary ThirtyTwoBitTimeStamp where arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary diff --git a/Codec/Encryption/OpenPGP/BlockCipher.hs b/Codec/Encryption/OpenPGP/BlockCipher.hs --- a/Codec/Encryption/OpenPGP/BlockCipher.hs +++ b/Codec/Encryption/OpenPGP/BlockCipher.hs @@ -1,11 +1,14 @@ --- BlockCipher.hs: OpenPGP (RFC4880) block cipher stuff --- Copyright © 2013-2024 Clint Adams +-- BlockCipher.hs: OpenPGP (RFC9580) block cipher stuff +-- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.BlockCipher - ( keySize + ( CipherError(..) + , renderCipherError + , keySize , withSymmetricCipher ) where @@ -21,53 +24,86 @@ import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B +-- | 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 + type HOCipher a = forall cipher. HOBlockCipher cipher => cipher -> Either String a withSymmetricCipher :: - SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either String a -withSymmetricCipher Plaintext _ _ = Left "this shouldn't have happened" -- FIXME: orphan instance? -withSymmetricCipher IDEA _ _ = Left "IDEA not yet implemented" -- FIXME: IDEA -withSymmetricCipher ReservedSAFER _ _ = Left "SAFER not implemented" -- FIXME: or not? -withSymmetricCipher ReservedDES _ _ = Left "DES not implemented" -- FIXME: or not? -withSymmetricCipher (OtherSA _) _ _ = - Left "Unknown, unimplemented symmetric algorithm" -withSymmetricCipher CAST5 key f = - (cipherInit key :: Either String (HOWrappedOldCCT CNC.CAST128)) >>= f -withSymmetricCipher Twofish key f = - (cipherInit key :: Either String (HOWrappedOldCCT CNC.TWOFISH)) >>= f -withSymmetricCipher TripleDES key f = - (cipherInit key :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) >>= f -withSymmetricCipher Blowfish key f = - (cipherInit key :: Either String (HOWrappedCCT Blowfish.Blowfish128)) >>= f -withSymmetricCipher AES128 key f = - (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f -withSymmetricCipher AES192 key f = - (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f -withSymmetricCipher AES256 key f = - (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f -withSymmetricCipher Camellia128 key f = - (cipherInit key :: Either String (HOWrappedCCT Camellia.Camellia128)) >>= f -withSymmetricCipher Camellia192 key f = - (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia192)) >>= f -withSymmetricCipher Camellia256 key f = - (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia256)) >>= f + SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either CipherError a +withSymmetricCipher Plaintext _ _ = Left (UnsupportedAlgorithm Plaintext) +withSymmetricCipher IDEA _ _ = Left (UnsupportedAlgorithm IDEA) +withSymmetricCipher ReservedSAFER _ _ = Left (UnsupportedAlgorithm ReservedSAFER) +withSymmetricCipher ReservedDES _ _ = Left (UnsupportedAlgorithm ReservedDES) +withSymmetricCipher (OtherSA n) _ _ = Left (UnsupportedAlgorithm (OtherSA n)) +withSymmetricCipher CAST5 keyBytes f = + initAndRun CAST5 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.CAST128)) f +withSymmetricCipher Twofish keyBytes f = + initAndRun Twofish (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.TWOFISH)) f +withSymmetricCipher TripleDES keyBytes f = + initAndRun TripleDES (cipherInit keyBytes :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) f +withSymmetricCipher Blowfish keyBytes f = + initAndRun Blowfish (cipherInit keyBytes :: Either String (HOWrappedCCT Blowfish.Blowfish128)) f +withSymmetricCipher AES128 keyBytes f = + initAndRun AES128 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES128)) f +withSymmetricCipher AES192 keyBytes f = + initAndRun AES192 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES192)) f +withSymmetricCipher AES256 keyBytes f = + initAndRun AES256 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES256)) f +withSymmetricCipher Camellia128 keyBytes f = + initAndRun Camellia128 (cipherInit keyBytes :: Either String (HOWrappedCCT Camellia.Camellia128)) f +withSymmetricCipher Camellia192 keyBytes f = + initAndRun Camellia192 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia192)) f +withSymmetricCipher Camellia256 keyBytes f = + initAndRun Camellia256 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia256)) f --- in octets; FIXME: co-opt Cipher's cipherKeySize or not? -keySize :: SymmetricAlgorithm -> Int -keySize Plaintext = 0 -keySize IDEA = 16 -- according to https://en.wikipedia.org/wiki/International_Data_Encryption_Algorithm -keySize TripleDES = 24 -- RFC 4880 says 168 bits (derived from 192 bits) but we don't know who does the derivation -keySize CAST5 = 16 -keySize Blowfish = 16 -keySize ReservedSAFER = undefined -keySize ReservedDES = undefined -keySize AES128 = 16 -keySize AES192 = 24 -keySize AES256 = 32 -keySize Twofish = 32 -keySize Camellia128 = 16 -keySize Camellia192 = 24 -keySize Camellia256 = 32 -keySize (OtherSA _) = undefined +initAndRun :: + HOBlockCipher cipher + => SymmetricAlgorithm + -> Either String cipher + -> (cipher -> Either String a) + -> Either CipherError a +initAndRun algo initResult f = + case initResult of + Left err -> Left (CipherInitFailed algo err) + Right c -> + case f c of + Left err -> Left (CipherOperationFailed err) + Right x -> Right x + +-- In octets. Keep this as an explicit OpenPGP algorithm mapping so behavior +-- stays stable across mixed backends (crypton/nettle) and includes unsupported +-- algorithms that never reach backend cipher types. +keySize :: SymmetricAlgorithm -> Either CipherError Int +keySize Plaintext = Right 0 +keySize IDEA = Right 16 +keySize TripleDES = Right 24 +keySize CAST5 = Right 16 +keySize Blowfish = Right 16 +keySize ReservedSAFER = Left (UnsupportedAlgorithm ReservedSAFER) +keySize ReservedDES = Left (UnsupportedAlgorithm ReservedDES) +keySize AES128 = Right 16 +keySize AES192 = Right 24 +keySize AES256 = Right 32 +keySize Twofish = Right 32 +keySize Camellia128 = Right 16 +keySize Camellia192 = Right 24 +keySize Camellia256 = Right 32 +keySize (OtherSA n) = Left (UnsupportedAlgorithm (OtherSA n)) diff --git a/Codec/Encryption/OpenPGP/CFB.hs b/Codec/Encryption/OpenPGP/CFB.hs --- a/Codec/Encryption/OpenPGP/CFB.hs +++ b/Codec/Encryption/OpenPGP/CFB.hs @@ -1,33 +1,68 @@ --- CFB.hs: OpenPGP (RFC4880) CFB mode --- Copyright © 2013-2019 Clint Adams +-- CFB.hs: OpenPGP (RFC9580) CFB mode +-- Copyright © 2013-2026 Clint Adams -- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + module Codec.Encryption.OpenPGP.CFB ( decrypt , decryptPreservingNonce , decryptNoNonce , decryptOpenPGPCfb + , decryptOpenPGPCfbWithNonce + , OpenPGPCFBMode(..) + , OpenPGPCFBModeW(..) , encryptNoNonce + , encryptOpenPGPCfbRaw + , mdcTrailerForSEIPDv1 + , seipdv1NonceFromIV + , validateSEIPD1MDC + , calculateMDC ) where -import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher) +import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), withSymmetricCipher) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import qualified Data.ByteArray as BA import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Control.Monad (when) +data OpenPGPCFBMode + = OpenPGPCFBResync + | OpenPGPCFBNoResync + deriving (Eq, Show) + +data OpenPGPCFBModeW (mode :: OpenPGPCFBMode) where + OpenPGPCFBResyncW :: OpenPGPCFBModeW 'OpenPGPCFBResync + OpenPGPCFBNoResyncW :: OpenPGPCFBModeW 'OpenPGPCFBNoResync + decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString - -> Either String B.ByteString -decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext + -> Either CipherError B.ByteString decryptOpenPGPCfb sa ciphertext keydata = + snd <$> decryptOpenPGPCfbWithNonce sa ciphertext keydata + +decryptOpenPGPCfbWithNonce :: + SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> Either CipherError (B.ByteString, B.ByteString) +decryptOpenPGPCfbWithNonce Plaintext ciphertext _ = return (mempty, ciphertext) +decryptOpenPGPCfbWithNonce sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do nonce <- decrypt1 ciphertext bc cleartext <- decrypt2 ciphertext bc if nonceCheck bc nonce - then return cleartext + then return (nonce, cleartext) else Left "Session key quickcheck failed" where decrypt1 :: @@ -54,37 +89,30 @@ SymmetricAlgorithm -> B.ByteString -> B.ByteString - -> Either String B.ByteString + -> Either CipherError B.ByteString decrypt x y z = snd <$> (decryptPreservingNonce x y z) decryptPreservingNonce :: SymmetricAlgorithm -> B.ByteString -> B.ByteString - -> Either String (B.ByteString, B.ByteString) + -> Either CipherError (B.ByteString, B.ByteString) decryptPreservingNonce Plaintext ciphertext _ = return (mempty, ciphertext) decryptPreservingNonce sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do - (nonce, cleartext) <- - fmap (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc) + let bs = blockSize bc + decrypted <- paddedCfbDecrypt bc (B.replicate bs 0) ciphertext + let (nonce, cleartext) = B.splitAt (bs + 2) decrypted if nonceCheck bc nonce then return (nonce, cleartext) else Left "Session key quickcheck failed" - where - decrypt' :: - HOBlockCipher cipher - => B.ByteString - -> cipher - -> Either String B.ByteString - decrypt' ct cipher = - paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString - -> Either String B.ByteString + -> Either CipherError B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext decryptNoNonce sa iv ciphertext keydata = withSymmetricCipher sa keydata (decrypt' ciphertext) @@ -106,7 +134,7 @@ -> IV -> B.ByteString -> B.ByteString - -> Either String B.ByteString + -> Either CipherError B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload encryptNoNonce sa s2k iv payload keydata = withSymmetricCipher sa keydata (encrypt' payload) @@ -117,3 +145,71 @@ -> cipher -> Either String B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct + +encryptOpenPGPCfbRaw :: + OpenPGPCFBModeW mode + -> SymmetricAlgorithm + -> IV + -> B.ByteString -- ^ plaintext (with MDC trailer already appended) + -> B.ByteString -- ^ raw session key bytes + -> Either CipherError B.ByteString +encryptOpenPGPCfbRaw _ Plaintext _ cleartext _ = Right cleartext +encryptOpenPGPCfbRaw mode sa iv cleartext keydata = + withSymmetricCipher sa keydata $ \cipher -> do + let initialVector = unIV iv + bs = blockSize cipher + if B.length initialVector /= bs + then Left + ("IV length mismatch for " ++ + show sa ++ + ": expected " ++ show bs ++ ", got " ++ show (B.length initialVector)) + else do + let prefix = initialVector <> B.drop (bs - 2) initialVector + case mode of + OpenPGPCFBResyncW -> do + nonceAndCheck <- paddedCfbEncrypt cipher (B.replicate bs 0) prefix + encryptedPayload <- + paddedCfbEncrypt cipher (B.take bs (B.drop 2 nonceAndCheck)) cleartext + return (nonceAndCheck <> encryptedPayload) + OpenPGPCFBNoResyncW -> + paddedCfbEncrypt cipher (B.replicate bs 0) (prefix <> cleartext) + +-- | Compute the MDC trailer appended to SEIPDv1 plaintext before encryption. +-- The trailer is: @0xd3 0x14 SHA1(nonce || plaintext || 0xd3 0x14)@. +mdcTrailerForSEIPDv1 :: IV -> B.ByteString -> B.ByteString +mdcTrailerForSEIPDv1 iv plaintext = mdcHeader <> digest + where + mdcHeader = B.pack [0xd3, 0x14] + nonce = seipdv1NonceFromIV iv + digest = BA.convert (CH.hash (nonce <> plaintext <> mdcHeader) :: CH.Digest CHA.SHA1) + +-- | The SEIPDv1 nonce: the IV bytes followed by its last two bytes (resync prefix). +seipdv1NonceFromIV :: IV -> B.ByteString +seipdv1NonceFromIV (IV ivBytes) = ivBytes <> B.drop (B.length ivBytes - 2) ivBytes + +calculateMDC :: B.ByteString -> B.ByteString -> Maybe BL.ByteString +calculateMDC nonce garbage + | B.length garbage < 23 = Nothing + | otherwise = + let digest = CH.hash (nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20]) :: CH.Digest CHA.SHA1 + in Just (BL.fromStrict (BA.convert digest :: B.ByteString)) + +-- | Verify the MDC trailer of a decrypted SEIPDv1 payload. +-- Takes the CFB nonce (blockSize+2 prefix bytes retained from decryption) +-- and the full decrypted bytes (payload + MDC packet), and returns the +-- payload without the MDC trailer on success. +validateSEIPD1MDC :: B.ByteString -> B.ByteString -> Either String B.ByteString +validateSEIPD1MDC nonce decrypted = do + when (B.length decrypted < 22) $ + Left "SEIPD1 cleartext too short to contain MDC trailer" + let (payload, trailer) = B.splitAt (B.length decrypted - 22) decrypted + when (B.take 2 trailer /= B.pack [211, 20]) $ + Left "SEIPD1 cleartext missing MDC packet trailer (tag 19)" + expectedMdc <- + case calculateMDC nonce decrypted of + Nothing -> Left "SEIPD1 cleartext too short for MDC calculation" + Just x -> Right x + let actualMdc = BL.fromStrict (B.drop 2 trailer) + when (expectedMdc /= actualMdc) $ + Left "MDC indicates tampering" + Right payload diff --git a/Codec/Encryption/OpenPGP/Compression.hs b/Codec/Encryption/OpenPGP/Compression.hs --- a/Codec/Encryption/OpenPGP/Compression.hs +++ b/Codec/Encryption/OpenPGP/Compression.hs @@ -1,9 +1,12 @@ --- Compression.hs: OpenPGP (RFC4880) compression and decompression --- Copyright © 2012-2015 Clint Adams +-- Compression.hs: OpenPGP (RFC9580) compression and decompression +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + module Codec.Encryption.OpenPGP.Compression - ( decompressPkt + ( CompressionError(..) + , renderCompressionError + , decompressPkt , compressPkts ) where @@ -15,26 +18,81 @@ import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut) +import qualified Data.ByteString.Lazy as BL -decompressPkt :: Pkt -> [Pkt] -decompressPkt (CompressedDataPkt algo bs) = - case runGetOrFail get (dfunc algo bs) of - Left _ -> [] - Right (_, _, packs) -> unBlock packs +-- | 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" + +-- | 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. +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 where - dfunc ZIP = ZlibRaw.decompress - dfunc ZLIB = Zlib.decompress - dfunc BZip2 = BZip.decompress - dfunc _ = error "Compression algorithm not supported" -decompressPkt p = [p] + dfunc Uncompressed = 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 + compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt compressPkts ca packs = let bs = runPut $ put (Block packs) cbs = cfunc ca bs - in CompressedDataPkt ca cbs + outAlgo = if isSupportedCompressionAlgorithm ca then ca else Uncompressed + in CompressedDataPkt outAlgo cbs where + cfunc Uncompressed = id cfunc ZIP = ZlibRaw.compress cfunc ZLIB = Zlib.compress cfunc BZip2 = BZip.compress - cfunc _ = error "Compression algorithm not supported" + cfunc _ = id + +isSupportedCompressionAlgorithm :: CompressionAlgorithm -> Bool +isSupportedCompressionAlgorithm Uncompressed = True +isSupportedCompressionAlgorithm ZIP = True +isSupportedCompressionAlgorithm ZLIB = True +isSupportedCompressionAlgorithm BZip2 = True +isSupportedCompressionAlgorithm (OtherCA _) = False diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -0,0 +1,2251 @@ +-- Encrypt.hs: OpenPGP (RFC9580) packet-level encryption helpers +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +module Codec.Encryption.OpenPGP.Encrypt + ( PKESKEncryptError(..) + , RecipientCapabilityNegotiationMode(..) + , RecipientCapabilityError(..) + , renderRecipientCapabilityError + , RecipientCapabilities(..) + , recipientCapabilitiesFromSubpacketPayloads + , recipientCapabilitySupportsEncryption + , RecipientTargetRejectionReason(..) + , RecipientEncryptionTargetRejected(..) + , RecipientEncryptionTargetsReport(..) + , recipientEncryptionTargetsReportFromTKAtTimestamp + , recipientEncryptionTargetsReportFromTK + , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetsFromTKAtTimestamp + , recipientEncryptionTargetFromTK + , recipientEncryptionTargetsFromTK + , PKESKVersionPolicy(..) + , RecipientPKESKVersionStrategy(..) + , RecipientPKESKVersionStrategyW(..) + , SomeRecipientPKESKVersionStrategyW(..) + , RecipientPKESKVersionSelector + , RecipientPKESKVersionSelectorTyped + , EncryptCompatibilityProfile(..) + , EncryptCompatibilityProfileW(..) + , SomeEncryptCompatibilityProfileW(..) + , RecipientEncryptionTarget(..) + , recipientEncryptionTarget + , recipientEncryptionTargetWithStrategy + , recipientEncryptionTargetWithCapabilities + , recipientEncryptionTargetWithStrategyTyped + , recipientVersionStrategyForProfile + , recipientVersionStrategyForProfileTyped + , RecipientPayloadShape(..) + , defaultRecipientPayloadShape + , SEIPDVersion(..) + , RecipientEncryptResult(..) + , RecipientEncryptRequest(..) + , RecipientEncryptRequestOverrides(..) + , encryptForRecipients + , encryptForRecipientsLegacy + , encryptForRecipientsWithCapabilityNegotiation + , PKESKV3SessionMaterial + , PKESKV6RawSessionMaterial + , PKESKSessionMaterial + , pkeskSessionAlgorithm + , pkeskSessionKey + , mkPKESKSessionMaterial + , mkPKESKV3SessionMaterial + , mkPKESKV6RawSessionMaterial + , pkeskV3SessionMaterial + , pkeskV6RawSessionMaterial + , encodeOpenPGPSessionMaterial + , generateSessionKeyMaterial + , canonicalizePKESKRecipientId + , canonicalizePKESKPacketRecipientIds + , buildPKESKv3PayloadForRecipient + , buildPKESKv3PktForRecipient + , buildPKESKPayloadForRecipient + , buildPKESKPktForRecipient + , buildPKESKPktsForRecipientTargetsWithSelector + , buildPKESKPktsForRecipientTargetsWithSelectorTyped + , encryptSEIPDv2Payload + , encryptSEIPDv1Payload + , encryptSEIPDv2WithSKESK + , encryptSEIPDv2WithSKESKBlock + , encryptSEIPDv2LiteralDataWithSKESK + , composeMessageWithSEIPDv2 + ) where + +import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher) +import Codec.Encryption.OpenPGP.CFB + ( OpenPGPCFBModeW(..) + , encryptOpenPGPCfbRaw + , mdcTrailerForSEIPDv1 + ) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS) +import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) +import Codec.Encryption.OpenPGP.Internal.CryptoECDH + ( normalizeMontgomeryPublic + , buildECDHKDFParam + , deriveECDHKek + ) +import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , deriveSKESK6KEK + , encryptSKESK6SessionKey + , seipdv2SymmetricKeySize + ) +import Codec.Encryption.OpenPGP.Policy + ( PKESKVersionPolicy(..) + , OpenPGPRFC(..) + , MessageEncryptionPolicy + , policyForRFC + , policyMessageEncryption + , messageDefaultSymmetricAlgorithm + , messageSEIPDv2SymmetricAlgorithms + , messageDefaultAEADAlgorithm + , messageDefaultChunkSize + , defaultPKESKVersionPolicy + ) +import Codec.Encryption.OpenPGP.Expirations + ( effectiveKeyPreferencesAtTimestamp + , isPKTimeValidWithSelfSignatures + , keyStateAt + , keyStateValid + , signatureEffectiveAt + ) +import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isSubkeyRevocation) +import Codec.Encryption.OpenPGP.SignatureQualities (sigCT, signatureHashedSubpacketsKnown) +import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (encryptWithOCBRFC7253) +import Control.Lens ((.~), ix) +import Control.Monad (when) +import Data.List (find, foldl', maximumBy) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (comparing) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE +import qualified Crypto.Hash.Algorithms as CHAlg +import Crypto.KDF.HKDF (expand, extract) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Generate as ECCGen +import qualified Crypto.PubKey.RSA.PKCS15 as RSA15 +import Crypto.Random.Types (MonadRandom, getRandomBytes) +import Data.Binary (put) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Bits ((.&.), shiftL, shiftR, xor) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Set as Set +import Data.Word (Word8, Word16, Word64) +import Data.Int (Int64) + +-- | Typed failures from one-pass signature packet construction. +data OPSBuildError + = OPSBuildMissingIssuerKeyId + | OPSBuildMissingIssuerFingerprint + | OPSBuildFingerprintWrongLength Int64 + | OPSBuildUnsupportedSigVersion PacketVersion + 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 + +-- | 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 + | RecipientCapabilitySelectionFailure RecipientCapabilityError + | PayloadBuildFailure String + | 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 (RecipientCapabilitySelectionFailure err) = + renderRecipientCapabilityError err +renderPKESKEncryptError (PayloadBuildFailure reason) = + "payload build failure: " ++ reason +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 + , recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm + , recipientCapabilityKeyFlags :: Set.Set KeyFlag + , recipientCapabilityFeatures :: Set.Set FeatureFlag + , recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm] + , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm] + } + deriving (Eq, Show) + +data RecipientTargetRejectionReason + = RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm + | RecipientTargetMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag) + | RecipientTargetRevoked SomePKPayload + | RecipientTargetNotValidAtTimestamp SomePKPayload ThirtyTwoBitTimeStamp + deriving (Eq, Show) + +data RecipientEncryptionTargetRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey :: SomePKPayload + , recipientEncryptionTargetRejectedCapabilities :: Maybe RecipientCapabilities + , recipientEncryptionTargetRejectedReason :: RecipientTargetRejectionReason + } + deriving (Eq, Show) + +data RecipientEncryptionTargetsReport = + RecipientEncryptionTargetsReport + { recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget] + , recipientEncryptionTargetsRejected :: [RecipientEncryptionTargetRejected] + } + deriving (Eq, Show) + +-- | Extract encrypt-relevant recipient capabilities from effective +-- self-signature subpackets. +-- +-- RFC 9580 preferred AEAD ciphersuites are currently carried through +-- 'OtherSigSub' type 39 and decoded into AEAD preferences here. +recipientCapabilitiesFromSubpacketPayloads :: + SomePKPayload + -> [SigSubPacketPayload] + -> RecipientCapabilities +recipientCapabilitiesFromSubpacketPayloads recipient payloads = + foldl' step (emptyRecipientCapabilities recipient) payloads + where + preferredAEADCiphersuitesSubpacketType :: Word8 + preferredAEADCiphersuitesSubpacketType = 39 + + step caps payload = + case payload of + KeyFlags flags -> + caps + { recipientCapabilityKeyFlags = + recipientCapabilityKeyFlags caps `Set.union` flags + } + Features features -> + caps + { recipientCapabilityFeatures = + recipientCapabilityFeatures caps `Set.union` features + } + PreferredSymmetricAlgorithms syms -> + caps + { recipientCapabilityPreferredSymmetricAlgorithms = + recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms + } + OtherSigSub subpacketType rawPayload + | subpacketType == preferredAEADCiphersuitesSubpacketType -> + caps + { recipientCapabilityPreferredAEADAlgorithms = + recipientCapabilityPreferredAEADAlgorithms caps ++ + preferredAEADAlgorithmsFromCiphersuites rawPayload + } + _ -> caps + + emptyRecipientCapabilities key = + RecipientCapabilities + { recipientCapabilityKeyVersion = _keyVersion key + , recipientCapabilityPublicKeyAlgorithm = _pkalgo key + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [] + , recipientCapabilityPreferredAEADAlgorithms = [] + } + + preferredAEADAlgorithmsFromCiphersuites :: BL.ByteString -> [AEADAlgorithm] + preferredAEADAlgorithmsFromCiphersuites = + dedupePreservingOrder . parsePairs . BL.unpack + where + parsePairs (_symAlgo:aeadAlgo:rest) = + (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest + parsePairs _ = [] + + dedupePreservingOrder = foldl' addIfMissing [] + addIfMissing acc x + | x `elem` acc = acc + | otherwise = acc ++ [x] + +recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool +recipientCapabilitySupportsEncryption caps = + let flags = recipientCapabilityKeyFlags caps + in Set.null flags || + Set.member EncryptStorageKey flags || + Set.member EncryptCommunicationsKey flags + +recipientCapabilityAdvertisesSEIPDv1Support :: RecipientCapabilities -> Bool +recipientCapabilityAdvertisesSEIPDv1Support caps = + let features = recipientCapabilityFeatures caps + in Set.null features || Set.member FeatureSEIPDv1 features + +recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool +recipientCapabilityAdvertisesSEIPDv2Support caps = + recipientCapabilityAdvertisesSEIPDv1Support caps && + Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) + +recipientEncryptionTargetFromTKAtTimestamp :: + ThirtyTwoBitTimeStamp + -> TKUnknown + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKAtTimestamp timestamp tk = + case recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) of + (target:_) -> Right target + [] -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK + +recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTK tk = + recipientEncryptionTargetFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +recipientEncryptionTargetsFromTKAtTimestamp :: + ThirtyTwoBitTimeStamp + -> TKUnknown + -> [RecipientEncryptionTarget] +recipientEncryptionTargetsFromTKAtTimestamp timestamp tk = + recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) + +recipientEncryptionTargetsReportFromTKAtTimestamp :: + ThirtyTwoBitTimeStamp + -> TKUnknown + -> RecipientEncryptionTargetsReport +recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk = + foldr classifyCandidate emptyReport (subkeyCandidates ++ [primaryCandidate]) + where + emptyReport = RecipientEncryptionTargetsReport [] [] + primaryCandidate = fst (_tkuKey tk) + primaryPreferencePayloads = + fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk) + subkeyCandidates = + mapMaybe + (\(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> Just pkp + SecretSubkeyPkt pkp _ -> Just pkp + _ -> Nothing) + (_tkuSubs tk) + classifyCandidate key report = + let caps = + recipientCapabilitiesFromSubpacketPayloads + key + (primaryPreferencePayloads ++ subkeyBindingCapabilityPayloads timestamp tk key) + keyStateRejection = recipientValidityRejectionReason timestamp tk key + in case keyStateRejection of + Just rejectionReason -> + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = rejectionReason + } : + recipientEncryptionTargetsRejected report + } + Nothing -> + if not (supportsPKESKRecipientAlgorithm key) + then + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = + RecipientTargetUnsupportedAlgorithm (_pkalgo key) + } : + recipientEncryptionTargetsRejected report + } + else + if recipientCapabilitySupportsEncryption caps + then + report + { recipientEncryptionTargetsAccepted = + recipientEncryptionTargetWithCapabilities key caps : + recipientEncryptionTargetsAccepted report + } + else + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = + RecipientTargetMissingEncryptionFlags key (recipientCapabilityKeyFlags caps) + } : + recipientEncryptionTargetsRejected report + } + +recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget] +recipientEncryptionTargetsFromTK tk = + recipientEncryptionTargetsFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +recipientEncryptionTargetsReportFromTK :: TK 'PublicTK -> RecipientEncryptionTargetsReport +recipientEncryptionTargetsReportFromTK tk = + recipientEncryptionTargetsReportFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +subkeyBindingCapabilityPayloads :: + ThirtyTwoBitTimeStamp + -> TKUnknown + -> SomePKPayload + -> [SigSubPacketPayload] +subkeyBindingCapabilityPayloads timestamp tk recipient = + maybe [] latestEffectiveBindingPayloads matchingSubkey + where + matchingSubkey = + find + (\(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient + SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient + _ -> False) + (_tkuSubs tk) + latestEffectiveBindingPayloads (_, sigs) = + maybe [] signaturePayloadsFromSignature (latestEffectiveSubkeyBindingSignature timestamp sigs) + +latestEffectiveSubkeyBindingSignature :: + ThirtyTwoBitTimeStamp + -> [SignaturePayload] + -> Maybe SignaturePayload +latestEffectiveSubkeyBindingSignature timestamp sigs = + case filter (isEffectiveSubkeyBindingSignature timestamp) sigs of + [] -> Nothing + candidates -> Just (maximumBy (comparing signatureCreationTimestamp) candidates) + +isEffectiveSubkeyBindingSignature :: + ThirtyTwoBitTimeStamp + -> SignaturePayload + -> Bool +isEffectiveSubkeyBindingSignature timestamp sig = + isSubkeyBindingSig sig && + maybe False + (\created -> + let tsValue = toInteger (unThirtyTwoBitTimeStamp timestamp) + createdValue = toInteger (unThirtyTwoBitTimeStamp created) + in createdValue <= tsValue && + maybe True + (\duration -> + if unThirtyTwoBitDuration duration == 0 + then True + else tsValue < createdValue + toInteger (unThirtyTwoBitDuration duration)) + (signatureExpirationDuration sig)) + (sigCT sig) + +signatureCreationTimestamp :: SignaturePayload -> ThirtyTwoBitTimeStamp +signatureCreationTimestamp sig = + fromMaybe (ThirtyTwoBitTimeStamp 0) (sigCT sig) + +signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration +signatureExpirationDuration sig = + case signatureHashedSubpacketsKnown sig of + Just hashed -> + foldr + (\subpacket acc -> + case subpacket of + SigSubPacket _ (SigExpirationTime duration) -> Just duration + _ -> acc) + Nothing + hashed + Nothing -> Nothing + +signaturePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload] +signaturePayloadsFromSignature sig = + case signatureHashedSubpacketsKnown sig of + Just hashed -> map (\(SigSubPacket _ payload) -> payload) hashed + Nothing -> [] + +recipientValidityRejectionReason :: + ThirtyTwoBitTimeStamp + -> TKUnknown + -> SomePKPayload + -> Maybe RecipientTargetRejectionReason +recipientValidityRejectionReason timestamp tk key + | fingerprint key == fingerprint (fst (_tkuKey tk)) = + if keyStateValid (keyStateAt (timestampToUTC timestamp) tk) + then Nothing + else Just (RecipientTargetNotValidAtTimestamp key timestamp) + | otherwise = + case findMatchingSubkeySignatures tk key of + Nothing -> Nothing + Just sigs + | subkeyRevokedAtTimestamp timestamp sigs -> + Just (RecipientTargetRevoked key) + | isPKTimeValidWithSelfSignatures (timestampToUTC timestamp) key sigs -> + Nothing + | otherwise -> + Just (RecipientTargetNotValidAtTimestamp key timestamp) + +findMatchingSubkeySignatures :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload] +findMatchingSubkeySignatures tk recipient = + snd <$> + find + (\(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient + SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient + _ -> False) + (_tkuSubs tk) + +subkeyRevokedAtTimestamp :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool +subkeyRevokedAtTimestamp timestamp = + any (\sig -> isSubkeyRevocation sig && signatureEffectiveAt (timestampToUTC timestamp) sig) + +timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime +timestampToUTC = + posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp + +supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool +supportsPKESKRecipientAlgorithm recipient = + case _pkalgo recipient of + RSA -> True + DeprecatedRSAEncryptOnly -> True + ECDH -> True + X25519 -> True + X448 -> True + _ -> False + +-- | Session-key bundle for PKESK/SKESK packet construction. +newtype PKESKV3SessionMaterial = + PKESKV3SessionMaterial + { unPKESKV3SessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +newtype PKESKV6RawSessionMaterial = + PKESKV6RawSessionMaterial + { unPKESKV6RawSessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +data PKESKSessionMaterial = + PKESKSessionMaterial + { pkeskSessionAlgorithm :: SymmetricAlgorithm + , pkeskSessionKey :: SessionKey + , pkeskEncodedSessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +mkPKESKSessionMaterial :: + SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKSessionMaterial +mkPKESKSessionMaterial symalgo sessionKey = do + v3Material <- mkPKESKV3SessionMaterial symalgo sessionKey + _v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey + pure + PKESKSessionMaterial + { pkeskSessionAlgorithm = symalgo + , pkeskSessionKey = sessionKey + , pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material + } + +mkPKESKV3SessionMaterial :: + SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKV3SessionMaterial +mkPKESKV3SessionMaterial symalgo sessionKey = do + keyBytes <- validatedSessionKeyBytes symalgo sessionKey + pure $ + PKESKV3SessionMaterial + (B.singleton (fromFVal symalgo) <> keyBytes <> checksum16Bytes keyBytes) + +mkPKESKV6RawSessionMaterial :: + SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKV6RawSessionMaterial +mkPKESKV6RawSessionMaterial symalgo sessionKey = + PKESKV6RawSessionMaterial <$> validatedSessionKeyBytes symalgo sessionKey + +pkeskV3SessionMaterial :: PKESKSessionMaterial -> PKESKV3SessionMaterial +pkeskV3SessionMaterial = + PKESKV3SessionMaterial . pkeskEncodedSessionMaterial + +pkeskV6RawSessionMaterial :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial +pkeskV6RawSessionMaterial = + PKESKV6RawSessionMaterial . unSessionKey . pkeskSessionKey + +validatedSessionKeyBytes :: + SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError B.ByteString +validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do + keyLen <- + first + (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError) + (keySize symalgo) + let actualLen = B.length sessionKey + if actualLen /= keyLen + then Left (InvalidSessionKeyLength symalgo keyLen actualLen) + else Right sessionKey + +data RecipientPKESKVersionStrategy + = RecipientPreferV6 + | RecipientForceV3Interop + deriving (Eq, Show) + +data RecipientPKESKVersionStrategyW (strategy :: RecipientPKESKVersionStrategy) where + RecipientPreferV6W :: RecipientPKESKVersionStrategyW 'RecipientPreferV6 + RecipientForceV3InteropW :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop + +data SomeRecipientPKESKVersionStrategyW where + SomeRecipientPKESKVersionStrategyW :: + RecipientPKESKVersionStrategyW strategy + -> SomeRecipientPKESKVersionStrategyW + +type RecipientPKESKVersionSelector = + SomePKPayload -> Either PKESKEncryptError RecipientPKESKVersionStrategy + +type RecipientPKESKVersionSelectorTyped = + SomePKPayload -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW + +data EncryptCompatibilityProfile + = EncryptStrictDefault + | EncryptInteropLegacy + deriving (Eq, Show) + +data EncryptCompatibilityProfileW (profile :: EncryptCompatibilityProfile) where + EncryptStrictDefaultW :: EncryptCompatibilityProfileW 'EncryptStrictDefault + EncryptInteropLegacyW :: EncryptCompatibilityProfileW 'EncryptInteropLegacy + +data SomeEncryptCompatibilityProfileW where + SomeEncryptCompatibilityProfileW :: + EncryptCompatibilityProfileW profile + -> SomeEncryptCompatibilityProfileW + +data SEIPDVersion + = SEIPDv1 + | SEIPDv2 + deriving (Eq, Show) + +type family PayloadVersionForProfile (profile :: EncryptCompatibilityProfile) :: SEIPDVersion where + PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2 + PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1 + +type family ProfileForPayloadVersion (version :: SEIPDVersion) :: EncryptCompatibilityProfile where + ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy + ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault + +data RecipientEncryptionTarget = + RecipientEncryptionTarget + { -- | Recipient key packet selected for PKESK wrapping. + recipientEncryptionTargetKey :: SomePKPayload + -- | Optional explicit PKESK version strategy hint. + -- When absent, profile defaults and auto-detection apply. + , recipientEncryptionTargetStrategy :: Maybe RecipientPKESKVersionStrategy + -- | Optional recipient capability hints used by negotiation-enabled + -- encryption to choose common symmetric/AEAD algorithms. + , recipientEncryptionTargetCapabilities :: Maybe RecipientCapabilities + } + deriving (Eq, Show) + +recipientEncryptionTarget :: SomePKPayload -> RecipientEncryptionTarget +recipientEncryptionTarget recipient = + RecipientEncryptionTarget recipient Nothing Nothing + +recipientEncryptionTargetWithStrategy :: SomePKPayload -> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget +recipientEncryptionTargetWithStrategy recipient strategy = + RecipientEncryptionTarget recipient (Just strategy) Nothing + +recipientEncryptionTargetWithCapabilities :: + SomePKPayload + -> RecipientCapabilities + -> RecipientEncryptionTarget +recipientEncryptionTargetWithCapabilities recipient capabilities = + RecipientEncryptionTarget recipient Nothing (Just capabilities) + +recipientEncryptionTargetWithStrategyTyped :: SomePKPayload + -> RecipientPKESKVersionStrategyW strategy + -> RecipientEncryptionTarget +recipientEncryptionTargetWithStrategyTyped recipient strategyW = + recipientEncryptionTargetWithStrategy recipient (demoteRecipientStrategy strategyW) + +recipientVersionStrategyForProfile :: + EncryptCompatibilityProfile + -> RecipientEncryptionTarget + -> Either PKESKEncryptError RecipientPKESKVersionStrategy +recipientVersionStrategyForProfile profile target = + case promoteEncryptCompatibilityProfile profile of + SomeEncryptCompatibilityProfileW profileW -> + demoteSomeRecipientStrategy <$> + recipientVersionStrategyForProfileTyped profileW target + +recipientVersionStrategyForProfileTyped :: + EncryptCompatibilityProfileW profile + -> RecipientEncryptionTarget + -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW +recipientVersionStrategyForProfileTyped profile target = + Right $ + case recipientEncryptionTargetStrategy target of + Just strategy -> + promoteRecipientStrategy strategy + Nothing -> + case profile of + EncryptStrictDefaultW -> + autoDetectRecipientVersionStrategy + (recipientEncryptionTargetKey target) + EncryptInteropLegacyW -> + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +profileForPayloadVersionW :: + RecipientEncryptRequestOverrides version + -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version) +profileForPayloadVersionW overrides = + case overrides of + RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptStrictDefaultW + RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptInteropLegacyW + +autoDetectRecipientVersionStrategy :: SomePKPayload + -> SomeRecipientPKESKVersionStrategyW +autoDetectRecipientVersionStrategy recipient + | _keyVersion recipient == V6 = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W + | _pkalgo recipient `elem` [X25519, X448] = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W + | otherwise = + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +data RecipientPayloadShape = + RecipientPayloadShape + { recipientPayloadDataType :: DataType + , recipientPayloadFileName :: FileName + , recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp + , recipientPayloadUseOnePassSignatures :: Bool + , recipientPayloadSignatures :: [SignaturePayload] + } + deriving (Eq, Show) + +defaultRecipientPayloadShape :: RecipientPayloadShape +defaultRecipientPayloadShape = + RecipientPayloadShape + { recipientPayloadDataType = BinaryData + , recipientPayloadFileName = BL.empty + , recipientPayloadTimestamp = 0 + , recipientPayloadUseOnePassSignatures = False + , recipientPayloadSignatures = [] + } + +data RecipientEncryptResult = + RecipientEncryptResult + { recipientEncryptPackets :: [Pkt] + , recipientEncryptSessionMaterial :: PKESKSessionMaterial + } + deriving (Eq, Show) + +data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where + RecipientEncryptRequestSEIPDv1Overrides :: + { recipientEncryptRequestIVOverride :: Maybe IV + } -> RecipientEncryptRequestOverrides 'SEIPDv1 + -- | For SEIPDv2 requests: + -- - when AEAD override is 'Nothing', encrypt-side capability negotiation + -- selects a common recipient-supported AEAD algorithm (if enabled). + -- - when AEAD override is 'Just', the explicit AEAD wins. + RecipientEncryptRequestSEIPDv2Overrides :: + { recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm + , recipientEncryptRequestChunkSizeOverride :: Maybe Word8 + , recipientEncryptRequestSaltOverride :: Maybe Salt + } -> RecipientEncryptRequestOverrides 'SEIPDv2 + +data RecipientEncryptRequest (v :: SEIPDVersion) = + RecipientEncryptRequest + { -- | Recipient encryption targets. At least one target is required. + recipientEncryptRequestTargets :: [RecipientEncryptionTarget] + , recipientEncryptRequestPayloadShape :: RecipientPayloadShape + , recipientEncryptRequestPayload :: B.ByteString + -- | Explicit symmetric algorithm override. When 'Nothing', the selected + -- mode (negotiated or legacy) determines algorithm selection. + , recipientEncryptRequestSymmetricOverride :: Maybe SymmetricAlgorithm + , recipientEncryptRequestOverrides :: RecipientEncryptRequestOverrides v + } + +deriving instance Eq (RecipientEncryptRequestOverrides v) +deriving instance Show (RecipientEncryptRequestOverrides v) +deriving instance Eq (RecipientEncryptRequest v) +deriving instance Show (RecipientEncryptRequest v) + +-- | Encode the RFC 9580 PKESK/SKESK session-key material: +-- one-octet algorithm ID, raw session key, then 16-bit checksum. +encodeOpenPGPSessionMaterial :: + SymmetricAlgorithm -> SessionKey -> Either PKESKEncryptError B.ByteString +encodeOpenPGPSessionMaterial symalgo sessionKey = + unPKESKV3SessionMaterial <$> mkPKESKV3SessionMaterial symalgo sessionKey + +-- | Generate a fresh session key and return both raw and encoded forms. +generateSessionKeyMaterial :: + MonadRandom m + => SymmetricAlgorithm + -> m (Either PKESKEncryptError PKESKSessionMaterial) +generateSessionKeyMaterial symalgo = + case keySize symalgo of + Left err -> pure (Left (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError 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 :: + BL.ByteString -> Either PKESKEncryptError BL.ByteString +canonicalizeRecipientKeyIdentifier rid + | BL.length rid == 20 || BL.length rid == 32 = Right rid + | BL.length rid == 21 && BL.head rid == 0x04 = Right (BL.tail rid) + | BL.length rid == 33 && BL.head rid == 0x06 = Right (BL.tail rid) + | otherwise = + Left + (InvalidRecipientIdentifier + ("unsupported PKESK recipient identifier length/prefix: " ++ + show (BL.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 + => PKESKVersionPolicy + -> SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayload) +buildPKESKPayloadForRecipient policy recipient material = + case policy of + ForceV3Interop -> + buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial material) + PreferV6 -> + case _pkalgo recipient of + RSA -> fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material) + ECDH -> fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material) + X25519 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material)) + X448 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material)) + pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + + +-- | Build a PKESK packet for one recipient key according to the selected version policy. +buildPKESKPktForRecipient :: + MonadRandom m + => PKESKVersionPolicy + -> SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError Pkt) +buildPKESKPktForRecipient policy recipient material = + fmap + (fmap PKESKPkt) + (buildPKESKPayloadForRecipient policy recipient material) + + +-- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop. +buildPKESKv3PayloadForRecipient :: + MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayload) +buildPKESKv3PayloadForRecipient recipient material = + fmap (fmap PKESKPayloadV3Packet) (buildPKESKv3PayloadForRecipientTyped recipient material) + +buildPKESKv3PayloadForRecipientTyped :: + MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildPKESKv3PayloadForRecipientTyped recipient material = + case _pkalgo recipient of + RSA -> buildRsaPKESKv3 recipient material + DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material + ECDH -> buildECDHPKESKv3 recipient material + pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + +-- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. +buildPKESKv3PktForRecipient :: + MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError Pkt) +buildPKESKv3PktForRecipient recipient material = + fmap (fmap PKESKPkt) (buildPKESKv3PayloadForRecipient recipient material) + +-- | Build PKESK packets for all recipients with a single shared session key. + +buildPKESKPktsForRecipientTargetsWithSelector :: + MonadRandom m + => (RecipientEncryptionTarget -> Either PKESKEncryptError RecipientPKESKVersionStrategy) + -> [RecipientEncryptionTarget] + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError [Pkt]) +buildPKESKPktsForRecipientTargetsWithSelector selector targets material + = buildPKESKPktsForRecipientTargetsWithSelectorTyped + (\target -> + promoteRecipientStrategy <$> selector target) + targets + material + +buildPKESKPktsForRecipientTargetsWithSelectorTyped :: + MonadRandom m + => (RecipientEncryptionTarget -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW) + -> [RecipientEncryptionTarget] + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError [Pkt]) +buildPKESKPktsForRecipientTargetsWithSelectorTyped selector targets material + | null targets = pure (Left NoRecipientsProvided) + | otherwise = + case preparePKESKVersionedMaterial material of + Left err -> pure (Left err) + Right (v3Material, v6RawMaterial) -> do + pkeskResults <- + mapM + (\target -> + case selector target of + Left err -> pure (Left err) + Right (SomeRecipientPKESKVersionStrategyW RecipientPreferV6W) -> + buildPKESKPktForRecipientWithPreparedPayload + RecipientPreferV6W + (recipientEncryptionTargetKey target) + (RecipientPreferV6Payload material v6RawMaterial) + Right (SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW) -> + buildPKESKPktForRecipientWithPreparedPayload + RecipientForceV3InteropW + (recipientEncryptionTargetKey target) + (RecipientForceV3Payload v3Material)) + targets + pure (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds) + +preparePKESKVersionedMaterial :: + PKESKSessionMaterial + -> Either PKESKEncryptError (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial) +preparePKESKVersionedMaterial material = do + v3Material <- + mkPKESKV3SessionMaterial + (pkeskSessionAlgorithm material) + (pkeskSessionKey material) + v6RawMaterial <- + mkPKESKV6RawSessionMaterial + (pkeskSessionAlgorithm material) + (pkeskSessionKey material) + pure (v3Material, v6RawMaterial) + +data RecipientPKESKRequestPayload (strategy :: RecipientPKESKVersionStrategy) where + RecipientForceV3Payload :: + PKESKV3SessionMaterial + -> RecipientPKESKRequestPayload 'RecipientForceV3Interop + RecipientPreferV6Payload :: + PKESKSessionMaterial + -> PKESKV6RawSessionMaterial + -> RecipientPKESKRequestPayload 'RecipientPreferV6 + +buildPKESKPktForRecipientWithPreparedPayload :: + MonadRandom m + => RecipientPKESKVersionStrategyW strategy + -> SomePKPayload + -> RecipientPKESKRequestPayload strategy + -> m (Either PKESKEncryptError Pkt) +buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload = + fmap fmapPKESKPkt payloadResult + where + fmapPKESKPkt = fmap PKESKPkt + payloadResult = + case (strategy, payload) of + (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) -> + buildPKESKv3PayloadForRecipient recipient v3Material + (RecipientPreferV6W, RecipientPreferV6Payload material v6RawMaterial) -> + case _pkalgo recipient of + RSA -> + fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material) + ECDH -> + fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material) + X25519 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX25519PKESKv6 recipient v6RawMaterial) + X448 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX448PKESKv6 recipient v6RawMaterial) + pka -> + pure (Left (UnsupportedRecipientAlgorithm pka)) + +-- | Encrypt for recipient targets with capability negotiation enabled. +-- +-- By default this negotiates a common symmetric and (for SEIPDv2) AEAD +-- algorithm from recipient capabilities when available. Explicit request +-- overrides still take precedence. +encryptForRecipients :: + MonadRandom m + => RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipients = + encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn + +-- | Encrypt for recipient targets without recipient capability negotiation. +-- +-- This preserves legacy behavior by using policy defaults unless request +-- overrides are provided. +encryptForRecipientsLegacy :: + MonadRandom m + => RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipientsLegacy = + encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOff + +-- | Encrypt for recipient targets with an explicit capability-negotiation mode. +-- +-- When negotiation is on, symmetric and AEAD selection use the common +-- intersection of recipient preferences constrained by the active policy. +-- When off, policy defaults are used. +encryptForRecipientsWithCapabilityNegotiation :: + MonadRandom m + => RecipientCapabilityNegotiationMode + -> RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipientsWithCapabilityNegotiation negotiationMode request + | null targets = pure (Left NoRecipientsProvided) + | otherwise = + case selectSymmetricAlgorithm negotiationMode request messagePolicy targets of + Left err -> pure (Left err) + Right symalgo -> do + sessionMaterialResult <- generateSessionKeyMaterial symalgo + case sessionMaterialResult of + Left err -> pure (Left err) + Right sessionMaterial -> do + pkeskResult <- + buildPKESKPktsForRecipientTargetsWithSelectorTyped + (recipientVersionStrategyForProfileTyped profileW) + targets + sessionMaterial + case pkeskResult of + Left err -> pure (Left err) + Right pkeskPkts -> do + payloadResult <- case recipientEncryptRequestOverrides request of + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = aeadOverride + , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride + , recipientEncryptRequestSaltOverride = saltOverride + } -> + case recipientsMissingSEIPDv2Support targets of + [] -> do + case selectAEADAlgorithm negotiationMode messagePolicy targets aeadOverride of + Left err -> pure (Left err) + Right aead -> do + salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride + let chunkSize = + maybe + (messageDefaultChunkSize messagePolicy) + id + chunkSizeOverride + pure $ + buildEncryptedPacketSequenceWithShape + symalgo + aead + chunkSize + (recipientEncryptRequestPayloadShape request) + salt + (pkeskSessionKey sessionMaterial) + pkeskPkts + (recipientEncryptRequestPayload request) + _missingSEIPDv2 -> + case recipientsMissingSEIPDv1Support targets of + [] -> + buildSEIPDv1PayloadWithIV + symalgo + sessionMaterial + pkeskPkts + Nothing + missingSEIPDv1 -> + pure + (Left + (RecipientCapabilitySelectionFailure + (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1))) + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = ivOverride } -> + case recipientsMissingSEIPDv1Support targets of + [] -> + buildSEIPDv1PayloadWithIV + symalgo + sessionMaterial + pkeskPkts + ivOverride + missingSEIPDv1 -> + pure + (Left + (RecipientCapabilitySelectionFailure + (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1))) + pure $ + fmap + (\pkts -> + RecipientEncryptResult + { recipientEncryptPackets = pkts + , recipientEncryptSessionMaterial = sessionMaterial + }) + payloadResult + where + targets = recipientEncryptRequestTargets request + profileW = + profileForPayloadVersionW (recipientEncryptRequestOverrides request) + messagePolicy = + case profileW of + EncryptStrictDefaultW -> + policyMessageEncryption (policyForRFC RFC9580) + EncryptInteropLegacyW -> + policyMessageEncryption (policyForRFC RFC4880) + + buildSEIPDv1PayloadWithIV :: + MonadRandom m + => SymmetricAlgorithm + -> PKESKSessionMaterial + -> [Pkt] + -> Maybe IV + -> m (Either PKESKEncryptError [Pkt]) + buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do + ivResult <- + case ivOverride of + Just iv -> pure (Right iv) + Nothing -> + let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial) + in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of + Left err -> pure (Left (PayloadBuildFailure (renderCipherError err))) + Right n -> fmap (Right . IV) (getRandomBytes n) + case ivResult of + Left err -> pure (Left err) + Right iv -> + pure $ + buildEncryptedPacketSequenceWithShapeSEIPDv1 + symalgo + iv + (recipientEncryptRequestPayloadShape request) + (pkeskSessionKey sessionMaterial) + pkeskPkts + (recipientEncryptRequestPayload request) + + recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload] + recipientsMissingSEIPDv1Support = + map recipientEncryptionTargetKey . + filter (not . targetAdvertisesSEIPDv1Support) + + recipientsMissingSEIPDv2Support :: [RecipientEncryptionTarget] -> [SomePKPayload] + recipientsMissingSEIPDv2Support = + map recipientEncryptionTargetKey . + filter (not . targetAdvertisesSEIPDv2Support) + + targetAdvertisesSEIPDv1Support :: RecipientEncryptionTarget -> Bool + targetAdvertisesSEIPDv1Support target = + case recipientEncryptionTargetCapabilities target of + Nothing -> True + Just caps -> recipientCapabilityAdvertisesSEIPDv1Support caps + + targetAdvertisesSEIPDv2Support :: RecipientEncryptionTarget -> Bool + targetAdvertisesSEIPDv2Support target = + case recipientEncryptionTargetCapabilities target of + Nothing -> True + Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps + +selectSymmetricAlgorithm :: + RecipientCapabilityNegotiationMode + -> RecipientEncryptRequest v + -> MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError SymmetricAlgorithm +selectSymmetricAlgorithm negotiationMode request messagePolicy targets = + case recipientEncryptRequestSymmetricOverride request of + Just override -> Right override + Nothing -> + case negotiationMode of + RecipientCapabilityNegotiationOff -> + Right (messageDefaultSymmetricAlgorithm messagePolicy) + RecipientCapabilityNegotiationOn -> + negotiateSymmetricAlgorithm messagePolicy targets + +selectAEADAlgorithm :: + RecipientCapabilityNegotiationMode + -> MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Maybe AEADAlgorithm + -> Either PKESKEncryptError AEADAlgorithm +selectAEADAlgorithm negotiationMode messagePolicy targets override = + case override of + Just explicit -> Right explicit + Nothing -> + case negotiationMode of + RecipientCapabilityNegotiationOff -> + Right (messageDefaultAEADAlgorithm messagePolicy) + RecipientCapabilityNegotiationOn -> + negotiateAEADAlgorithm messagePolicy targets + +negotiateSymmetricAlgorithm :: + MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError SymmetricAlgorithm +negotiateSymmetricAlgorithm messagePolicy targets = + chooseCommonAlgorithm + policyOrder + recipientChoices + (RecipientCapabilityNoCommonSymmetricAlgorithms (concat recipientChoices)) + where + policyOrder = + case messageSEIPDv2SymmetricAlgorithms messagePolicy of + [] -> [messageDefaultSymmetricAlgorithm messagePolicy] + syms -> syms + recipientChoices = map choicesForTarget targets + choicesForTarget target = + case recipientEncryptionTargetCapabilities target of + Just caps -> + let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps + allowed = [alg | alg <- policyOrder, alg `elem` preferred] + in if null allowed + then policyOrder + else allowed + Nothing -> policyOrder + +negotiateAEADAlgorithm :: + MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError AEADAlgorithm +negotiateAEADAlgorithm messagePolicy targets = + chooseCommonAlgorithm + policyOrder + recipientChoices + (RecipientCapabilityNoCommonAEADAlgorithms (concat recipientChoices)) + where + policyOrder = foldl' addIfMissing [] (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM]) + recipientChoices = map choicesForTarget targets + choicesForTarget target = + case recipientEncryptionTargetCapabilities target of + Just caps -> + let preferred = recipientCapabilityPreferredAEADAlgorithms caps + allowed = [alg | alg <- policyOrder, alg `elem` preferred] + in if null allowed + then policyOrder + else allowed + Nothing -> policyOrder + addIfMissing acc x + | x `elem` acc = acc + | otherwise = acc ++ [x] + +chooseCommonAlgorithm :: + Eq a + => [a] + -> [[a]] + -> RecipientCapabilityError + -> Either PKESKEncryptError a +chooseCommonAlgorithm policyOrder recipientChoices err = + case recipientChoices of + [] -> Left (RecipientCapabilitySelectionFailure err) + (firstChoices:restChoices) -> + let common = foldl' intersectOrdered firstChoices restChoices + orderedCommon = [alg | alg <- policyOrder, alg `elem` common] + in case orderedCommon of + (selected:_) -> Right selected + [] -> Left (RecipientCapabilitySelectionFailure err) + where + intersectOrdered as bs = [a | a <- as, a `elem` bs] + +promoteRecipientStrategy :: + RecipientPKESKVersionStrategy + -> SomeRecipientPKESKVersionStrategyW +promoteRecipientStrategy RecipientPreferV6 = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W +promoteRecipientStrategy RecipientForceV3Interop = + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +demoteRecipientStrategy :: + RecipientPKESKVersionStrategyW strategy + -> RecipientPKESKVersionStrategy +demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6 +demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop + +demoteSomeRecipientStrategy :: + SomeRecipientPKESKVersionStrategyW + -> RecipientPKESKVersionStrategy +demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) = + demoteRecipientStrategy strategyW + +promoteEncryptCompatibilityProfile :: + EncryptCompatibilityProfile + -> SomeEncryptCompatibilityProfileW +promoteEncryptCompatibilityProfile EncryptStrictDefault = + SomeEncryptCompatibilityProfileW EncryptStrictDefaultW +promoteEncryptCompatibilityProfile EncryptInteropLegacy = + SomeEncryptCompatibilityProfileW EncryptInteropLegacyW + +-- | High-level encrypt-side helper for public-key recipient encryption. +-- +-- Returns a complete packet sequence: +-- @[PKESK ..., SEIPD2 ...]@. + + + + + + + + + +buildEncryptedPacketSequence :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> RecipientPayloadShape + -> Salt + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either String [Pkt] +buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = + first renderPKESKEncryptError + (buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload) + +buildEncryptedPacketSequenceWithShape :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> RecipientPayloadShape + -> Salt + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either PKESKEncryptError [Pkt] +buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do + onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape) + let signatures = recipientPayloadSignatures payloadShape + literalBlock = + Block + (onePassSignatures ++ + [ LiteralDataPkt + (recipientPayloadDataType payloadShape) + (recipientPayloadFileName payloadShape) + (recipientPayloadTimestamp payloadShape) + (BL.fromStrict payload) + ] ++ + map SignaturePkt signatures) + ciphertext <- + first PayloadBuildFailure $ + encryptSEIPDv2Payload + symalgo + aead + chunkSize + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) + Right + (pkesks ++ + [SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext))]) + +-- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext. +encryptSEIPDv1Payload :: + SymmetricAlgorithm + -> IV + -> SessionKey + -> B.ByteString -- ^ inner packet block plaintext + -> Either String B.ByteString +encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext = + let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext + in first + renderCipherError + (encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW symalgo iv cleartextWithMDC keyBytes) + +-- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC). +buildEncryptedPacketSequenceWithShapeSEIPDv1 :: + SymmetricAlgorithm + -> IV + -> RecipientPayloadShape + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either PKESKEncryptError [Pkt] +buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do + onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape) + let signatures = recipientPayloadSignatures payloadShape + literalBlock = + Block + (onePassSignatures ++ + [ LiteralDataPkt + (recipientPayloadDataType payloadShape) + (recipientPayloadFileName payloadShape) + (recipientPayloadTimestamp payloadShape) + (BL.fromStrict payload) + ] ++ + map SignaturePkt signatures) + ciphertext <- + first PayloadBuildFailure $ + encryptSEIPDv1Payload symalgo iv sessionKey (BL.toStrict (runPut (put literalBlock))) + Right + (pkesks ++ + [SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))]) + +buildOnePassSignaturePackets :: RecipientPayloadShape -> Either OPSBuildError [Pkt] +buildOnePassSignaturePackets payloadShape + | not (recipientPayloadUseOnePassSignatures payloadShape) = Right [] + | null signatures = Right [] + | otherwise = + fmap (map OnePassSignaturePkt) $ + sequence (zipWith buildOnePassSignature nestedFlags (reverse signatures)) + where + signatures = recipientPayloadSignatures payloadShape + nestedFlags = replicate (length signatures - 1) True ++ [False] + +data OnePassSignatureBuildCase where + OnePassSignatureBuildCaseV3 :: + SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseV4 :: + SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseV6 :: + SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseOther :: + PacketVersion -> OnePassSignatureBuildCase + +onePassSignatureBuildCase :: SignaturePayload -> OnePassSignatureBuildCase +onePassSignatureBuildCase sig = + case toSomeSignaturePayload sig of + SomeSignaturePayload (payload@SigPayloadV3Data {}) -> + OnePassSignatureBuildCaseV3 payload + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + OnePassSignatureBuildCaseV4 payload + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + OnePassSignatureBuildCaseV6 payload + SomeSignaturePayload (SigPayloadOtherData version _) -> + OnePassSignatureBuildCaseOther version + +buildOnePassSignature :: NestedFlag -> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload +buildOnePassSignature nestedFlag sig = + case onePassSignatureBuildCase sig of + OnePassSignatureBuildCaseV3 (SigPayloadV3Data sigType _ issuerKeyId pubkeyAlgo hashAlgo _ _) -> + Right + (OPSPayloadV3Packet + (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)) + OnePassSignatureBuildCaseV4 (SigPayloadV4Data sigType pubkeyAlgo hashAlgo hashedSubpackets unhashedSubpackets _ _) -> + case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of + Just issuerKeyId -> + Right + (OPSPayloadV3Packet + (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)) + Nothing -> + Left OPSBuildMissingIssuerKeyId + OnePassSignatureBuildCaseV6 (SigPayloadV6Data sigType pubkeyAlgo hashAlgo salt hashedSubpackets unhashedSubpackets _ _) -> + case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV6) hashedSubpackets unhashedSubpackets of + Just signerFingerprint + | BL.length signerFingerprint == 32 -> + Right + (OPSPayloadV6Packet + (OPSPayloadV6 sigType hashAlgo pubkeyAlgo salt signerFingerprint nestedFlag)) + | otherwise -> + Left (OPSBuildFingerprintWrongLength (BL.length signerFingerprint)) + Nothing -> + Left OPSBuildMissingIssuerFingerprint + OnePassSignatureBuildCaseOther version -> + Left (OPSBuildUnsupportedSigVersion version) + +signatureIssuerKeyId :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId +signatureIssuerKeyId hashedSubpackets unhashedSubpackets = + case findIssuerKeyId hashedSubpackets of + Just issuerKeyId -> Just issuerKeyId + Nothing -> + case findIssuerKeyId unhashedSubpackets of + Just issuerKeyId -> Just issuerKeyId + Nothing -> + case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV4) hashedSubpackets unhashedSubpackets of + Just issuerFingerprintBytes -> + if BL.length issuerFingerprintBytes >= 8 + then + Just + (EightOctetKeyId + (BL.drop (BL.length issuerFingerprintBytes - 8) issuerFingerprintBytes)) + else Nothing + Nothing -> Nothing + +signatureIssuerFingerprint :: + PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe BL.ByteString +signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = + unFingerprint <$> findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets + +findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId +findIssuerKeyId subpackets = + case find isIssuerKeyIdSubpacket subpackets of + Just (SigSubPacket _ (Issuer issuerKeyId)) -> Just issuerKeyId + _ -> Nothing + +findIssuerFingerprint :: + PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint +findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = + case findIssuerFingerprintIn expectedVersion hashedSubpackets of + Just issuerFingerprint -> Just issuerFingerprint + Nothing -> findIssuerFingerprintIn expectedVersion unhashedSubpackets + +findIssuerFingerprintIn :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint +findIssuerFingerprintIn expectedVersion subpackets = + case find (isIssuerFingerprintSubpacket expectedVersion) subpackets of + Just (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) -> Just issuerFingerprint + _ -> Nothing + +isIssuerKeyIdSubpacket :: SigSubPacket -> Bool +isIssuerKeyIdSubpacket (SigSubPacket _ (Issuer _)) = True +isIssuerKeyIdSubpacket _ = False + +isIssuerFingerprintSubpacket :: PacketVersion -> SigSubPacket -> Bool +isIssuerFingerprintSubpacket expectedVersion (SigSubPacket _ (IssuerFingerprint version _)) = + BTypes.issuerFingerprintVersionToPacketVersion version == expectedVersion +isIssuerFingerprintSubpacket _ _ = False + +buildRsaPKESKv6 :: + MonadRandom m + => SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildRsaPKESKv6 recipient material = + case _pubkey recipient of + RSAPubKey (RSA_PublicKey publicKey) -> do + encrypted <- RSA15.encrypt publicKey (pkeskEncodedSessionMaterial material) + pure $ + fmap + (\esk -> + let mpiEsk = runPut (put (MPI (os2ip esk))) + in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk) + (first (RecipientKeyWrapFailure RSA . show) encrypted) + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + RSA + "recipient PKPayload does not contain an RSA public key")) + +buildRsaPKESKv3 :: + MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildRsaPKESKv3 recipient material = + case _pubkey recipient of + RSAPubKey (RSA_PublicKey publicKey) -> + case eightOctetKeyID recipient of + Left err -> + pure + (Left + (InvalidRecipientKeyMaterial + (_pkalgo recipient) + ("failed to derive PKESKv3 recipient key ID: " ++ err))) + Right eoki -> do + encrypted <- RSA15.encrypt publicKey (unPKESKV3SessionMaterial material) + pure $ + fmap + (\esk -> + PKESKPayloadV3 + 3 + eoki + (_pkalgo recipient) + (MPI (os2ip esk) :| [])) + (first (RecipientKeyWrapFailure (_pkalgo recipient) . show) encrypted) + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + (_pkalgo recipient) + "recipient PKPayload does not contain an RSA public key")) + +buildECDHPKESKv3 :: + MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildECDHPKESKv3 recipient material = + case _pubkey recipient of + ECDHPubKey ecdhPub kdfHA kdfSA -> + case eightOctetKeyID recipient of + Left err -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + ("failed to derive PKESKv3 recipient key ID: " ++ err))) + Right eoki -> + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do + (ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub) + case point2MBS (ECDSA.public_q ephemeralPub) of + Nothing -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "failed to serialize ECDH ephemeral point")) + Just ephemeralBytes -> + pure $ + buildEcdhV3Payload + recipient + eoki + ECDH + ecdhPub + kdfHA + kdfSA + ephemeralBytes + (BA.convert + (ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephemeralPriv) + (ECDSA.public_q recipientPub)) :: + B.ByteString) + material + EdDSAPubKey Ed25519 recipientPoint -> do + ephSecretRaw <- getRandomBytes 32 + pure $ + do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C25519.publicKey recipientPublicBytes + let ephPublicBytes = + B.cons 0x40 (BA.convert (C25519.toPublic ephSecret) :: B.ByteString) + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV3Payload + recipient + eoki + ECDH + ecdhPub + kdfHA + kdfSA + ephPublicBytes + sharedSecret + material + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "recipient ECDH public key is not RFC6637-compatible")) + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "recipient PKPayload does not contain ECDH public key material")) + +buildECDHPKESKv6 :: + MonadRandom m + => SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildECDHPKESKv6 recipient material = + case _pubkey recipient of + ECDHPubKey ecdhPub kdfHA kdfSA -> + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do + (ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub) + case point2MBS (ECDSA.public_q ephemeralPub) of + Nothing -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "failed to serialize ECDH ephemeral point")) + Just ephemeralBytes -> + pure $ + buildEcdhV6Esk + recipient + ECDH + ecdhPub + kdfHA + kdfSA + ephemeralBytes + (BA.convert + (ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephemeralPriv) + (ECDSA.public_q recipientPub)) :: + B.ByteString) + material + EdDSAPubKey Ed25519 recipientPoint -> do + ephSecretRaw <- getRandomBytes 32 + pure $ + do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C25519.publicKey recipientPublicBytes + let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material + EdDSAPubKey Ed448 recipientPoint -> do + ephSecretRaw <- getRandomBytes 56 + pure $ + do recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C448.secretKey (leftPadTo 56 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) . + CE.eitherCryptoError $ + C448.publicKey recipientPublicBytes + let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "recipient ECDH public key is not ECDSA/X25519/X448-compatible")) + _ -> + pure + (Left + (InvalidRecipientKeyMaterial + ECDH + "recipient PKPayload does not contain ECDH public key material")) + +buildX25519PKESKv6 :: + MonadRandom m + => SomePKPayload + -> PKESKV6RawSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildX25519PKESKv6 recipient material = do + ephSecretRaw <- getRandomBytes 32 + pure $ + do recipientPublic <- extractX25519RecipientPublic recipient + ephSecret <- + first (RecipientKeyWrapFailure X25519 . show) . + CE.eitherCryptoError $ + C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure X25519 . show) . + CE.eitherCryptoError $ + C25519.publicKey recipientPublic + let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret + wrapped <- + first (RecipientKeyWrapFailure X25519) . + aesKeyWrapRFC3394 AES128 kek $ + unPKESKV6RawSessionMaterial material + esk <- encodeV6X25519Esk ephPublicBytes wrapped + Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X25519 (BL.fromStrict esk)) + +buildX448PKESKv6 :: + MonadRandom m + => SomePKPayload + -> PKESKV6RawSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildX448PKESKv6 recipient material = do + ephSecretRaw <- getRandomBytes 56 + pure $ + do recipientPublic <- extractX448RecipientPublic recipient + ephSecret <- + first (RecipientKeyWrapFailure X448 . show) . + CE.eitherCryptoError $ + C448.secretKey (leftPadTo 56 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure X448 . show) . + CE.eitherCryptoError $ + C448.publicKey recipientPublic + let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret + wrapped <- + first (RecipientKeyWrapFailure X448) . + aesKeyWrapRFC3394 AES256 kek $ + unPKESKV6RawSessionMaterial material + esk <- encodeV6X448Esk ephPublicBytes wrapped + Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X448 (BL.fromStrict esk)) + +buildEcdhV6Esk :: SomePKPayload + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKSessionMaterial + -> Either PKESKEncryptError PKESKPayloadV6 +buildEcdhV6Esk recipient pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do + kdfParam <- + first (RecipientKdfFailure pka) $ + buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA + kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam + wrapped <- + first (RecipientKeyWrapFailure pka) . + aesKeyWrapRFC3394 kdfSA kek $ + padToMultipleOf8 (pkeskEncodedSessionMaterial material) + esk <- encodeV6EcdhEsk ephemeralBytes wrapped + Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) pka (BL.fromStrict esk)) + +buildEcdhV3Payload :: SomePKPayload + -> EightOctetKeyId + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKV3SessionMaterial + -> Either PKESKEncryptError PKESKPayloadV3 +buildEcdhV3Payload recipient eoki pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do + kdfParam <- + first (RecipientKdfFailure pka) $ + buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA + kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam + wrapped <- + first (RecipientKeyWrapFailure pka) . + aesKeyWrapRFC3394 kdfSA kek $ + padToMultipleOf8 (unPKESKV3SessionMaterial material) + Right + (PKESKPayloadV3 + 3 + eoki + pka + (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)])) + +recipientKeyIdentifier :: SomePKPayload -> BL.ByteString +recipientKeyIdentifier = unFingerprint . fingerprint + +encodeV6EcdhEsk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString +encodeV6EcdhEsk ephemeral wrapped = do + let ephLen = B.length ephemeral + if ephLen > 255 + then Left (RecipientKeyWrapFailure ECDH "ephemeral key encoding is too large") + else Right (B.singleton (fromIntegral ephLen) <> ephemeral <> wrapped) + +encodeV6X25519Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString +encodeV6X25519Esk ephemeral wrapped + | B.length ephemeral /= 32 = + Left (RecipientKeyWrapFailure X25519 "X25519 ephemeral key must be exactly 32 octets") + | B.length wrapped > 255 = + Left (RecipientKeyWrapFailure X25519 "wrapped session key encoding is too large") + | otherwise = + Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped) + +encodeV6X448Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString +encodeV6X448Esk ephemeral wrapped + | B.length ephemeral /= 56 = + Left (RecipientKeyWrapFailure X448 "X448 ephemeral key must be exactly 56 octets") + | B.length wrapped > 255 = + Left (RecipientKeyWrapFailure X448 "wrapped session key encoding is too large") + | otherwise = + Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped) + +extractX25519RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString +extractX25519RecipientPublic recipient = + case _pubkey recipient of + EdDSAPubKey Ed25519 point -> + normalizeX25519Public (edPointBytes point) + ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ -> + normalizeX25519Public (edPointBytes point) + other -> + Left + (InvalidRecipientKeyMaterial + X25519 + ("expected X25519-compatible recipient key, got " ++ show other)) + +extractX448RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString +extractX448RecipientPublic recipient = + case _pubkey recipient of + EdDSAPubKey Ed448 point -> + normalizeX448Public (edPointBytes point) + ECDHPubKey (EdDSAPubKey Ed448 point) _ _ -> + normalizeX448Public (edPointBytes point) + other -> + Left + (InvalidRecipientKeyMaterial + X448 + ("expected X448-compatible recipient key, got " ++ show other)) + +normalizeX25519Public :: B.ByteString -> Either PKESKEncryptError B.ByteString +normalizeX25519Public = + first (InvalidRecipientKeyMaterial X25519) . + normalizeMontgomeryPublic + 32 + "invalid X25519 public key length/prefix: " + +normalizeX448Public :: B.ByteString -> Either PKESKEncryptError B.ByteString +normalizeX448Public = + first (InvalidRecipientKeyMaterial X448) . + normalizeMontgomeryPublic + 56 + "invalid X448 public key length/prefix: " + +edPointBytes :: EdPoint -> B.ByteString +edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x +edPointBytes (NativeEPoint (EPoint x)) = i2osp x + +deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHAlg.SHA256 B.empty ikm + info = "OpenPGP X25519" :: B.ByteString + in expand @CHAlg.SHA256 prk info 16 + +deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX448Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHAlg.SHA512 B.empty ikm + info = "OpenPGP X448" :: B.ByteString + in expand @CHAlg.SHA512 prk info 32 + +padToMultipleOf8 :: B.ByteString -> B.ByteString +padToMultipleOf8 bs + | padLen == 0 = bs + | otherwise = bs <> B.replicate padLen (fromIntegral padLen) + where + rem8 = B.length bs `mod` 8 + padLen = if rem8 == 0 then 0 else 8 - rem8 + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral . + B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 + +checksum16Bytes :: B.ByteString -> B.ByteString +checksum16Bytes bs = + B.pack + [ fromIntegral ((chk `shiftR` 8) .&. 0xff) + , fromIntegral (chk .&. 0xff) + ] + where + chk = checksum16 bs + +aesKeyWrapRFC3394 :: + SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString +aesKeyWrapRFC3394 sa kek plain = + withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek wrapWithCipher + where + wrapWithCipher :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString + wrapWithCipher cipher = do + if B.length plain < 16 || B.length plain `mod` 8 /= 0 + then Left "ECDH key wrap input must be at least 16 octets and a multiple of 8" + else Right () + let rs = chunksOf8 plain + if length rs < 2 + then Left "ECDH key wrap input must contain at least two 64-bit blocks" + else Right () + (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs + Right (aFinal <> B.concat rFinal) + wrapRounds :: CCT.BlockCipher cipher => cipher -> B.ByteString -> [B.ByteString] -> Either String (B.ByteString, [B.ByteString]) + wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit + where + n = length rsInit + goJ j a rs + | j > 5 = Right (a, rs) + | otherwise = do + (a', rs') <- goI 1 a rs + goJ (j + 1) a' rs' + where + goI i curA curRs + | i > n = Right (curA, curRs) + | otherwise = do + let t = fromIntegral (n * j + i) :: Word64 + rI = curRs !! (i - 1) + block = CCT.ecbEncrypt cipher (curA <> rI) + (msb, lsb) = B.splitAt 8 block + aNext = xorBS msb (encodeWord64be t) + rsNext = (ix (i - 1) .~ lsb) curRs + goI (i + 1) aNext rsNext + +chunksOf8 :: B.ByteString -> [B.ByteString] +chunksOf8 bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8 t + +xorBS :: B.ByteString -> B.ByteString -> B.ByteString +xorBS a b = B.pack (B.zipWith xor a b) + +encryptSEIPDv2WithSKESK :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Either String [Pkt] +encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do + keyLen <- symKeySize symalgo + sessionKeyMaterial <- first renderS2KError (string2Key s2k keyLen passphrase) + (_, nonceSize) <- + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SKESK v6 encrypt" + aead + when (B.length (unSalt salt) < nonceSize) $ + Left "SEIPD v2 salt is too short to derive the SKESK v6 IV" + let skeskIV = B.take nonceSize (unSalt salt) + kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial + (wrappedSessionKey, skeskTag) <- + encryptSKESK6SessionKey symalgo aead kek skeskIV sessionKeyMaterial + let sessionKey = SessionKey sessionKeyMaterial + encrypted <- encryptSEIPDv2Payload symalgo aead chunkSize salt sessionKey literalPayload + return + [ SKESKPkt + (SKESKPayloadV6Packet + (SKESKPayloadV6 + symalgo + aead + s2k + (BL.fromStrict skeskIV) + (BL.fromStrict wrappedSessionKey) + (BL.fromStrict skeskTag))) + , SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted)) + ] + +encryptSEIPDv2WithSKESKBlock :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> Block Pkt + -> Either String [Pkt] +encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock = + encryptSEIPDv2WithSKESK + symalgo + aead + chunkSize + salt + s2k + passphrase + (BL.toStrict (runPut (put packetBlock))) + +encryptSEIPDv2LiteralDataWithSKESK :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Either String [Pkt] +encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload = + encryptSEIPDv2WithSKESKBlock + symalgo + aead + chunkSize + salt + s2k + passphrase + (Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)]) + +encryptSEIPDv2Payload :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SessionKey + -> B.ByteString + -> Either String B.ByteString +encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do + (mode, nonceSize) <- aeadModeAndNonceSize aead + keyLen <- symKeySize symalgo + let outputLen = keyLen + nonceSize - 8 + info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize] + prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey + okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString + messageKey = B.take keyLen okm + noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) + withAESCipher + "SEIPD v2 encrypt currently supports AES-128/192/256 only" + symalgo + messageKey + (encryptChunks mode info chunkSize noncePrefix plaintext) + +encryptChunks :: + CCT.BlockCipher cipher + => CCT.AEADMode + -> B.ByteString + -> Word8 + -> B.ByteString + -> B.ByteString + -> cipher + -> Either String B.ByteString +encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 + where + chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) + go idx remaining acc totalPlain + | B.null remaining = do + (finalTag, finalCipher) <- + if mode == CCT.AEAD_OCB + then + encryptWithOCBRFC7253 + cipher + (noncePrefix <> encodeWord64be idx) + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + else do + aead <- initAEAD idx + let (tag, out) = + CCT.aeadSimpleEncrypt + aead + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + 16 + Right (tag, out) + if B.null finalCipher + then return (B.concat (reverse acc) <> authTagToBS finalTag) + else Left "expected empty ciphertext for final SEIPD v2 tag" + | otherwise = do + let (chunkPlain, rest) = B.splitAt chunkLen remaining + (tag, chunkCipher) <- + if mode == CCT.AEAD_OCB + then + encryptWithOCBRFC7253 + cipher + (noncePrefix <> encodeWord64be idx) + info + chunkPlain + else do + aead <- initAEAD idx + pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16) + let chunkOut = chunkCipher <> authTagToBS tag + go + (idx + 1) + rest + (chunkOut : acc) + (totalPlain + B.length chunkPlain) + + initAEAD idx = + first show . CE.eitherCryptoError $ + CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx) + +aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) +aeadModeAndNonceSize = + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SEIPD v2 encrypt" + +symKeySize :: SymmetricAlgorithm -> Either String Int +symKeySize = + seipdv2SymmetricKeySize + "unsupported symmetric algorithm for SEIPD v2 encrypt" + +authTagToBS :: CCT.AuthTag -> B.ByteString +authTagToBS = BA.convert . CCT.unAuthTag + +encodeWord64be :: Word64 -> B.ByteString +encodeWord64be = BL.toStrict . runPut . putWord64be + +-- | Compose a complete AEAD-encrypted message with optional literal data and signature. +-- Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization. +-- +-- Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes) +-- (SimpleS2K SHA256) passphrase payload Nothing@ +-- returns @[SKESK v6, SEIPD v2, ]@ +-- +-- If the signature is provided, it will be included in the encrypted payload. +composeMessageWithSEIPDv2 :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Maybe [Pkt] + -> Either String [Pkt] +composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do + let packets = case mSigs of + Nothing -> [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)] + Just sigs -> LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) : sigs + blockPayload = Block packets + encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase blockPayload diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -1,35 +1,310 @@ --- Expirations.hs: OpenPGP (RFC4880) expiration checking --- Copyright © 2014-2015 Clint Adams +-- Expirations.hs: OpenPGP (RFC9580) expiration checking +-- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.Expirations - ( isTKTimeValid + ( KeyState(..) + , keyStateAt + , effectiveKeyPreferencesAt + , effectiveUIDPreferencesAt + , effectiveKeyPreferencesAtTimestamp + , effectiveUIDPreferencesAtTimestamp + , isTKTimeValid + , isPKTimeValidWithSelfSignatures , getKeyExpirationTimesFromSignature + , isCertificationSig + , signatureCreationTime + , signatureExpirationTime + , signatureExpirationDuration + , firstSignatureExpirationDuration + , signatureEffectiveAt + , addDurationToTime + , newestByCreationTime ) where +import Control.Error.Util (hush) import Control.Lens ((&), (^.), _1) -import Data.Time.Clock (UTCTime) +import Data.List (maximumBy) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Ord (comparing) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal (issuer, issuerFP) import Codec.Encryption.OpenPGP.Ontology (isKET) +import Codec.Encryption.OpenPGP.SignatureQualities + ( sigCT + , sigType + , signatureHashedSubpacketsKnown + ) import Codec.Encryption.OpenPGP.Types +data KeyState = + KeyState + { keyStateValid :: Bool + , keyStateSelfSignaturesKnown :: Bool + , keyStateHasEffectiveSelfSignature :: Bool + , keyStateExpirationTime :: Maybe UTCTime + } + deriving (Eq, Show) + -- this assumes that all key expiration time subpackets are valid -isTKTimeValid :: UTCTime -> TK -> Bool -isTKTimeValid ct key = ct >= keyCreationTime && ct < keyExpirationTime +isTKTimeValid :: UTCTime -> TKUnknown -> Bool +isTKTimeValid ct = keyStateValid . keyStateAt ct + +keyStateAt :: UTCTime -> TKUnknown -> KeyState +keyStateAt ct tk = + baseState {keyStateValid = keyStateValid baseState && bindingStateAllowsValidation} where - keyCreationTime = - key ^. tkKey . _1 . timestamp & posixSecondsToUTCTime . realToFrac - keyExpirationTime = - posixSecondsToUTCTime . realToFrac . - ((key ^. tkKey . _1 . timestamp & unThirtyTwoBitTimeStamp) +) . - unThirtyTwoBitDuration . - newest . - concatMap getKeyExpirationTimesFromSignature $ - (concatMap snd (key ^. tkUIDs) ++ concatMap snd (key ^. tkUAts)) - newest [] = maxBound - newest xs = maximum xs + baseState = + keyStateFromSelfSignaturesAt ct (tk ^. tkuKey . _1) relevantSelfSignatures + relevantSelfSignatures = + filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkuRevs) ++ + filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUIDs)) ++ + filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUAts)) + selfCertificationGroups = + map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUIDs) ++ + map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUAts) + hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups + hasAnyActiveSelfCertification = + any (selfCertificationGroupActiveAt ct) selfCertificationGroups + bindingStateAllowsValidation = + not hasAnySelfCertification || hasAnyActiveSelfCertification + primaryKey = tk ^. tkuKey . _1 +effectiveKeyPreferencesAt :: UTCTime -> TKUnknown -> Maybe [SigSubPacketPayload] +effectiveKeyPreferencesAt ct tk + | not (keyStateValid (keyStateAt ct tk)) = Nothing + | otherwise = do + sig <- latestEffectivePreferenceCarrierAt ct tk + let prefs = preferencePayloadsFromSignature sig + if null prefs + then Nothing + else Just prefs + +effectiveUIDPreferencesAt :: UTCTime -> Text -> TKUnknown -> Maybe [SigSubPacketPayload] +effectiveUIDPreferencesAt ct uid tk + | not (keyStateValid (keyStateAt ct tk)) = Nothing + | otherwise = do + sigs <- lookup uid (tk ^. tkuUIDs) + cert <- latestActiveSelfCertificationAt ct (filter (isSelfSignatureFor primaryKey) sigs) + let prefs = preferencePayloadsFromSignature cert + if null prefs + then Nothing + else Just prefs + where + primaryKey = tk ^. tkuKey . _1 + +effectiveKeyPreferencesAtTimestamp :: + ThirtyTwoBitTimeStamp -> TKUnknown -> Maybe [SigSubPacketPayload] +effectiveKeyPreferencesAtTimestamp ts = + effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) + +effectiveUIDPreferencesAtTimestamp :: + ThirtyTwoBitTimeStamp -> Text -> TKUnknown -> Maybe [SigSubPacketPayload] +effectiveUIDPreferencesAtTimestamp ts uid = + effectiveUIDPreferencesAt + (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) + uid + +isPKTimeValidWithSelfSignatures :: + UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool +isPKTimeValidWithSelfSignatures ct pkp sigs = + keyStateValid (keyStateFromSelfSignaturesAt ct pkp sigs) + +keyStateFromSelfSignaturesAt :: + UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState +keyStateFromSelfSignaturesAt ct pkp sigs = + KeyState + { keyStateValid = + ct >= keyCreationTime && + selfSignatureStateAllowsValidation && + maybe True (ct <) keyExpirationTime + , keyStateSelfSignaturesKnown = maybe False (const True) latestKnownSelfSignature + , keyStateHasEffectiveSelfSignature = + maybe False (signatureEffectiveAt ct) latestKnownSelfSignature + , keyStateExpirationTime = keyExpirationTime + } + where + keyCreationTime = _timestamp pkp & posixSecondsToUTCTime . realToFrac + knownSelfSignatures = filter (signatureCreatedAtOrBefore ct) sigs + selfSignatureStateAllowsValidation = + maybe (null sigs) (signatureEffectiveAt ct) latestKnownSelfSignature + latestKnownSelfSignature = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownSelfSignatures) + keyExpirationTime = effectiveKeyExpirationTime ct pkp sigs + +effectiveKeyExpirationTime :: + UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime +effectiveKeyExpirationTime ct pkp sigs = + signatureExpirationDurationToUTCTime pkp =<< latestKnownExpirationDuration ct sigs + +latestKnownExpirationDuration :: + UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration +latestKnownExpirationDuration ct sigs = + latestKnownSelfSignatureExpirationDuration ct =<< + (snd <$> newestByCreationTime (mapMaybeSignatureCreationTime (filter (signatureCreatedAtOrBefore ct) sigs))) + +latestKnownSelfSignatureExpirationDuration :: + UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration +latestKnownSelfSignatureExpirationDuration ct sig + | signatureEffectiveAt ct sig = listToMaybe (getKeyExpirationTimesFromSignature sig) + | otherwise = Nothing + +signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool +signatureEffectiveAt ct sig = + maybe False (<= ct) (signatureCreationTime sig) && + maybe True (ct <) (signatureExpirationTime sig) + +signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool +signatureCreatedAtOrBefore ct sig = + maybe False (<= ct) (signatureCreationTime sig) + +signatureCreationTime :: SignaturePayload -> Maybe UTCTime +signatureCreationTime = + fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT + +signatureExpirationTime :: SignaturePayload -> Maybe UTCTime +signatureExpirationTime sig = + addDurationToTime <$> + signatureCreationTime sig <*> + signatureExpirationDuration sig + +signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration +signatureExpirationDuration sig = + signatureHashedSubpacketsKnown sig >>= firstSignatureExpirationDuration + +firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration +firstSignatureExpirationDuration = + foldr + (\subpacket acc -> + case subpacket of + SigSubPacket _ (SigExpirationTime duration) -> Just duration + _ -> acc) + Nothing + +signatureExpirationDurationToUTCTime :: + SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime +signatureExpirationDurationToUTCTime _ (ThirtyTwoBitDuration 0) = Nothing +signatureExpirationDurationToUTCTime pkp duration = + Just $ + addDurationToTime + (_timestamp pkp & posixSecondsToUTCTime . realToFrac) + duration + +addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime +addDurationToTime baseTime duration = + addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime + +newestByCreationTime :: [(UTCTime, a)] -> Maybe (UTCTime, a) +newestByCreationTime [] = Nothing +newestByCreationTime xs = Just (maximumBy (comparing fst) xs) + +mapMaybeSignatureCreationTime :: [SignaturePayload] -> [(UTCTime, SignaturePayload)] +mapMaybeSignatureCreationTime = + foldr + (\sig acc -> + case signatureCreationTime sig of + Just ct -> (ct, sig) : acc + Nothing -> acc) + [] + +selfCertificationGroupActiveAt :: UTCTime -> [SignaturePayload] -> Bool +selfCertificationGroupActiveAt ct sigs = + maybe False (const True) (latestActiveSelfCertificationAt ct sigs) + +latestActiveSelfCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestActiveSelfCertificationAt ct sigs = + case latestKnownSelfCertification of + Nothing -> Nothing + Just certification -> + if signatureEffectiveAt ct certification && + not (any (\revocation -> revokesCertificationAt ct revocation certification) certRevocations) + then Just certification + else Nothing + where + latestKnownSelfCertification = + snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownCertifications) + knownCertifications = + filter (\sig -> isCertificationSig sig && signatureCreatedAtOrBefore ct sig) sigs + certRevocations = + filter (\sig -> isCertRevocationForTime ct sig) sigs + +latestEffectivePreferenceCarrierAt :: UTCTime -> TKUnknown -> Maybe SignaturePayload +latestEffectivePreferenceCarrierAt ct tk = + snd <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates) + where + primaryKey = tk ^. tkuKey . _1 + directKeySigs = + filter + (\sig -> isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig) + (tk ^. tkuRevs) + uidSelfCerts = + mapMaybe + (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd) + (tk ^. tkuUIDs) + uatSelfCerts = + mapMaybe + (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd) + (tk ^. tkuUAts) + candidates = directKeySigs ++ uidSelfCerts ++ uatSelfCerts + +preferencePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload] +preferencePayloadsFromSignature = + map + (\(SigSubPacket _ payload) -> payload) . + filter isPreferenceSubpacket . + signatureHashedSubpackets + +signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] +signatureHashedSubpackets sig = + maybe [] id (signatureHashedSubpacketsKnown sig) + +isPreferenceSubpacket :: SigSubPacket -> Bool +isPreferenceSubpacket (SigSubPacket _ (PreferredSymmetricAlgorithms _)) = True +isPreferenceSubpacket (SigSubPacket _ (PreferredHashAlgorithms _)) = True +isPreferenceSubpacket (SigSubPacket _ (PreferredCompressionAlgorithms _)) = True +isPreferenceSubpacket (SigSubPacket _ (KeyServerPreferences _)) = True +isPreferenceSubpacket (SigSubPacket _ (PreferredKeyServer _)) = True +isPreferenceSubpacket (SigSubPacket _ (Features _)) = True +isPreferenceSubpacket (SigSubPacket _ (OtherSigSub subpacketType _)) = + subpacketType == 39 +isPreferenceSubpacket _ = False + +revokesCertificationAt :: UTCTime -> SignaturePayload -> SignaturePayload -> Bool +revokesCertificationAt ct revocation certification = + signatureEffectiveAt ct revocation && + case (signatureCreationTime certification, signatureCreationTime revocation) of + (Just certificationTime, Just revocationTime) -> certificationTime < revocationTime + _ -> False + +isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool +isCertRevocationForTime ct sig = + sigType sig == Just CertRevocationSig && + signatureCreatedAtOrBefore ct sig + +isCertificationSig :: SignaturePayload -> Bool +isCertificationSig sig = + sigType sig `elem` [Just GenericCert, Just PersonaCert, Just CasualCert, Just PositiveCert] + +isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool +isDirectKeySelfSigFor pkp sig = + sigType sig == Just SignatureDirectlyOnAKey && isSelfSignatureFor pkp sig + +isSelfCertificationFor :: SomePKPayload -> SignaturePayload -> Bool +isSelfCertificationFor pkp sig = + isCertificationSig sig && isSelfSignatureFor pkp sig + +isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool +isSelfSignatureFor pkp sig = + (((== fingerprint pkp) <$> issuerFP (SignaturePkt sig)) == Just True) || + (((==) <$> issuer (SignaturePkt sig) <*> hush (eightOctetKeyID pkp)) == Just True) + getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] -getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = - map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs +getKeyExpirationTimesFromSignature sig = + map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ + filter isKET (signatureHashedSubpackets sig) diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -1,50 +1,96 @@ --- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods --- Copyright © 2012-2016 Clint Adams +-- Fingerprint.hs: OpenPGP (RFC9580) fingerprinting methods +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint ) where import Crypto.Hash (Digest, hashlazy) -import Crypto.Hash.Algorithms (MD5, SHA1) +import Crypto.Hash.Algorithms (MD5, SHA1, SHA256) import Crypto.Number.Serialize (i2osp) import qualified Crypto.PubKey.RSA as RSA import Data.Binary.Put (runPut) import qualified Data.ByteArray as BA +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting) import Codec.Encryption.OpenPGP.Types -eightOctetKeyID :: PKPayload -> Either String EightOctetKeyId -eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey (RSA_PublicKey rp))) = - (Right . - EightOctetKeyId . - BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n) - rp -eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey (RSA_PublicKey rp))) = - (Right . - EightOctetKeyId . - BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n) - rp -eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey (RSA_PublicKey rp))) = - (Right . - EightOctetKeyId . - BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n) - rp -eightOctetKeyID (PKPayload DeprecatedV3 _ _ _ _) = - Left "Cannot calculate the key ID of a non-RSA V3 key" -eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = - (Right . EightOctetKeyId . BL.drop 12 . unTOF . fingerprint) p4 +eightOctetKeyID :: SomePKPayload -> Either String 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" + FingerprintingV4 pkpV4 -> + Right (EightOctetKeyId (BL.drop 12 (unFingerprint (fingerprintV4 pkpV4)))) + FingerprintingV6 pkpV6 -> + Right (EightOctetKeyId (BL.take 8 (unFingerprint (fingerprintV6 pkpV6)))) -fingerprint :: PKPayload -> TwentyOctetFingerprint -fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = - (TwentyOctetFingerprint . - BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest MD5)) - (runPut $ putPKPforFingerprinting (PublicKeyPkt p3)) -fingerprint p4@(PKPayload V4 _ _ _ _) = - (TwentyOctetFingerprint . - BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest SHA1)) - (runPut $ putPKPforFingerprinting (PublicKeyPkt p4)) +fingerprint :: SomePKPayload -> Fingerprint +fingerprint pkp = + case classifyFingerprintingKey pkp of + FingerprintingV3RSA pkpV3 _ -> fingerprintV3 pkpV3 + FingerprintingV3NonRSA pkpV3 -> fingerprintV3 pkpV3 + FingerprintingV4 pkpV4 -> fingerprintV4 pkpV4 + FingerprintingV6 pkpV6 -> fingerprintV6 pkpV6 + +data FingerprintingKey where + FingerprintingV3RSA :: + PKPayload 'DeprecatedV3 + -> RSA.PublicKey + -> FingerprintingKey + FingerprintingV3NonRSA :: PKPayload 'DeprecatedV3 -> FingerprintingKey + FingerprintingV4 :: PKPayload 'V4 -> FingerprintingKey + FingerprintingV6 :: PKPayload 'V6 -> FingerprintingKey + +classifyFingerprintingKey :: SomePKPayload -> FingerprintingKey +classifyFingerprintingKey (SomePKPayload pkp@(PKPayloadV3 _ _ pka (RSAPubKey (RSA_PublicKey rp)))) + | pka == RSA || pka == DeprecatedRSAEncryptOnly || pka == DeprecatedRSASignOnly = + FingerprintingV3RSA pkp rp +classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV3 {}) = + FingerprintingV3NonRSA pkp +classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV4 {}) = + FingerprintingV4 pkp +classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV6 {}) = + FingerprintingV6 pkp + +v3RSAKeyId :: RSA.PublicKey -> EightOctetKeyId +v3RSAKeyId = + EightOctetKeyId . + BL.reverse . BL.take 8 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n + +fingerprintV3 :: PKPayload 'DeprecatedV3 -> Fingerprint +fingerprintV3 = fingerprintFromDigestMD5 . serializeForFingerprinting + +fingerprintV4 :: PKPayload 'V4 -> Fingerprint +fingerprintV4 = fingerprintFromDigestSHA1 . serializeForFingerprinting + +fingerprintV6 :: PKPayload 'V6 -> Fingerprint +fingerprintV6 = fingerprintFromDigestSHA256 . serializeForFingerprinting + +serializeForFingerprinting :: PKPayload v -> BL.ByteString +serializeForFingerprinting = + runPut . putPKPforFingerprinting . PublicKeyPkt . SomePKPayload + +fingerprintFromDigestMD5 :: BL.ByteString -> Fingerprint +fingerprintFromDigestMD5 serialized = + let digest = hashlazy serialized :: Digest MD5 + in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) + +fingerprintFromDigestSHA1 :: BL.ByteString -> Fingerprint +fingerprintFromDigestSHA1 serialized = + let digest = hashlazy serialized :: Digest SHA1 + in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) + +fingerprintFromDigestSHA256 :: BL.ByteString -> Fingerprint +fingerprintFromDigestSHA256 serialized = + let digest = hashlazy serialized :: Digest SHA256 + in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) 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 @@ -1,7 +1,10 @@ -- Internal.hs: private utility functions and such --- Copyright © 2012-2019 Clint Adams +-- 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 OverloadedStrings #-} module Codec.Encryption.OpenPGP.Internal @@ -10,11 +13,12 @@ , issuer , issuerFP , emptyPSC + , leftPadTo , pubkeyToMPIs , multiplicativeInverse , curveoidBSToCurve , curveToCurveoidBS - , point2BS + , point2MBS , curveoidBSToEdSigningCurve , edSigningCurveToCurveoidBS , curve2Curve @@ -34,7 +38,7 @@ import Data.List (find) import Data.Word (Word16, Word8) -import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isIssuerFPSSP, isSigCreationTime) +import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) import Codec.Encryption.OpenPGP.Types countBits :: ByteString -> Word16 @@ -68,16 +72,66 @@ (OtherPacketPkt 0 "lastPrimaryKey placeholder") (OtherPacketPkt 0 "lastSubkey placeholder") +leftPadTo :: Int -> B.ByteString -> B.ByteString +leftPadTo targetLen bs + | B.length bs >= targetLen = bs + | otherwise = B.replicate (targetLen - B.length bs) 0 <> bs + issuer :: Pkt -> Maybe EightOctetKeyId -issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = - fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs) -issuer _ = Nothing +issuer pkt = + case fromPktIssuerExtractionCase pkt of + Just extractionCase -> + find isIssuerSSP (unhashedSubpackets extractionCase) >>= issuerFromSubpacket + Nothing -> Nothing -issuerFP :: Pkt -> Maybe TwentyOctetFingerprint -issuerFP (SignaturePkt (SigV4 _ _ _ hsubs _ _ _)) = - fmap (\(SigSubPacket _ (IssuerFingerprint _ i)) -> i) (find isIssuerFPSSP hsubs) -issuerFP _ = Nothing +issuerFP :: Pkt -> Maybe Fingerprint +issuerFP pkt = + case fromPktIssuerExtractionCase pkt of + Just extractionCase -> + find + (isIssuerFingerprintFor (issuerFingerprintVersion extractionCase)) + (hashedSubpackets extractionCase) >>= + issuerFingerprintFromSubpacket + Nothing -> Nothing +data IssuerExtractionCase where + IssuerExtractionCaseV4 :: SignaturePayloadV 'SigPayloadV4 -> IssuerExtractionCase + IssuerExtractionCaseV6 :: SignaturePayloadV 'SigPayloadV6 -> IssuerExtractionCase + +fromPktIssuerExtractionCase :: Pkt -> Maybe IssuerExtractionCase +fromPktIssuerExtractionCase pkt = + case fromPktEitherSomeSignatureV pkt of + Right (SomeSignatureV (SignatureV4Packet payload)) -> + Just (IssuerExtractionCaseV4 payload) + Right (SomeSignatureV (SignatureV6Packet payload)) -> + Just (IssuerExtractionCaseV6 payload) + _ -> Nothing + +hashedSubpackets :: IssuerExtractionCase -> [SigSubPacket] +hashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) = hsubs +hashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) = hsubs + +unhashedSubpackets :: IssuerExtractionCase -> [SigSubPacket] +unhashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ _ usubs _ _)) = usubs +unhashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ _ usubs _ _)) = usubs + +issuerFingerprintVersion :: IssuerExtractionCase -> IssuerFingerprintVersion +issuerFingerprintVersion IssuerExtractionCaseV4 {} = IssuerFingerprintV4 +issuerFingerprintVersion IssuerExtractionCaseV6 {} = IssuerFingerprintV6 + +isIssuerFingerprintFor :: IssuerFingerprintVersion -> SigSubPacket -> Bool +isIssuerFingerprintFor version (SigSubPacket _ (IssuerFingerprint packetVersion _)) = + packetVersion == version +isIssuerFingerprintFor _ _ = False + +issuerFingerprintFromSubpacket :: SigSubPacket -> Maybe Fingerprint +issuerFingerprintFromSubpacket (SigSubPacket _ (IssuerFingerprint _ i)) = Just i +issuerFingerprintFromSubpacket _ = Nothing + +issuerFromSubpacket :: SigSubPacket -> Maybe EightOctetKeyId +issuerFromSubpacket (SigSubPacket _ (Issuer i)) = Just i +issuerFromSubpacket _ = Nothing + pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = [MPI (RSA.public_n k), MPI (RSA.public_e k)] @@ -91,12 +145,16 @@ pkParams f = MPI . f . DSA.public_params $ k pubkeyToMPIs (ElGamalPubKey p g y) = [MPI p, MPI g, MPI y] pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) _ _) = - [MPI (os2ip (point2BS q))] -pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ (EPoint x)) _ _) = [MPI x] + [MPI (os2ip (pointToBSOrError q))] +pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)] pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) = - [MPI (os2ip (point2BS q))] -pubkeyToMPIs (EdDSAPubKey _ (EPoint x)) = [MPI x] + [MPI (os2ip (pointToBSOrError q))] +pubkeyToMPIs (EdDSAPubKey _ ep) = [MPI (edPointInteger ep)] +edPointInteger :: EdPoint -> Integer +edPointInteger (PrefixedNativeEPoint (EPoint x)) = x +edPointInteger (NativeEPoint (EPoint x)) = x + multiplicativeInverse :: Integral a => a -> a -> a multiplicativeInverse _ 1 = 1 multiplicativeInverse q p = (n * q + 1) `div` p @@ -111,6 +169,8 @@ | B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] == oidbs = Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1 | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] == oidbs = Right Curve25519 + | B.pack [0x2B, 0x65, 0x6F] == oidbs = + Right Curve448 | otherwise = Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"] curveToCurveoidBS :: ECCCurve -> Either String B.ByteString @@ -120,16 +180,36 @@ curveToCurveoidBS NISTP521 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] curveToCurveoidBS Curve25519 = Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] +curveToCurveoidBS Curve448 = Right $ B.pack [0x2B, 0x65, 0x6F] curveToCurveoidBS _ = Left "unknown curve" -point2BS :: ECCT.PublicPoint -> B.ByteString -point2BS (ECCT.Point x y) = B.concat [B.singleton 0x04, i2osp x, i2osp y] -- FIXME: check for length equality? -point2BS ECCT.PointO = error "FIXME: point at infinity" +point2MBS :: ECCT.PublicPoint -> Maybe B.ByteString +point2MBS (ECCT.Point x y) + | B.null xb || B.null yb = Nothing + | B.length xb /= B.length yb = Nothing + | otherwise = Just (B.concat [B.singleton 0x04, xb, yb]) + where + xb = i2osp x + yb = i2osp y +point2MBS ECCT.PointO = Nothing +pointToBSOrError :: ECCT.PublicPoint -> B.ByteString +pointToBSOrError point = + case point of + ECCT.PointO -> error "OpenPGP forbids serializing the point at infinity" + _ -> + case point2MBS point of + Just bs -> bs + Nothing -> + error + "OpenPGP EC point serialization requires equal non-empty coordinate widths" + curveoidBSToEdSigningCurve :: B.ByteString -> Either String EdSigningCurve curveoidBSToEdSigningCurve oidbs | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] == oidbs = Right Ed25519 + | B.pack [0x2B, 0x65, 0x71] == oidbs = + Right Ed448 | otherwise = Left $ concat ["unknown Edwards signing curve (...", show (B.unpack oidbs), ")"] @@ -137,6 +217,7 @@ edSigningCurveToCurveoidBS :: EdSigningCurve -> Either String B.ByteString edSigningCurveToCurveoidBS Ed25519 = Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] +edSigningCurveToCurveoidBS Ed448 = Right $ B.pack [0x2B, 0x65, 0x71] curve2Curve :: ECCCurve -> ECCT.Curve curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1 diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoAES.hs b/Codec/Encryption/OpenPGP/Internal/CryptoAES.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal/CryptoAES.hs @@ -0,0 +1,37 @@ +-- CryptoAES.hs: OpenPGP (RFC9580) AES helper utilities +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} + +module Codec.Encryption.OpenPGP.Internal.CryptoAES + ( withAESCipher + ) where + +import Codec.Encryption.OpenPGP.Types +import qualified "crypton" Crypto.Cipher.AES as AES +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE +import Data.Bifunctor (first) +import qualified Data.ByteString as B + +withAESCipher :: + String + -> SymmetricAlgorithm + -> B.ByteString + -> (forall cipher. CCT.BlockCipher cipher => cipher -> Either String a) + -> Either String a +withAESCipher unsupportedSymmetricError symalgo keyBytes f = + case symalgo of + AES128 -> + first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES128)) >>= + f + AES192 -> + first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES192)) >>= + f + AES256 -> + first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES256)) >>= + f + _ -> Left unsupportedSymmetricError diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs @@ -0,0 +1,71 @@ +-- CryptoECDH.hs: OpenPGP (RFC9580) ECDH helper utilities +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE OverloadedStrings #-} + +module Codec.Encryption.OpenPGP.Internal.CryptoECDH + ( normalizeMontgomeryPublic + , buildECDHKDFParam + , deriveECDHKek + ) where + +import Codec.Encryption.OpenPGP.BlockCipher (keySize, renderCipherError) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal (curveFromCurve, curveToCurveoidBS, leftPadTo) +import Codec.Encryption.OpenPGP.Policy (ecdhKdfHashDigest) +import Codec.Encryption.OpenPGP.Types +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +normalizeMontgomeryPublic :: + Int + -> String + -> B.ByteString + -> 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 + 1 && B.head bs == 0x40 = Right (B.tail bs) + | otherwise = Left (label ++ show (B.length bs)) + +buildECDHKDFParam :: + SomePKPayload + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> Either String B.ByteString +buildECDHKDFParam recipientPKP pka recipientECDHPub kdfHA kdfSA = + (<> + B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> + "Anonymous Sender " <> + BL.toStrict (unFingerprint (fingerprint recipientPKP))) <$> + encodedCurveOid + where + encodedCurveOid = ((\oid -> B.singleton (fromIntegral (B.length oid)) <> oid) <$>) curveOid + curveOid = + case recipientECDHPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> + curveToCurveoidBS (curveFromCurve curve) + EdDSAPubKey Ed25519 _ -> + curveToCurveoidBS Curve25519 + EdDSAPubKey Ed448 _ -> + curveToCurveoidBS Curve448 + _ -> Left "ECDH KDF param requires ECDH recipient key" + +deriveECDHKek :: + HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +deriveECDHKek kdfHA kdfSA sharedSecret kdfParam = do + digest <- ecdhKdfHashDigest kdfHA (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + kekLen <- first renderCipherError (keySize kdfSA) + if B.length digest < kekLen + then Left "ECDH KDF digest is shorter than required KEK length" + else Right (B.take kekLen digest) diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs b/Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs @@ -0,0 +1,135 @@ +-- CryptoSEIPDv2.hs: OpenPGP (RFC9580) SEIPD-v2 and SKESK-v6 crypto helpers +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , seipdv2SymmetricKeySize + , deriveSKESK6KEK + , encryptSKESK6SessionKey + , decryptSKESK6SessionKey + ) where + +import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB + ( decryptWithOCBRFC7253With + , encryptWithOCBRFC7253 + ) +import Codec.Encryption.OpenPGP.Types +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) +import Data.Bifunctor (first) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B + +aeadModeAndNonceSizeForSEIPDv2 :: + String -> AEADAlgorithm -> Either String (CCT.AEADMode, Int) +aeadModeAndNonceSizeForSEIPDv2 otherAeadError EAX = + Left "EAX is currently unsupported by the crypton AEAD backend" +aeadModeAndNonceSizeForSEIPDv2 otherAeadError OCB = Right (CCT.AEAD_OCB, 15) +aeadModeAndNonceSizeForSEIPDv2 otherAeadError GCM = Right (CCT.AEAD_GCM, 12) +aeadModeAndNonceSizeForSEIPDv2 otherAeadError (OtherAEADAlgo _) = Left otherAeadError + +seipdv2SymmetricKeySize :: String -> SymmetricAlgorithm -> Either String Int +seipdv2SymmetricKeySize unsupportedSymmetricError symalgo = + case symalgo of + AES128 -> Right 16 + AES192 -> Right 24 + AES256 -> Right 32 + _ -> Left unsupportedSymmetricError + +skeskV6Info :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString +skeskV6Info symalgo aead = B.pack [0xc3, 6, fromFVal symalgo, fromFVal aead] + +deriveSKESK6KEK :: + SymmetricAlgorithm + -> AEADAlgorithm + -> B.ByteString + -> Either String B.ByteString +deriveSKESK6KEK symalgo aead ikm = do + keyLen <- + seipdv2SymmetricKeySize + "SKESK v6 currently supports AES-128/192/256 only" + symalgo + let prk = extract @CHA.SHA256 B.empty ikm + pure (expand @CHA.SHA256 prk (skeskV6Info symalgo aead) keyLen) + +encryptSKESK6SessionKey :: + SymmetricAlgorithm + -> AEADAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String (B.ByteString, B.ByteString) +encryptSKESK6SessionKey symalgo aead kek iv sessionKey = do + (mode, nonceSize) <- + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SKESK v6 encrypt" + aead + if B.length iv /= nonceSize + then Left "SKESK v6 IV length does not match AEAD algorithm" + else + withAESCipher + "SKESK v6 encrypt currently supports AES-128/192/256 only" + symalgo + kek + (\cipher -> + if mode == CCT.AEAD_OCB + then do + (tag, ciphertext) <- + encryptWithOCBRFC7253 cipher iv (skeskV6Info symalgo aead) sessionKey + pure (ciphertext, authTagToBS tag) + else do + aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv + let (tag, ciphertext) = + CCT.aeadSimpleEncrypt aeadCtx (skeskV6Info symalgo aead) sessionKey 16 + pure (ciphertext, authTagToBS tag)) + +decryptSKESK6SessionKey :: + SymmetricAlgorithm + -> AEADAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +decryptSKESK6SessionKey symalgo aead kek iv ciphertext tag = do + (mode, nonceSize) <- + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SKESK v6 decrypt" + aead + if B.length iv /= nonceSize + then Left "SKESK v6 IV length does not match AEAD algorithm" + else + withAESCipher + "SKESK v6 decrypt currently supports AES-128/192/256 only" + symalgo + kek + (\cipher -> + if mode == CCT.AEAD_OCB + then + decryptWithOCBRFC7253With + (\_ _ _ _ _ _ -> "SKESK v6 authentication failed") + cipher + iv + (skeskV6Info symalgo aead) + ciphertext + (mkAuthTag tag) + else do + aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv + case CCT.aeadSimpleDecrypt aeadCtx (skeskV6Info symalgo aead) ciphertext (mkAuthTag tag) of + Nothing -> Left "SKESK v6 authentication failed" + Just plain -> Right plain) + +authTagToBS :: CCT.AuthTag -> B.ByteString +authTagToBS = BA.convert . CCT.unAuthTag + +mkAuthTag :: B.ByteString -> CCT.AuthTag +mkAuthTag = CCT.AuthTag . BA.convert diff --git a/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs b/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs @@ -0,0 +1,227 @@ +-- RFC7253OCB.hs: RFC7253 implementation as a +-- workaround until crypton is fixed +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). +{-# LANGUAGE PackageImports #-} + +module Codec.Encryption.OpenPGP.Internal.RFC7253OCB + ( encryptWithOCBRFC7253 + , decryptWithOCBRFC7253 + , decryptWithOCBRFC7253With + ) where + +import Control.Monad (when) +import qualified "crypton" Crypto.Cipher.Types as CCT +import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import Data.List (foldl') +import Crypto.Number.Serialize (i2osp, os2ip) +import Data.Word (Word8) + +encryptWithOCBRFC7253 :: + CCT.BlockCipher c + => c + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String (CCT.AuthTag, B.ByteString) +encryptWithOCBRFC7253 cipher nonce ad plaintext = do + when (B.length nonce > 15 || B.null nonce) $ + Left "invalid nonce size for OCB" + offset0 <- ocbOffset0 cipher nonce + let zeroBlock = B.replicate 16 0 + lStar = CCT.ecbEncrypt cipher zeroBlock + lDollar = ocbDouble lStar + lCache = iterate ocbDouble (ocbDouble lDollar) + hashAd = ocbHash cipher lStar lCache ad + (fullBlocks, partial) = splitFullAndPartial plaintext + (cipherBlocks, offsetM, checksum) = + foldl' + (\(accBlocks, offsetPrev, checksumPrev) (idx, pBlock) -> + let offsetI = xorBS offsetPrev (lCache !! ntz idx) + cipherI = xorBS offsetI (CCT.ecbEncrypt cipher (xorBS offsetI pBlock)) + checksumI = xorBS checksumPrev pBlock + in (accBlocks ++ [cipherI], offsetI, checksumI)) + ([], offset0, zeroBlock) + (zip [1 ..] fullBlocks) + (cipherLast, offsetLast, checksumLast) = + if B.null partial + then (B.empty, offsetM, checksum) + else + let offsetStar = xorBS offsetM lStar + pad = CCT.ecbEncrypt cipher offsetStar + cipherPartial = xorBS partial (B.take (B.length partial) pad) + checksum' = xorBS checksum (ocbPadPartial partial) + in (cipherPartial, offsetStar, checksum') + tagBytes = + xorBS + (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) + hashAd + ciphertext = B.concat cipherBlocks <> cipherLast + in Right (mkAuthTag (B.take 16 tagBytes), ciphertext) + +decryptWithOCBRFC7253 :: + CCT.BlockCipher c + => c + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> CCT.AuthTag + -> Either String B.ByteString +decryptWithOCBRFC7253 = + decryptWithOCBRFC7253With (\_ _ _ _ _ _ -> "OCB authentication failed") + +decryptWithOCBRFC7253With :: + CCT.BlockCipher c + => (B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> String) + -> c + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> CCT.AuthTag + -> Either String B.ByteString +decryptWithOCBRFC7253With onAuthFailure cipher nonce ad ciphertext authTag = do + when (B.length nonce > 15 || B.null nonce) $ + Left "invalid nonce size for OCB" + when (B.length tagBytes /= 16) $ + Left "invalid auth tag size for OCB" + offset0 <- ocbOffset0 cipher nonce + let zeroBlock = B.replicate 16 0 + lStar = CCT.ecbEncrypt cipher zeroBlock + lDollar = ocbDouble lStar + lCache = iterate ocbDouble (ocbDouble lDollar) + hashAd = ocbHash cipher lStar lCache ad + (fullBlocks, partial) = splitFullAndPartial ciphertext + (plainBlocks, offsetM, checksum) = + foldl' + (\(accBlocks, offsetPrev, checksumPrev) (idx, cBlock) -> + let offsetI = xorBS offsetPrev (lCache !! ntz idx) + plainI = xorBS offsetI (CCT.ecbDecrypt cipher (xorBS offsetI cBlock)) + checksumI = xorBS checksumPrev plainI + in (accBlocks ++ [plainI], offsetI, checksumI)) + ([], offset0, zeroBlock) + (zip [1 ..] fullBlocks) + (plainLast, offsetLast, checksumLast) = + if B.null partial + then (B.empty, offsetM, checksum) + else + let offsetStar = xorBS offsetM lStar + pad = CCT.ecbEncrypt cipher offsetStar + plainPartial = xorBS partial (B.take (B.length partial) pad) + checksum' = xorBS checksum (ocbPadPartial plainPartial) + in (plainPartial, offsetStar, checksum') + tagComputed = + xorBS + (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) + hashAd + plaintext = B.concat plainBlocks <> plainLast + computedTag = B.take 16 tagComputed + in if BA.constEq tagBytes computedTag + then Right plaintext + else Left (onAuthFailure tagBytes computedTag nonce ad hashAd plaintext) + where + tagBytes = BA.convert authTag :: B.ByteString + +mkAuthTag :: B.ByteString -> CCT.AuthTag +mkAuthTag = CCT.AuthTag . BA.convert + +ocbOffset0 :: CCT.BlockCipher c => c -> B.ByteString -> Either String B.ByteString +ocbOffset0 cipher nonce = do + let nonceLen = B.length nonce + prefixLen = 16 - nonceLen + when (prefixLen <= 0) $ + Left "invalid nonce size for OCB" + let prefix = B.pack (replicate (prefixLen - 1) 0 <> [1 :: Word8]) + nonceBlock = prefix <> nonce + bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int + nonceTop = B.init nonceBlock <> B.singleton (B.last nonceBlock .&. 0xc0) + kTop = CCT.ecbEncrypt cipher nonceTop + stretch = kTop <> xorBS (B.take 8 kTop) (B.take 8 (B.drop 1 kTop)) + Right (ocbBitSlice128 stretch bottom) + +ocbHash :: + CCT.BlockCipher c + => c + -> B.ByteString + -> [B.ByteString] + -> B.ByteString + -> B.ByteString +ocbHash cipher lStar lCache ad = + let (fullBlocks, partial) = splitFullAndPartial ad + (sumBlocks, offsetFinal) = + foldl' + (\(acc, offsetPrev) (idx, block) -> + let offsetI = xorBS offsetPrev (lCache !! ntz idx) + sumI = xorBS acc (CCT.ecbEncrypt cipher (xorBS offsetI block)) + in (sumI, offsetI)) + (B.replicate 16 0, B.replicate 16 0) + (zip [1 ..] fullBlocks) + in if B.null partial + then sumBlocks + else + let offsetStar = xorBS offsetFinal lStar + block = ocbPadPartial partial + in xorBS sumBlocks (CCT.ecbEncrypt cipher (xorBS offsetStar block)) + +ocbPadPartial :: B.ByteString -> B.ByteString +ocbPadPartial bs = bs <> B.singleton 0x80 <> B.replicate (15 - B.length bs) 0 + +ocbDouble :: B.ByteString -> B.ByteString +ocbDouble bs = + let shifted = shiftLeftOne bs + carry = (B.head bs .&. 0x80) /= 0 + in if carry + then B.init shifted <> B.singleton (B.last shifted `xor` 0x87) + else shifted + +shiftLeftOne :: B.ByteString -> B.ByteString +shiftLeftOne bs = B.pack shifted + where + (shifted, _) = + foldl' + (\(acc, carryIn) x -> + let y = ((x `shiftL` 1) .&. 0xff) .|. carryIn + carryOut = if (x .&. 0x80) /= 0 then 1 else 0 + in (y : acc, carryOut)) + ([], 0) + (reverse (B.unpack bs)) + +xorBS :: B.ByteString -> B.ByteString -> B.ByteString +xorBS a b = B.pack (B.zipWith xor a b) + +ocbBitSlice128 :: B.ByteString -> Int -> B.ByteString +ocbBitSlice128 stretch startBit = + let stretchInt = os2ip stretch + shift = 192 - (startBit + 128) + mask = (1 `shiftL` (128 :: Int)) - 1 + slice = (stretchInt `shiftR` shift) .&. mask + in leftPadTo16 (i2osp slice) + +leftPadTo16 :: B.ByteString -> B.ByteString +leftPadTo16 bs + | B.length bs >= 16 = B.drop (B.length bs - 16) bs + | otherwise = B.replicate (16 - B.length bs) 0 <> bs + +splitFullAndPartial :: B.ByteString -> ([B.ByteString], B.ByteString) +splitFullAndPartial bs + | B.null bs = ([], B.empty) + | otherwise = + let fullLen = (B.length bs `div` 16) * 16 + (fullPart, rest) = B.splitAt fullLen bs + in (chunk16 fullPart, rest) + +chunk16 :: B.ByteString -> [B.ByteString] +chunk16 bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 16 bs + in h : chunk16 t + +ntz :: Int -> Int +ntz i = go i 0 + where + go n c + | n .&. 1 == 1 = c + | otherwise = go (n `shiftR` 1) (c + 1) diff --git a/Codec/Encryption/OpenPGP/KeyInfo.hs b/Codec/Encryption/OpenPGP/KeyInfo.hs --- a/Codec/Encryption/OpenPGP/KeyInfo.hs +++ b/Codec/Encryption/OpenPGP/KeyInfo.hs @@ -1,7 +1,8 @@ --- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods --- Copyright © 2012-2018 Clint Adams +-- KeyInfo.hs: OpenPGP (RFC9580) fingerprinting methods +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + module Codec.Encryption.OpenPGP.KeyInfo ( pubkeySize , pkalgoAbbrev @@ -15,6 +16,7 @@ import Data.List (unfoldr) import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BaseTypes pubkeySize :: PKey -> Either String Int pubkeySize (RSAPubKey (RSA_PublicKey x)) = Right (RSA.public_size x * 8) @@ -26,7 +28,9 @@ pubkeySize (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) _ _) = Right (fromIntegral (ECCT.curveSizeBits curve)) pubkeySize (ECDHPubKey (EdDSAPubKey Ed25519 _) _ _) = Right 256 +pubkeySize (ECDHPubKey (EdDSAPubKey Ed448 _) _ _) = Right 448 pubkeySize (EdDSAPubKey Ed25519 _) = Right 256 +pubkeySize (EdDSAPubKey Ed448 _) = Right 448 pubkeySize x = Left $ "Unable to calculate size of " ++ show x bitcount :: Integer -> Int @@ -39,16 +43,19 @@ then Nothing else Just (True, x `shiftR` 8)) --- FIXME: redo these for hOpenPGP 3 pkalgoAbbrev :: PubKeyAlgorithm -> String -pkalgoAbbrev RSA = "R" -pkalgoAbbrev DSA = "D" -pkalgoAbbrev ElgamalEncryptOnly = "g" -pkalgoAbbrev DeprecatedRSAEncryptOnly = "-" -pkalgoAbbrev DeprecatedRSASignOnly = "_" -pkalgoAbbrev ECDH = "e" -pkalgoAbbrev ECDSA = "E" -pkalgoAbbrev ForbiddenElgamal = "f" -pkalgoAbbrev DH = "d" -pkalgoAbbrev EdDSA = "w" +pkalgoAbbrev RSA = "rsa" +pkalgoAbbrev DSA = "dsa" +pkalgoAbbrev ElgamalEncryptOnly = "elg" +pkalgoAbbrev DeprecatedRSAEncryptOnly = "-re" +pkalgoAbbrev DeprecatedRSASignOnly = "-rs" +pkalgoAbbrev ECDH = "ecdh" +pkalgoAbbrev ECDSA = "ecd" +pkalgoAbbrev ForbiddenElgamal = "-eg" +pkalgoAbbrev DH = "dh" +pkalgoAbbrev EdDSA = "edd" +pkalgoAbbrev BaseTypes.X25519 = "x25" +pkalgoAbbrev BaseTypes.X448 = "x448" +pkalgoAbbrev BaseTypes.Ed25519 = "e25" +pkalgoAbbrev BaseTypes.Ed448 = "e448" pkalgoAbbrev (OtherPKA _) = "." diff --git a/Codec/Encryption/OpenPGP/KeySelection.hs b/Codec/Encryption/OpenPGP/KeySelection.hs --- a/Codec/Encryption/OpenPGP/KeySelection.hs +++ b/Codec/Encryption/OpenPGP/KeySelection.hs @@ -1,7 +1,8 @@ --- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys --- Copyright © 2014-2018 Clint Adams +-- KeySelection.hs: OpenPGP (RFC9580) ways to ask for keys +-- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.KeySelection @@ -10,7 +11,7 @@ ) where import Codec.Encryption.OpenPGP.Types -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text @@ -31,10 +32,10 @@ fmap EightOctetKeyId . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper -parseFingerprint :: Text -> Either String TwentyOctetFingerprint +parseFingerprint :: Text -> Either String Fingerprint parseFingerprint = - fmap TwentyOctetFingerprint . - (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/= ' ') + fmap Fingerprint . + (parseOnly hexes <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)) . toUpper . T.filter (/= ' ') hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x") diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -1,46 +1,76 @@ --- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright © 2012-2020 Clint Adams +-- KeyringParser.hs: OpenPGP (RFC9580) transferable keys parsing +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} module Codec.Encryption.OpenPGP.KeyringParser ( -- * Parsers parseAChunk + , parseAChunkEither , finalizeParsing + , finalizeParsingEither + , KeyringChunkParseError(..) , anyTK + , anyTKWithWireRep , UidOrUat(..) , splitUs , publicTK + , publicTKWithWireRep , secretTK + , secretTKWithWireRep , brokenTK + , brokenTKWithWireRep , pkPayload + , pkPayloadWithWireRep , signature + , signatureWithWireRep , signedUID + , signedUIDWithWireRep , signedUAt + , signedUAtWithWireRep , signedOrRevokedPubSubkey + , signedOrRevokedPubSubkeyWithWireRep , brokenPubSubkey + , brokenPubSubkeyWithWireRep , rawOrSignedOrRevokedSecSubkey + , rawOrSignedOrRevokedSecSubkeyWithWireRep , brokenSecSubkey + , brokenSecSubkeyWithWireRep , skPayload + , skPayloadWithWireRep , broken + , brokenWithWireRep -- * Utilities + , parseUnknownTKs , parseTKs + , parsePublicTKs + , parseSecretTKs + , parseTKsWithWireRep ) where import Control.Applicative ((<|>), many) -import Data.Maybe (catMaybes) +import Data.List (foldl') +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.List.NonEmpty as NE import Data.Text (Text) import Codec.Encryption.OpenPGP.Ontology (isTrustPkt) +import Codec.Encryption.OpenPGP.Policy + ( isAllowedPrimaryKeySigType + , isAllowedSubkeySigType + , isAllowedUIDSigType + ) +import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () import Text.ParserCombinators.Incremental.LeftBiasedLocal ( Parser - , completeResults , concatMany , failure , feed @@ -49,35 +79,79 @@ , satisfy ) +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 + => [(r, s)] + -> ([r], s) +collapseCompleted rs = + let (resultsRev, remainder) = + foldl' + (\(accResults, accRemainder) (result, rest) -> + (result : accResults, accRemainder <> rest)) + ([], mempty) + rs + in (reverse resultsRev, remainder) + parseAChunk :: (Monoid s, Show s) => Parser s r -> s -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) -parseAChunk _ a ([], Nothing) = error $ "Failure before " ++ show a -parseAChunk op a (cr, Nothing) = -#if MIN_VERSION_incremental_parser(0,4,0) - either error (\x -> (x, map fst cr)) (inspect (feed (mconcat (map snd cr) <> a) op)) -parseAChunk _ a (_, Just (_, p)) = either error (\x -> (x, [])) (inspect (feed a p)) -#else - (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr) -parseAChunk _ a (_, Just (_, p)) = (inspect (feed a p), []) -#endif +parseAChunk op a st = + either (error . renderChunkParseError) id (parseAChunkEither op a st) +parseAChunkEither :: + (Monoid s, Show s) + => Parser s r + -> s + -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> Either + KeyringChunkParseError + (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +parseAChunkEither _ a ([], Nothing) = + Left (ChunkFailureBeforeInput ("Failure before " ++ show a)) +parseAChunkEither op a (cr, Nothing) = + let (completed, remainder) = collapseCompleted cr + in + (\x -> (x, completed)) <$> + either (Left . ChunkParserFailure) Right (inspect (feed (remainder <> a) op)) +parseAChunkEither _ a (_, Just (_, p)) = + (\x -> (x, [])) <$> either (Left . ChunkParserFailure) Right (inspect (feed a p)) + finalizeParsing :: Monoid s => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) -finalizeParsing ([], Nothing) = error "Unexpected finalization failure" -finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr) -#if MIN_VERSION_incremental_parser(0,4,0) -finalizeParsing (_, Just (_, p)) = either error finalizeParsing (inspect (feedEof p)) -#else -finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p)) -#endif +finalizeParsing st = + either (error . renderChunkParseError) id (finalizeParsingEither st) -anyTK :: Bool -> Parser [Pkt] (Maybe TK) +finalizeParsingEither :: + Monoid s + => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> Either + KeyringChunkParseError + (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +finalizeParsingEither ([], Nothing) = Left ChunkUnexpectedFinalizationFailure +finalizeParsingEither (cr, Nothing) = + let (completed, _) = collapseCompleted cr + in Right (([], Nothing), completed) +finalizeParsingEither (_, Just (_, p)) = + either (Left . ChunkParserFailure) finalizeParsingEither (inspect (feedEof p)) + +anyTK :: Bool -> Parser [Pkt] (Maybe TKUnknown) anyTK True = publicTK True <|> secretTK True anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 @@ -102,16 +176,16 @@ unA (A x, y) = (x, y) unA x = error $ "unA should never be called on " ++ show x -publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK) +publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TKUnknown) publicTK intolerant = do pkp <- pkPayload pkpsigs <- concatMany - (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey]) + (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) (uids, uats) <- - fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant + fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (pubsub intolerant) - return $ Just (TK pkp pkpsigs uids uats subs) + return $ Just (TKUnknown pkp pkpsigs uids uats subs) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey @@ -120,16 +194,16 @@ skp <- skPayload skpsigs <- concatMany - (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey]) + (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) (uids, uats) <- - fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant? + fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (secsub intolerant) - return $ Just (TK skp skpsigs uids uats subs) + return $ Just (TKUnknown skp skpsigs uids uats subs) where secsub True = rawOrSignedOrRevokedSecSubkey True secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey -brokenTK :: Int -> Parser [Pkt] (Maybe TK) +brokenTK :: Int -> Parser [Pkt] (Maybe TKUnknown) brokenTK 6 = do _ <- broken 6 _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) @@ -144,18 +218,31 @@ return Nothing brokenTK _ = fail "Unexpected broken packet type" -pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum) +pkPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) pkPayload = do pkpkts <- satisfy isPKP case pkpkts of - [PublicKeyPkt p] -> return (p, Nothing) + [pkt] -> + case pktToPublicKeyPkt pkt of + Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt) + _ -> failure _ -> failure where - isPKP [PublicKeyPkt _] = True + isPKP [pkt] = + case pktToPublicKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + Nothing -> False isPKP _ = False signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload] -signature intolerant rts = +signature intolerant rts = signatureWithPredicate intolerant (\st -> st `elem` rts) + +-- | RFC9580-aware signature parser that validates context using a predicate +-- The predicate operates on SigType to determine if the signature is allowed +-- in this context (e.g., isAllowedPrimaryKeySigType for primary keys). +signatureWithPredicate :: Bool -> (SigType -> Bool) -> Parser [Pkt] [SignaturePayload] +signatureWithPredicate intolerant predicate = if intolerant then signature' else signature' <|> brokensig' @@ -171,13 +258,10 @@ [sp] _ -> failure brokensig' = const [] <$> broken 2 - isSP True [SignaturePkt sp@SigV3 {}] = isSP' sp - isSP True [SignaturePkt sp@SigV4 {}] = isSP' sp + isSP True [SignaturePkt sp] = isSP' sp isSP False [SignaturePkt _] = True isSP _ _ = False - isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts - isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts - isSP' _ = False + isSP' sigPayload = maybe False predicate (sigType sigPayload) signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUID intolerant = do @@ -186,14 +270,7 @@ [UserIdPkt u] -> do sigs <- concatMany - (signature - intolerant - [ GenericCert - , PersonaCert - , CasualCert - , PositiveCert - , CertRevocationSig - ]) + (signatureWithPredicate intolerant isAllowedUIDSigType) return (I u, sigs) _ -> failure where @@ -207,14 +284,7 @@ [UserAttributePkt us] -> do sigs <- concatMany - (signature - intolerant - [ GenericCert - , PersonaCert - , CasualCert - , PositiveCert - , CertRevocationSig - ]) + (signatureWithPredicate intolerant isAllowedUIDSigType) return (A us, sigs) _ -> failure where @@ -228,17 +298,20 @@ [p] -> do sigs <- concatMany - (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig]) + (signatureWithPredicate intolerant isAllowedSubkeySigType) return [(p, sigs)] _ -> failure where - isPSKP [PublicSubkeyPkt _] = True + isPSKP [pkt] = + case pktToPublicKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + Nothing -> False isPSKP _ = False brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenPubSubkey = do _ <- broken 14 - _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig]) + _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType) return [] rawOrSignedOrRevokedSecSubkey :: @@ -249,27 +322,37 @@ [p] -> do sigs <- concatMany - (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig]) + (signatureWithPredicate intolerant isAllowedSubkeySigType) return [(p, sigs)] _ -> failure where - isSSKP [SecretSubkeyPkt _ _] = True + isSSKP [pkt] = + case pktToSecretKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + Nothing -> False isSSKP _ = False brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenSecSubkey = do _ <- broken 7 - _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig]) + _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType) return [] -skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum) +skPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) skPayload = do spkts <- satisfy isSKP case spkts of - [SecretKeyPkt p ska] -> return (p, Just ska) + [pkt] -> + case pktToSecretKeyPkt pkt of + Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt) + _ -> failure _ -> failure where - isSKP [SecretKeyPkt _ _] = True + isSKP [pkt] = + case pktToSecretKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + Nothing -> False isSKP _ = False broken :: Int -> Parser [Pkt] Pkt @@ -283,12 +366,316 @@ isBroken _ = False -- | parse TKs from packets -parseTKs :: Bool -> [Pkt] -> [TK] -parseTKs intolerant ps = - catMaybes - (concatMap - fst - (completeResults - (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant)))))) +parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown] +parseUnknownTKs intolerant ps = + catMaybes $ + runIncrementalParser + (anyTK intolerant) + (map (: []) (filter notTrustPacket ps)) where notTrustPacket = not . isTrustPkt + +parseTKs :: Bool -> [Pkt] -> [SomeTK] +parseTKs intolerant = + mapMaybe (either (const Nothing) Just . fromUnknownToTK) . parseUnknownTKs intolerant + +parsePublicTKs :: Bool -> [Pkt] -> [TK 'PublicTK] +parsePublicTKs intolerant packets = + mapMaybe + (\case + SomePublicTK tk -> Just tk + SomeSecretTK _ -> Nothing) + (parseTKs intolerant packets) + +parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK] +parseSecretTKs intolerant packets = + mapMaybe + (\case + SomeSecretTK tk -> Just tk + SomePublicTK _ -> Nothing) + (parseTKs intolerant packets) + +anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True +anyTKWithWireRep False = + publicTKWithWireRep False <|> secretTKWithWireRep False <|> + brokenTKWithWireRep 6 <|> brokenTKWithWireRep 5 + +publicTKWithWireRep, secretTKWithWireRep :: + Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +publicTKWithWireRep intolerant = do + (pkp, pkps) <- pkPayloadWithWireRep + (pkpsigs, pkpsigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType) + uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant) + subResults <- concatMany (pubsub intolerant) + let semanticUs = fmap fst uidResults + (uids, uats) = splitUs semanticUs + uidrefs = concatMap snd uidResults + subs = fmap fst subResults + subrefs = concatMap snd subResults + tk = TKUnknown pkp pkpsigs uids uats subs + refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs + return $ Just (mkTKWithWireRep tk refs) + where + pubsub True = signedOrRevokedPubSubkeyWithWireRep True + pubsub False = + signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep + +secretTKWithWireRep intolerant = do + (skp, skps) <- skPayloadWithWireRep + (skpsigs, skpsigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType) + uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant) + subResults <- concatMany (secsub intolerant) + let semanticUs = fmap fst uidResults + (uids, uats) = splitUs semanticUs + uidrefs = concatMap snd uidResults + subs = fmap fst subResults + subrefs = concatMap snd subResults + tk = TKUnknown skp skpsigs uids uats subs + refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs + return $ Just (mkTKWithWireRep tk refs) + where + secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True + secsub False = + rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep + +brokenTKWithWireRep :: Int -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +brokenTKWithWireRep 6 = do + _ <- brokenWithWireRep 6 + _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) + _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) + _ <- + concatMany + (signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep) + return Nothing +brokenTKWithWireRep 5 = do + _ <- brokenWithWireRep 5 + _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) + _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) + _ <- + concatMany + (rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep) + return Nothing +brokenTKWithWireRep _ = fail "Unexpected broken packet type" + +pkPayloadWithWireRep :: + Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) +pkPayloadWithWireRep = do + pkpkts <- satisfy isPKPWS + case pkpkts of + [pktWithSource] -> + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt, [pktWithSource]) + _ -> failure + _ -> failure + where + isPKPWS [pktWithSource] = + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + _ -> False + isPKPWS _ = False + +signatureWithWireRep :: + Bool + -> [SigType] + -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) +signatureWithWireRep intolerant rts = + signatureWithWireRepPredicate intolerant (\st -> st `elem` rts) + +-- | RFC9580-aware signature parser with wire representation support +signatureWithWireRepPredicate :: + Bool + -> (SigType -> Bool) + -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) +signatureWithWireRepPredicate intolerant predicate = + if intolerant + then signature' + else signature' <|> brokensig' + where + signature' = do + spks <- satisfy (isSPWS intolerant) + case spks of + [pktWithSource] -> + case _pktValue pktWithSource of + SignaturePkt sp -> + let sigs = + (if intolerant + then id + else filter isSP') + [sp] + in return (sigs, if null sigs then [] else [pktWithSource]) + _ -> failure + _ -> failure + brokensig' = const ([], []) <$> brokenWithWireRep 2 + isSPWS True [pktWithSource] = + case _pktValue pktWithSource of + SignaturePkt sp -> isSP' sp + _ -> False + isSPWS False [pktWithSource] = + case _pktValue pktWithSource of + SignaturePkt _ -> True + _ -> False + isSPWS _ _ = False + isSP' sigPayload = maybe False predicate (sigType sigPayload) + +signedUIDWithWireRep :: + Bool + -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) +signedUIDWithWireRep intolerant = do + upkts <- satisfy isUIDWS + case upkts of + [pktWithSource] -> + case _pktValue pktWithSource of + UserIdPkt u -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) + return ((I u, sigs), pktWithSource : sigrefs) + _ -> failure + _ -> failure + where + isUIDWS [pktWithSource] = + case _pktValue pktWithSource of + UserIdPkt _ -> True + _ -> False + isUIDWS _ = False + +signedUAtWithWireRep :: + Bool + -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) +signedUAtWithWireRep intolerant = do + uapkts <- satisfy isUAtWS + case uapkts of + [pktWithSource] -> + case _pktValue pktWithSource of + UserAttributePkt us -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) + return ((A us, sigs), pktWithSource : sigrefs) + _ -> failure + _ -> failure + where + isUAtWS [pktWithSource] = + case _pktValue pktWithSource of + UserAttributePkt _ -> True + _ -> False + isUAtWS _ = False + +signedOrRevokedPubSubkeyWithWireRep :: + Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +signedOrRevokedPubSubkeyWithWireRep intolerant = do + pskpkts <- satisfy isPSKPWS + case pskpkts of + [pktWithSource] -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) + return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] + _ -> failure + where + isPSKPWS [pktWithSource] = + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + _ -> False + isPSKPWS _ = False + +brokenPubSubkeyWithWireRep :: + Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +brokenPubSubkeyWithWireRep = do + _ <- brokenWithWireRep 14 + _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) + return [] + +rawOrSignedOrRevokedSecSubkeyWithWireRep :: + Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +rawOrSignedOrRevokedSecSubkeyWithWireRep intolerant = do + sskpkts <- satisfy isSSKPWS + case sskpkts of + [pktWithSource] -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) + return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] + _ -> failure + where + isSSKPWS [pktWithSource] = + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + _ -> False + isSSKPWS _ = False + +brokenSecSubkeyWithWireRep :: + Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +brokenSecSubkeyWithWireRep = do + _ <- brokenWithWireRep 7 + _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) + return [] + +skPayloadWithWireRep :: + Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) +skPayloadWithWireRep = do + spkts <- satisfy isSKPWS + case spkts of + [pktWithSource] -> + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt, [pktWithSource]) + _ -> failure + _ -> failure + where + isSKPWS [pktWithSource] = + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + _ -> False + isSKPWS _ = False + +brokenWithWireRep :: Int -> Parser [PktWithWireRep] PktWithWireRep +brokenWithWireRep t = do + bpkts <- satisfy isBrokenWS + case bpkts of + [bp] -> return bp + _ -> failure + where + isBrokenWS [pktWithSource] = + case _pktValue pktWithSource of + BrokenPacketPkt _ a _ -> t == fromIntegral a + _ -> False + isBrokenWS _ = False + +parseTKsWithWireRep :: Bool -> [PktWithWireRep] -> [TKWithWireRep] +parseTKsWithWireRep intolerant ps = + catMaybes $ + runIncrementalParser + (anyTKWithWireRep intolerant) + (map (: []) (filter notTrustPacketWithWireRep ps)) + where + notTrustPacketWithWireRep = not . isTrustPkt . _pktValue + +runIncrementalParser :: + (Monoid s, Show s) + => Parser s r + -> [s] + -> [r] +runIncrementalParser parser chunks = go ([], Just (Nothing, parser)) chunks + where + go st [] = snd (finalizeParsing st) + go st (chunk:rest) = + let (st', out) = parseAChunk parser chunk st + in out <> go st' rest + +mkTKWithWireRep :: TKUnknown -> [PktWithWireRep] -> TKWithWireRep +mkTKWithWireRep tk refs = + case refs of + [] -> error "mkTKWithWireRep requires at least one packet reference" + (pktWithSource:_) -> + TKWithWireRep + (NE.singleton (wireRepOfPkt pktWithSource)) + (spanByteRanges (map _pktRange refs)) + refs + tk diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -0,0 +1,901 @@ +-- Message.hs: OpenPGP (RFC9580) message helpers +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Codec.Encryption.OpenPGP.Message + ( Passphrase + , mkPassphrase + , passphraseBytes + , EncryptedPayload + , mkEncryptedPayload + , encryptedPayloadBytes + , ClearPayload + , mkClearPayload + , clearPayloadBytes + , WrappedSessionMaterial + , SigningAlgorithm(..) + , SecretKeyFor + , VersionedPKPayload + , asV4PKPayload + , asV6PKPayload + , Signer + , SigningCapability + , mkRSASignerV4 + , mkRSASignerV6 + , mkEd25519SignerV4 + , mkEd25519SignerV6 + , mkEd448SignerV4 + , mkEd448SignerV6 + , MessageParseFailure(..) + , MessageDecryptFailure(..) + , MessageError(..) + , SessionMaterialExposure(..) + , EncryptMessageProfile + , EncryptMessageOptions(..) + , RecoveredSessionMaterial(..) + , encryptMessage + , decryptMessage + , signMessage + , signMessageWith + , ConduitMessage.VerificationPolicy(..) + , ConduitMessage.VerificationOptions(..) + , ConduitMessage.defaultVerificationOptions + , verifySignedMessage + ) where + +import Data.Bifunctor (first) +import Data.Kind (Type) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import qualified Crypto.Hash as CH +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA.Types as RSATypes +import qualified Data.ByteArray as BA +import Crypto.Random.Types (MonadRandom, getRandomBytes) +import Data.Binary (put) +import Data.Binary.Put (runPut) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Word (Word8) + +import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher) +import Codec.Encryption.OpenPGP.CFB + ( OpenPGPCFBModeW(..) + , decryptOpenPGPCfb + , decryptPreservingNonce + , encryptOpenPGPCfbRaw + , mdcTrailerForSEIPDv1 + , seipdv1NonceFromIV + , validateSEIPD1MDC + ) +import Codec.Encryption.OpenPGP.Encrypt (encryptSEIPDv2WithSKESKBlock) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) +import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( decryptSKESK6SessionKey + , deriveSKESK6KEK + ) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPPolicy + , defaultPolicy + , deprecatedHashAlgorithms + , messageDefaultAEADAlgorithm + , messageDefaultChunkSize + , messageSEIPDv2SaltOctets + , policyGenerationDeprecations + , policyMessageEncryption + , supportsSEIPDv2Symmetric + , OpenPGPRFCW(..) + , HashAlgorithmW(..) + ) +import Codec.Encryption.OpenPGP.S2K (S2KError(..), renderS2KError, skesk2SessionKey, string2Key) +import Codec.Encryption.OpenPGP.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.Signatures + ( SignError(..) + , VerificationError + , signDataWithRSABuilder + , signDataWithRSAV6Builder + , signDataWithEd25519Builder + , signDataWithEd25519V6Builder + , signDataWithEd448Builder + , signDataWithEd448V6Builder + ) +import Codec.Encryption.OpenPGP.Subpackets + ( sigBuilderInitTyped + , sigBuilderInitV6Typed + , addHashedSubs + , addUnhashedSubs + , listToHashedSubs + , listToUnhashedSubs + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload) +import qualified Data.Conduit.OpenPGP.Message as ConduitMessage + +newtype Passphrase = Passphrase { unPassphrase :: BL.ByteString } + deriving (Eq, Ord, Show) + +newtype EncryptedPayload = EncryptedPayload { unEncryptedPayload :: BL.ByteString } + deriving (Eq, Ord, Show) + +newtype ClearPayload = ClearPayload { unClearPayload :: BL.ByteString } + deriving (Eq, Ord, Show) + +newtype WrappedSessionMaterial = WrappedSessionMaterial { unWrappedSessionMaterial :: B.ByteString } + deriving (Eq, Ord, Show) + +data SigningAlgorithm = AlgoRSA | AlgoEd25519 | AlgoEd448 + +type family SecretKeyFor (alg :: SigningAlgorithm) where + SecretKeyFor 'AlgoRSA = RSATypes.PrivateKey + SecretKeyFor 'AlgoEd25519 = Ed25519.SecretKey + SecretKeyFor 'AlgoEd448 = Ed448.SecretKey + +type family KeyVersionForSig (v :: Type) :: KeyVersion where + KeyVersionForSig V4Sig = 'V4 + KeyVersionForSig V6Sig = 'V6 + +data VersionedPKPayload (v :: KeyVersion) where + VersionedPKPayloadV4 :: PKPayload 'V4 -> VersionedPKPayload 'V4 + VersionedPKPayloadV6 :: PKPayload 'V6 -> VersionedPKPayload 'V6 + +asV4PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V4) +asV4PKPayload (SomePKPayload pk@(PKPayloadV4 _ _ _)) = + Right (VersionedPKPayloadV4 pk) +asV4PKPayload _ = Left "Expected a v4 PKPayload" + +asV6PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V6) +asV6PKPayload (SomePKPayload pk@(PKPayloadV6 _ _ _)) = + Right (VersionedPKPayloadV6 pk) +asV6PKPayload _ = Left "Expected a v6 PKPayload" + +data Signer (alg :: SigningAlgorithm) (v :: Type) where + RSASigner :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA v + Ed25519Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 v + Ed448Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 v + +class SigningCapability (alg :: SigningAlgorithm) v +instance SigningCapability 'AlgoRSA V4Sig +instance SigningCapability 'AlgoRSA V6Sig +instance SigningCapability 'AlgoEd25519 V4Sig +instance SigningCapability 'AlgoEd25519 V6Sig +instance SigningCapability 'AlgoEd448 V4Sig +instance SigningCapability 'AlgoEd448 V6Sig + +mkRSASignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V4Sig +mkRSASignerV4 = RSASigner + +mkRSASignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V6Sig +mkRSASignerV6 = RSASigner + +mkEd25519SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V4Sig +mkEd25519SignerV4 = Ed25519Signer + +mkEd25519SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V6Sig +mkEd25519SignerV6 = Ed25519Signer + +mkEd448SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V4Sig +mkEd448SignerV4 = Ed448Signer + +mkEd448SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V6Sig +mkEd448SignerV6 = Ed448Signer + +data MessageError + = MessageEncryptError String + | MessageDecryptError String + | MessageSignError SignError + | MessageParseError String + | MessageParseFailureError MessageParseFailure + | MessageDecryptFailureError MessageDecryptFailure + deriving (Eq, Show) + +newtype MessageFlow a = + MessageFlow + { runMessageFlow :: Either MessageError a + } + +instance Functor MessageFlow where + fmap f (MessageFlow result) = MessageFlow (fmap f result) + +instance Applicative MessageFlow where + pure = MessageFlow . Right + MessageFlow ff <*> MessageFlow fa = MessageFlow (ff <*> fa) + +instance Monad MessageFlow where + MessageFlow result >>= f = + case result of + Left err -> MessageFlow (Left err) + Right x -> f x + +messageStep :: Either MessageError a -> MessageFlow a +messageStep = MessageFlow + +type MessageFlowT m = ExceptT MessageError m + +runMessageFlowT :: MessageFlowT m a -> m (Either MessageError a) +runMessageFlowT = runExceptT + +liftMessageFlowT :: Monad m => MessageFlow a -> MessageFlowT m a +liftMessageFlowT (MessageFlow result) = + case result of + Left err -> throwE err + Right x -> pure x + +data MessageParseFailure + = MissingEncryptedMessage + | ExpectedSKESKThenEncryptedData + | SKESKSEIPDAlgorithmMismatch + | UnsupportedEncryptedSKESK + | MissingLiteralDataPacket + | UnknownCriticalPacketType Word8 + | BrokenCriticalPacketType Word8 String + deriving (Eq, Show) + +data MessageDecryptFailure + = SessionMaterialDerivationFailed S2KError + | PayloadDecryptFailed String + deriving (Eq, Show) + +data ParsedEncryptedPayloadKind + = LegacySEDPayloadKind + | LegacySEIPDv1PayloadKind + | SEIPDv2PayloadKind + +data EncryptedPreludeKind + = LegacyEncryptedPreludeKind + | SEIPDv2EncryptedPreludeKind + +data SessionMaterialExposure + = DoNotExposeSessionMaterial + | ExposeSessionMaterial + deriving (Eq, Show) + +data EncryptMessageProfile + = RFC4880Message + | RFC9580Message + +data EncryptMessageOptions (p :: EncryptMessageProfile) where + RFC4880EncryptMessageOptions :: + { rfc4880EncryptMessageExposure :: SessionMaterialExposure + , rfc4880EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm + , rfc4880EncryptMessageS2K :: S2K + , rfc4880EncryptMessageIV :: IV + } + -> EncryptMessageOptions 'RFC4880Message + RFC9580EncryptMessageOptions :: + { rfc9580EncryptMessageExposure :: SessionMaterialExposure + , rfc9580EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm + , rfc9580EncryptMessageS2K :: S2K + , rfc9580EncryptMessageIV :: IV + } + -> EncryptMessageOptions 'RFC9580Message + +deriving instance Eq (EncryptMessageOptions p) +deriving instance Show (EncryptMessageOptions p) + +data RecoveredSessionMaterial = + RecoveredSessionMaterial + { recoveredSessionAlgorithm :: SymmetricAlgorithm + , recoveredSessionKey :: SessionKey + } + 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) = err + +mkPassphrase :: BL.ByteString -> Passphrase +mkPassphrase = Passphrase + +passphraseBytes :: Passphrase -> BL.ByteString +passphraseBytes = unPassphrase + +mkEncryptedPayload :: BL.ByteString -> EncryptedPayload +mkEncryptedPayload = EncryptedPayload + +mkClearPayload :: BL.ByteString -> ClearPayload +mkClearPayload = ClearPayload + +clearPayloadBytes :: ClearPayload -> BL.ByteString +clearPayloadBytes = unClearPayload + +encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString +encryptedPayloadBytes = unEncryptedPayload + +firstLeft :: (e -> e') -> Either e a -> Either e' a +firstLeft f = either (Left . f) Right + +-- | Lift a parse failure step into the unified MessageError channel +parseStep :: Either MessageParseFailure a -> MessageFlow a +parseStep = messageStep . firstLeft MessageParseFailureError + +-- | Lift a decrypt failure step into the unified MessageError channel +decryptStep :: Either MessageDecryptFailure a -> MessageFlow a +decryptStep = messageStep . firstLeft MessageDecryptFailureError + +-- | Lift a string encrypt error step into the unified MessageError channel +encryptStep :: Either String a -> MessageFlow a +encryptStep = messageStep . firstLeft MessageEncryptError + +-- | Lift a sign error step into the unified MessageError channel +signStep :: Either SignError a -> MessageFlow a +signStep = messageStep . firstLeft MessageSignError + +signStepT :: Monad m => Either SignError a -> MessageFlowT m a +signStepT = liftMessageFlowT . signStep + +signBackendStep :: Either String a -> Either SignError a +signBackendStep = firstLeft SignBackendError + +decryptSessionStep :: Either S2KError a -> Either MessageDecryptFailure a +decryptSessionStep = firstLeft SessionMaterialDerivationFailed + +decryptSessionKeySizeStep :: Either CipherError a -> Either MessageDecryptFailure a +decryptSessionKeySizeStep = + firstLeft (SessionMaterialDerivationFailed . S2KUnsupportedAlgorithm) + +decryptCipherStep :: Either CipherError a -> Either MessageDecryptFailure a +decryptCipherStep = firstLeft (PayloadDecryptFailed . renderCipherError) + +decryptPayloadStep :: Either String a -> Either MessageDecryptFailure a +decryptPayloadStep = firstLeft PayloadDecryptFailed + +encryptMessage :: + EncryptMessageOptions p + -> Passphrase + -> ClearPayload + -> Either MessageError (EncryptedPayload, Maybe RecoveredSessionMaterial) +encryptMessage options passphrase payload = runMessageFlow $ + case options of + RFC4880EncryptMessageOptions exposure sa s2k iv -> do + encryptedPayload <- encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload + sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase + pure (encryptedPayload, exposedSessionMaterial exposure sa sessionKeyMaterial) + RFC9580EncryptMessageOptions exposure sa s2k iv -> do + encryptStep $ validateRFC9580MessageSymmetric defaultPolicy sa + encryptStep $ validateModernMessageS2K defaultPolicy s2k + encrypted <- + encryptStep $ + encryptSEIPDv2WithSKESKBlock + sa + (messageDefaultAEADAlgorithm messagePolicy) + (messageDefaultChunkSize messagePolicy) + (defaultSEIPDv2SaltFromIV (messageSEIPDv2SaltOctets messagePolicy) iv) + s2k + (unPassphrase passphrase) + (Block [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)]) + sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase + pure + ( EncryptedPayload (runPut (put (Block encrypted))) + , exposedSessionMaterial exposure sa sessionKeyMaterial + ) + where + messagePolicy = policyMessageEncryption defaultPolicy + +defaultSEIPDv2SaltFromIV :: Int -> IV -> Salt +defaultSEIPDv2SaltFromIV outputLen (IV ivBytes) = + Salt (B.take outputLen (B.concat (replicate outputLen seed))) + where + seed + | B.null ivBytes = B.singleton 0 + | otherwise = ivBytes + +encryptMessageWithRFC4880Fallback :: + SymmetricAlgorithm + -> S2K + -> IV + -> Passphrase + -> ClearPayload + -> MessageFlow EncryptedPayload +encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do + keyLen <- encryptStep . first renderCipherError $ keySize sa + sessionMaterial <- encryptStep . first renderS2KError $ + WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase) + let literal = LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload) + cleartext = BL.toStrict (runPut (put (Block [literal]))) + cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext + encrypted <- encryptStep . first renderCipherError $ + encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW sa iv cleartextWithMDC (unWrappedSessionMaterial sessionMaterial) + return . EncryptedPayload . runPut . put $ + Block + [ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) + , SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict encrypted)) + ] + +deriveSessionMaterial :: + SymmetricAlgorithm -> S2K -> Passphrase -> MessageFlow B.ByteString +deriveSessionMaterial sa s2k passphrase = do + keyLen <- encryptStep . first renderCipherError $ keySize sa + encryptStep . first renderS2KError $ string2Key s2k keyLen (unPassphrase passphrase) + +exposedSessionMaterial :: + SessionMaterialExposure + -> SymmetricAlgorithm + -> B.ByteString + -> Maybe RecoveredSessionMaterial +exposedSessionMaterial DoNotExposeSessionMaterial _ _ = Nothing +exposedSessionMaterial ExposeSessionMaterial sa sessionKeyMaterial = + Just + (RecoveredSessionMaterial + { recoveredSessionAlgorithm = sa + , recoveredSessionKey = SessionKey sessionKeyMaterial + }) + +decryptMessage :: Passphrase -> EncryptedPayload -> Either MessageError ClearPayload +decryptMessage passphrase encrypted = runMessageFlow $ do + encryptedPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unEncryptedPayload encrypted)) + payload <- parseStep $ extractEncryptedPayload encryptedPackets + cleartext <- decryptStep $ decryptPayloadTyped passphrase payload + clearPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unClearPayload cleartext)) + parseStep $ extractLiteralPayload clearPackets + +signMessageWith :: + (MonadRandom m, SigningCapability alg v) + => Signer alg v + -> ClearPayload + -> m (Either MessageError BL.ByteString) +signMessageWith signer payload = runMessageFlowT $ + case signer of + RSASigner signerPK signingKey -> + case signerPK of + VersionedPKPayloadV4 pk -> + signV4Message + pk + (\hashed unhashed clear -> + let builder = + sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithRSABuilder withUnhashed signingKey clear) + payload + VersionedPKPayloadV6 pk -> + signV6Message + pk + (\salt hashed unhashed clear -> + let builder = + sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithRSAV6Builder withUnhashed signingKey clear) + payload + Ed25519Signer signerPK signingKey -> + case signerPK of + VersionedPKPayloadV4 pk -> + signV4Message + pk + (\hashed unhashed clear -> + let builder = + sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithEd25519Builder withUnhashed signingKey clear) + payload + VersionedPKPayloadV6 pk -> + signV6Message + pk + (\salt hashed unhashed clear -> + let builder = + sigBuilderInitV6Typed @'PKA.Ed25519 RFC9580W BinarySig SHA512W salt + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithEd25519V6Builder withUnhashed signingKey clear) + payload + Ed448Signer signerPK signingKey -> + case signerPK of + VersionedPKPayloadV4 pk -> + signV4Message + pk + (\hashed unhashed clear -> + let builder = + sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithEd448Builder withUnhashed signingKey clear) + payload + VersionedPKPayloadV6 pk -> + signV6Message + pk + (\salt hashed unhashed clear -> + let builder = + sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + in signDataWithEd448V6Builder withUnhashed signingKey clear) + payload + +signMessage :: + (MonadRandom m, SigningCapability alg v) + => Signer alg v + -> BL.ByteString + -> m (Either MessageError BL.ByteString) +signMessage signer = signMessageWith signer . mkClearPayload + +versionedPKPayload :: VersionedPKPayload v -> PKPayload v +versionedPKPayload (VersionedPKPayloadV4 pk) = pk +versionedPKPayload (VersionedPKPayloadV6 pk) = pk + +verifySignedMessage :: + ConduitMessage.VerificationOptions + -> PublicKeyring + -> BL.ByteString + -> [Either VerificationError Verification] +verifySignedMessage = ConduitMessage.verifyMessage + +signV4Message :: + Monad m + => PKPayload 'V4 + -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) + -> ClearPayload + -> MessageFlowT m BL.ByteString +signV4Message signer signingFn payload = + signStepT (signV4WithIssuers signer signingFn payload) + +signV6Message :: + MonadRandom m + => PKPayload 'V6 + -> (SignatureSalt -> [SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) + -> ClearPayload + -> MessageFlowT m BL.ByteString +signV6Message signer signingFn payload = do + salt <- lift randomSHA512SignatureSalt + signStepT (signV6WithFingerprintOnly signer (signingFn salt) payload) + +randomSHA512SignatureSalt :: MonadRandom m => m SignatureSalt +randomSHA512SignatureSalt = + SignatureSalt . BL.fromStrict <$> getRandomBytes 32 + +signV4WithIssuers :: + PKPayload 'V4 + -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) + -> ClearPayload + -> Either SignError BL.ByteString +signV4WithIssuers signer signingFn payload = do + issuerKeyId <- signBackendStep (eightOctetKeyID (SomePKPayload signer)) + let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint (SomePKPayload signer)))] + unhashed = [SigSubPacket False (Issuer issuerKeyId)] + signWithSubpackets hashed unhashed signingFn payload + +signV6WithFingerprintOnly :: + PKPayload 'V6 + -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) + -> ClearPayload + -> Either SignError BL.ByteString +signV6WithFingerprintOnly signer signingFn payload = do + let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint (SomePKPayload signer)))] + unhashed = [] + signWithSubpackets hashed unhashed signingFn payload + +signWithSubpackets :: + [SigSubPacket] + -> [SigSubPacket] + -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) + -> ClearPayload + -> Either SignError BL.ByteString +signWithSubpackets hashed unhashed signingFn payload = do + let clear = unClearPayload payload + literal = LiteralDataPkt BinaryData BL.empty 0 clear + signature <- signingFn hashed unhashed clear + return . runPut . put $ Block [literal, SignaturePkt signature] + +encryptOpenPGPCfb :: + SymmetricAlgorithm + -> IV + -> B.ByteString + -> WrappedSessionMaterial + -> Either CipherError B.ByteString +encryptOpenPGPCfb sa iv cleartext (WrappedSessionMaterial keydata) = + encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartext keydata + +extractEncryptedPayload :: + [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload +extractEncryptedPayload = + fmap parsedEncryptedPayloadFromPrelude . extractEncryptedPreludeTyped + +data EncryptedPrelude (k :: EncryptedPreludeKind) where + LegacySEDPrelude :: + SKESK 'SKESKV4 + -> B.ByteString + -> EncryptedPrelude 'LegacyEncryptedPreludeKind + LegacySEIPDv1Prelude :: + SKESK 'SKESKV4 + -> B.ByteString + -> EncryptedPrelude 'LegacyEncryptedPreludeKind + SEIPDv2SKESK4Prelude :: + SymmetricAlgorithm + -> S2K + -> AEADAlgorithm + -> Word8 + -> Salt + -> B.ByteString + -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind + SEIPDv2SKESK6Prelude :: + SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> BL.ByteString + -> BL.ByteString + -> BL.ByteString + -> Word8 + -> Salt + -> B.ByteString + -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind + +data SomeEncryptedPrelude where + SomeEncryptedPrelude :: EncryptedPrelude k -> SomeEncryptedPrelude + +extractEncryptedPreludeTyped :: + [Pkt] -> Either MessageParseFailure SomeEncryptedPrelude +extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncDataPkt payload:_) = + Right + (SomeEncryptedPrelude + (LegacySEDPrelude + (SKESK4Packet sa s2k esk) + (BL.toStrict payload))) +extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncIntegrityProtectedDataPkt (SEIPD1 _ payload):_) = + Right + (SomeEncryptedPrelude + (LegacySEIPDv1Prelude + (SKESK4Packet sa s2k esk) + (BL.toStrict payload))) +extractEncryptedPreludeTyped (SKESKPkt skesk:SymEncIntegrityProtectedDataPkt (SEIPD2 payloadSA aead chunkSize salt payload):_) = + toSEIPDv2Prelude skesk payloadSA aead chunkSize salt payload +extractEncryptedPreludeTyped [] = Left MissingEncryptedMessage +extractEncryptedPreludeTyped _ = Left ExpectedSKESKThenEncryptedData + +toSEIPDv2Prelude :: + SKESKPayload + -> SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> BL.ByteString + -> Either MessageParseFailure SomeEncryptedPrelude +toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) payloadSA aead chunkSize salt payload + | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch + | otherwise = + Right + (SomeEncryptedPrelude + (SEIPDv2SKESK4Prelude + sa + s2k + aead + chunkSize + salt + (BL.toStrict payload))) +toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA aead chunkSize salt payload + | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch + | otherwise = + Right + (SomeEncryptedPrelude + (SEIPDv2SKESK6Prelude + sa + aa + s2k + iv + esk + tag + chunkSize + salt + (BL.toStrict payload))) +toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ (Just _))) _ _ _ _ _ = Left UnsupportedEncryptedSKESK +toSEIPDv2Prelude _ _ _ _ _ _ = Left ExpectedSKESKThenEncryptedData + +parsedEncryptedPayloadFromPrelude :: SomeEncryptedPrelude -> SomeParsedEncryptedPayload +parsedEncryptedPayloadFromPrelude (SomeEncryptedPrelude prelude) = + case prelude of + LegacySEDPrelude skesk payload -> + SomeParsedEncryptedPayload (LegacySEDPayload skesk payload) + LegacySEIPDv1Prelude skesk payload -> + SomeParsedEncryptedPayload (LegacySEIPDv1Payload skesk payload) + SEIPDv2SKESK4Prelude sa s2k aead chunkSize salt payload -> + SomeParsedEncryptedPayload + (SEIPDv2Payload + sa + aead + chunkSize + salt + (SEIPDv2SKESK4 sa s2k) + payload) + SEIPDv2SKESK6Prelude sa aa s2k iv esk tag chunkSize salt payload -> + SomeParsedEncryptedPayload + (SEIPDv2Payload + sa + aa + chunkSize + salt + (SEIPDv2SKESK6 sa aa s2k iv esk tag) + payload) + +data SEIPDv2SKESKInfo (v :: KeyVersion) where + SEIPDv2SKESK4 :: SymmetricAlgorithm -> S2K -> SEIPDv2SKESKInfo 'V4 + SEIPDv2SKESK6 :: + SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> BL.ByteString + -> BL.ByteString + -> BL.ByteString + -> SEIPDv2SKESKInfo 'V6 + +data ParsedEncryptedPayload (k :: ParsedEncryptedPayloadKind) where + LegacySEDPayload :: + SKESK 'SKESKV4 + -> B.ByteString + -> ParsedEncryptedPayload 'LegacySEDPayloadKind + LegacySEIPDv1Payload :: + SKESK 'SKESKV4 + -> B.ByteString + -> ParsedEncryptedPayload 'LegacySEIPDv1PayloadKind + SEIPDv2Payload :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SEIPDv2SKESKInfo v + -> B.ByteString + -> ParsedEncryptedPayload 'SEIPDv2PayloadKind + +data SomeParsedEncryptedPayload where + SomeParsedEncryptedPayload :: + ParsedEncryptedPayload k + -> SomeParsedEncryptedPayload + +decryptPayload :: Passphrase -> SomeParsedEncryptedPayload -> Either String ClearPayload +decryptPayload passphrase = + first renderMessageDecryptFailure . decryptPayloadTyped passphrase + +decryptPayloadTyped :: + Passphrase -> SomeParsedEncryptedPayload -> Either MessageDecryptFailure ClearPayload +decryptPayloadTyped passphrase (SomeParsedEncryptedPayload payload) = + case payload of + LegacySEDPayload skesk encryptedPayload -> + decryptLegacySEDPayloadTyped passphrase skesk encryptedPayload + LegacySEIPDv1Payload skesk encryptedPayload -> + decryptLegacySEIPDv1PayloadTyped passphrase skesk encryptedPayload + SEIPDv2Payload sa aead chunkSize salt skeskInfo encryptedPayload -> + decryptSEIPDv2PayloadTyped + passphrase + sa + aead + chunkSize + salt + skeskInfo + encryptedPayload + +decryptLegacySEDPayloadTyped :: + Passphrase + -> SKESK 'SKESKV4 + -> B.ByteString + -> Either MessageDecryptFailure ClearPayload +decryptLegacySEDPayloadTyped passphrase skesk payload = do + (sessionAlgorithm, sessionKeyBytes) <- + decryptSessionStep $ + skesk2SessionKey skesk (unPassphrase passphrase) + decryptCipherStep $ + ClearPayload . BL.fromStrict <$> + decryptOpenPGPCfb + sessionAlgorithm + payload + sessionKeyBytes + +decryptLegacySEIPDv1PayloadTyped :: + Passphrase + -> SKESK 'SKESKV4 + -> B.ByteString + -> Either MessageDecryptFailure ClearPayload +decryptLegacySEIPDv1PayloadTyped passphrase skesk payload = do + (sessionAlgorithm, sessionKeyBytes) <- + decryptSessionStep $ + skesk2SessionKey skesk (unPassphrase passphrase) + (nonce, decrypted) <- + decryptCipherStep $ + decryptPreservingNonce sessionAlgorithm payload sessionKeyBytes + cleartext <- decryptPayloadStep $ validateSEIPD1MDC nonce decrypted + Right (ClearPayload (BL.fromStrict cleartext)) + +decryptSEIPDv2PayloadTyped :: + Passphrase + -> SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SEIPDv2SKESKInfo v + -> B.ByteString + -> Either MessageDecryptFailure ClearPayload +decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo payload = do + sessionKey <- SessionKey <$> deriveSEIPDv2SessionKeyBytes passphrase skeskInfo + decryptPayloadStep $ + ClearPayload . BL.fromStrict <$> + decryptSEIPDv2Payload sa aead chunkSize salt payload sessionKey + +deriveSEIPDv2SessionKeyBytes :: + Passphrase + -> SEIPDv2SKESKInfo v + -> Either MessageDecryptFailure B.ByteString +deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK4 sa s2k) = + deriveSessionKeyBytes passphrase sa s2k +deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK6 sa aead s2k iv esk tag) = do + ikm <- deriveSessionKeyBytes passphrase sa s2k + kek <- decryptPayloadStep $ deriveSKESK6KEK sa aead ikm + decryptPayloadStep $ + decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag) + +deriveSessionKeyBytes :: + Passphrase + -> SymmetricAlgorithm + -> S2K + -> Either MessageDecryptFailure B.ByteString +deriveSessionKeyBytes passphrase sa s2k = do + keyLen <- decryptSessionKeySizeStep $ keySize sa + decryptSessionStep $ string2Key s2k keyLen (unPassphrase passphrase) + +extractLiteralPayload :: [Pkt] -> Either MessageParseFailure ClearPayload +extractLiteralPayload pkts = + case [p | LiteralDataPkt _ _ _ p <- pkts] of + payload:_ -> Right (ClearPayload payload) + [] -> Left MissingLiteralDataPacket + +rejectUnknownCriticalPacketsTyped :: [Pkt] -> Either MessageParseFailure [Pkt] +rejectUnknownCriticalPacketsTyped = + go [] + where + go acc [] = Right (reverse acc) + go acc (pkt:rest) = + case pkt of + OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t) + BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err) + _ -> go (pkt : acc) rest + +validateModernMessageS2K :: OpenPGPPolicy -> S2K -> Either String () +validateModernMessageS2K policy s2k = + case s2kHashAlgorithm s2k of + Just ha + | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) -> + Left + ("deprecated hash algorithm disallowed for modern message generation: " ++ + show ha) + _ -> Right () + +validateRFC9580MessageSymmetric :: + OpenPGPPolicy -> SymmetricAlgorithm -> Either String () +validateRFC9580MessageSymmetric policy sa + | supportsSEIPDv2Symmetric policy sa = Right () + | otherwise = + Left + ("symmetric algorithm disallowed for RFC9580 message generation: " ++ + show sa) + +s2kHashAlgorithm :: S2K -> Maybe HashAlgorithm +s2kHashAlgorithm (Simple ha) = Just ha +s2kHashAlgorithm (Salted ha _) = Just ha +s2kHashAlgorithm (IteratedSalted ha _ _) = Just ha +s2kHashAlgorithm Argon2 {} = Nothing +s2kHashAlgorithm (OtherS2K _ _) = Nothing diff --git a/Codec/Encryption/OpenPGP/Ontology.hs b/Codec/Encryption/OpenPGP/Ontology.hs --- a/Codec/Encryption/OpenPGP/Ontology.hs +++ b/Codec/Encryption/OpenPGP/Ontology.hs @@ -1,9 +1,13 @@ --- Ontology.hs: OpenPGP (RFC4880) "is" functions --- Copyright © 2012-2019 Clint Adams +-- Ontology.hs: OpenPGP (RFC9580) "is" functions +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.Ontology - ( + ( -- * for signature payloads isCertRevocationSig , isRevokerP @@ -25,30 +29,69 @@ import Codec.Encryption.OpenPGP.Types +data TrailerCapableSignaturePayload where + TrailerCapableSignaturePayloadV4 :: + SignaturePayloadV 'SigPayloadV4 -> TrailerCapableSignaturePayload + TrailerCapableSignaturePayloadV6 :: + SignaturePayloadV 'SigPayloadV6 -> TrailerCapableSignaturePayload + +trailerCapableSignaturePayload :: + SignaturePayload -> Maybe TrailerCapableSignaturePayload +trailerCapableSignaturePayload sig = + case toSomeSignaturePayload sig of + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (TrailerCapableSignaturePayloadV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (TrailerCapableSignaturePayloadV6 payload) + _ -> Nothing + +trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType +trailerCapableSigType (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) = st +trailerCapableSigType (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) = st + +trailerCapableSubpacketLists :: + TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket]) +trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data _ _ _ h u _ _)) = + (h, u) +trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ h u _ _)) = + (h, u) + +-- | Test whether a 'SignaturePayload' has the given 'SigType'. +-- Returns 'False' for V3 and 'SigVOther' payloads; V3 signatures are excluded +-- from structural predicate checks since they lack subpacket support and are +-- not used in V4/V6 keyring contexts. +isSigTypeFor :: SigType -> SignaturePayload -> Bool +isSigTypeFor expected sig = + case trailerCapableSignaturePayload sig of + Just trailerCapable -> trailerCapableSigType trailerCapable == expected + _ -> False + isCertRevocationSig :: SignaturePayload -> Bool -isCertRevocationSig (SigV4 CertRevocationSig _ _ _ _ _ _) = True -isCertRevocationSig _ = False +isCertRevocationSig = isSigTypeFor CertRevocationSig isRevokerP :: SignaturePayload -> Bool -isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = - any isRevocationKeySSP h && any isIssuerSSP u -isRevokerP _ = False +isRevokerP sig = + case trailerCapableSignaturePayload sig of + Just trailerCapable + | trailerCapableSigType trailerCapable == SignatureDirectlyOnAKey -> + let (h, u) = trailerCapableSubpacketLists trailerCapable + in hasRevokerSubpackets h u + _ -> False +hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool +hasRevokerSubpackets h u = any isRevocationKeySSP h && any isIssuerSSP u + isPKBindingSig :: SignaturePayload -> Bool -isPKBindingSig (SigV4 PrimaryKeyBindingSig _ _ _ _ _ _) = True -isPKBindingSig _ = False +isPKBindingSig = isSigTypeFor PrimaryKeyBindingSig isSKBindingSig :: SignaturePayload -> Bool -isSKBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True -isSKBindingSig _ = False +isSKBindingSig = isSigTypeFor SubkeyBindingSig isSubkeyRevocation :: SignaturePayload -> Bool -isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True -isSubkeyRevocation _ = False +isSubkeyRevocation = isSigTypeFor SubkeyRevocationSig isSubkeyBindingSig :: SignaturePayload -> Bool -isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True -isSubkeyBindingSig _ = False +isSubkeyBindingSig = isSigTypeFor SubkeyBindingSig isTrustPkt :: Pkt -> Bool isTrustPkt (TrustPkt _) = True diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -0,0 +1,493 @@ +-- Policy.hs: OpenPGP standards policy profiles +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Codec.Encryption.OpenPGP.Policy + ( OpenPGPRFC(..) + , OpenPGPRFCW(..) + , SomeOpenPGPRFCW(..) + , promoteOpenPGPRFC + , demoteOpenPGPRFCW + , HashAlgorithmW(..) + , SomeHashAlgorithmW(..) + , promoteHashAlgorithm + , demoteHashAlgorithmW + , HashAlgoStatus(..) + , HashAlgoStatusFor + , HashAlgoAllowedFor + , HashAlgoVerifiableFor + , PKESKVersionPolicy(..) + , MessageEncryptionPolicy(..) + , SecretKeyProtectionPolicy(..) + , GenerationDeprecationPolicy(..) + , VerificationDefaults(..) + , DecryptPolicy(..) + , OpenPGPPolicy(..) + , policyForRFC + , defaultPolicy + , defaultPKESKVersionPolicy + , defaultVerificationDefaults + , defaultDecryptPolicy + , lenientDecryptPolicy + , supportsSEIPDv2Symmetric + , secretKeyProtectionPolicyForKeyVersion + , signatureV6SaltSizeForHashAlgorithm + , ecdhKdfHashDigest + , validateTable30PolicyForRecipient + , legacySecretKeyProtectionErrorMessage + -- * Signature context validation (RFC9580/RFC4880) + , isAllowedPrimaryKeySig + , isAllowedSubkeySig + , isAllowedUIDSig + -- * Signature type validation helpers (for parser use) + , isAllowedPrimaryKeySigType + , isAllowedSubkeySigType + , isAllowedUIDSigType + ) where + +import Codec.Encryption.OpenPGP.Types +import Codec.Encryption.OpenPGP.SignatureQualities (sigType) +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHAlg +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import Data.List (elem) +import Data.Kind (Constraint) +import Data.Word (Word8) +import GHC.TypeLits (ErrorMessage(..), TypeError) + +data OpenPGPRFC + = RFC2440 + | RFC4880 + | RFC9580 + deriving (Eq, Show) + +data OpenPGPRFCW (rfc :: OpenPGPRFC) where + RFC2440W :: OpenPGPRFCW 'RFC2440 + RFC4880W :: OpenPGPRFCW 'RFC4880 + RFC9580W :: OpenPGPRFCW 'RFC9580 + +data SomeOpenPGPRFCW where + SomeOpenPGPRFCW :: OpenPGPRFCW rfc -> SomeOpenPGPRFCW + +demoteOpenPGPRFCW :: OpenPGPRFCW rfc -> OpenPGPRFC +demoteOpenPGPRFCW RFC2440W = RFC2440 +demoteOpenPGPRFCW RFC4880W = RFC4880 +demoteOpenPGPRFCW RFC9580W = RFC9580 + +promoteOpenPGPRFC :: OpenPGPRFC -> SomeOpenPGPRFCW +promoteOpenPGPRFC RFC2440 = SomeOpenPGPRFCW RFC2440W +promoteOpenPGPRFC RFC4880 = SomeOpenPGPRFCW RFC4880W +promoteOpenPGPRFC RFC9580 = SomeOpenPGPRFCW RFC9580W + +data HashAlgorithmW (h :: HashAlgorithm) where + DeprecatedMD5W :: HashAlgorithmW 'DeprecatedMD5 + SHA1W :: HashAlgorithmW 'SHA1 + RIPEMD160W :: HashAlgorithmW 'RIPEMD160 + SHA256W :: HashAlgorithmW 'SHA256 + SHA384W :: HashAlgorithmW 'SHA384 + SHA512W :: HashAlgorithmW 'SHA512 + SHA224W :: HashAlgorithmW 'SHA224 + SHA3_256W :: HashAlgorithmW 'SHA3_256 + SHA3_512W :: HashAlgorithmW 'SHA3_512 + +data SomeHashAlgorithmW where + SomeHashAlgorithmW :: HashAlgorithmW h -> SomeHashAlgorithmW + +demoteHashAlgorithmW :: HashAlgorithmW h -> HashAlgorithm +demoteHashAlgorithmW DeprecatedMD5W = DeprecatedMD5 +demoteHashAlgorithmW SHA1W = SHA1 +demoteHashAlgorithmW RIPEMD160W = RIPEMD160 +demoteHashAlgorithmW SHA256W = SHA256 +demoteHashAlgorithmW SHA384W = SHA384 +demoteHashAlgorithmW SHA512W = SHA512 +demoteHashAlgorithmW SHA224W = SHA224 +demoteHashAlgorithmW SHA3_256W = SHA3_256 +demoteHashAlgorithmW SHA3_512W = SHA3_512 + +promoteHashAlgorithm :: HashAlgorithm -> Maybe SomeHashAlgorithmW +promoteHashAlgorithm DeprecatedMD5 = Just (SomeHashAlgorithmW DeprecatedMD5W) +promoteHashAlgorithm SHA1 = Just (SomeHashAlgorithmW SHA1W) +promoteHashAlgorithm RIPEMD160 = Just (SomeHashAlgorithmW RIPEMD160W) +promoteHashAlgorithm SHA256 = Just (SomeHashAlgorithmW SHA256W) +promoteHashAlgorithm SHA384 = Just (SomeHashAlgorithmW SHA384W) +promoteHashAlgorithm SHA512 = Just (SomeHashAlgorithmW SHA512W) +promoteHashAlgorithm SHA224 = Just (SomeHashAlgorithmW SHA224W) +promoteHashAlgorithm SHA3_256 = Just (SomeHashAlgorithmW SHA3_256W) +promoteHashAlgorithm SHA3_512 = Just (SomeHashAlgorithmW SHA3_512W) +promoteHashAlgorithm (OtherHA _) = Nothing + +signatureV6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 +signatureV6SaltSizeForHashAlgorithm SHA224 = Just 16 +signatureV6SaltSizeForHashAlgorithm SHA256 = Just 16 +signatureV6SaltSizeForHashAlgorithm SHA384 = Just 24 +signatureV6SaltSizeForHashAlgorithm SHA512 = Just 32 +signatureV6SaltSizeForHashAlgorithm SHA3_256 = Just 16 +signatureV6SaltSizeForHashAlgorithm SHA3_512 = Just 32 +signatureV6SaltSizeForHashAlgorithm _ = Nothing + +data HashAlgoStatus + = HashAllowed + | HashShouldNot + | HashMustNot + +type family HashAlgoStatusFor (rfc :: OpenPGPRFC) (h :: HashAlgorithm) :: HashAlgoStatus where + HashAlgoStatusFor 'RFC4880 'DeprecatedMD5 = 'HashShouldNot + HashAlgoStatusFor 'RFC9580 'DeprecatedMD5 = 'HashMustNot + HashAlgoStatusFor 'RFC9580 'SHA1 = 'HashMustNot + HashAlgoStatusFor 'RFC9580 'RIPEMD160 = 'HashShouldNot + HashAlgoStatusFor rfc h = 'HashAllowed + +type family AssertHashAllowed (status :: HashAlgoStatus) :: Constraint where + AssertHashAllowed 'HashAllowed = () + AssertHashAllowed 'HashShouldNot = + TypeError ('Text "Hash algorithm is deprecated (SHOULD NOT) for new signatures under this RFC") + AssertHashAllowed 'HashMustNot = + TypeError ('Text "Hash algorithm is disallowed (MUST NOT) for new signatures under this RFC") + +type HashAlgoAllowedFor rfc h = AssertHashAllowed (HashAlgoStatusFor rfc h) + +type family AssertHashVerifiable (status :: HashAlgoStatus) :: Constraint where + AssertHashVerifiable 'HashAllowed = () + AssertHashVerifiable 'HashShouldNot = () + AssertHashVerifiable 'HashMustNot = + TypeError ('Text "Hash algorithm is disallowed for verification in this RFC context") + +type HashAlgoVerifiableFor rfc h = AssertHashVerifiable (HashAlgoStatusFor rfc h) + +data PKESKVersionPolicy + = PreferV6 + | ForceV3Interop + deriving (Eq, Show) + +data MessageEncryptionPolicy = MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm :: SymmetricAlgorithm + , messageDefaultAEADAlgorithm :: AEADAlgorithm + , messageDefaultChunkSize :: Word8 + , messageS2KSaltOctets :: Int + , messageSEIPDv2SaltOctets :: Int + , messageDefaultS2KForSalt :: Salt -> S2K + , messageSEIPDv2SymmetricAlgorithms :: [SymmetricAlgorithm] + } + +data SecretKeyProtectionPolicy = SecretKeyProtectionPolicy + { secretKeyDefaultSymmetricAlgorithm :: SymmetricAlgorithm + , secretKeyDefaultAEADAlgorithm :: AEADAlgorithm + , secretKeyDefaultS2KForSalt :: Salt -> S2K + , secretKeyS2KSaltOctets :: Int + , secretKeyAEADNonceOctets :: Int + } + +data GenerationDeprecationPolicy = GenerationDeprecationPolicy + { deprecatedHashAlgorithms :: [HashAlgorithm] + , deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm] + } + +data VerificationDefaults = VerificationDefaults + { verificationDefaultStrict :: Bool + , verificationDefaultStreaming :: Bool + } + +-- | Per-message decrypt-side enforcement policy. +-- +-- 'defaultDecryptPolicy' applies RFC9580-strict rules: no unauthenticated +-- (SED) ciphertext, modern symmetric algorithms only, and rejection of +-- deprecated S2K specifiers in SKESK. Use 'lenientDecryptPolicy' when +-- interoperating with older RFC4880 or RFC2440 messages. +data DecryptPolicy = DecryptPolicy + { -- | When 'False' (RFC9580 default), receiving a Symmetrically Encrypted + -- Data packet (SED, tag 9) is a hard error. RFC9580 §5.9 says + -- implementations SHOULD reject unauthenticated ciphertext. + decryptAllowSEDNoIntegrity :: Bool + -- | When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected. + -- Defaults to 'True' for interoperability with RFC4880 senders. + , decryptAllowSEIPDv1 :: Bool + -- | Allowed symmetric algorithms for session keys. 'Nothing' means + -- unrestricted. The RFC9580 default restricts to AES-128/192/256. + , decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm] + -- | Allowed AEAD algorithms for SEIPDv2 payloads. 'Nothing' means + -- unrestricted. The RFC9580 default allows EAX, OCB, and GCM. + , decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm] + -- | When 'True' (RFC9580 default), reject SKESK packets that use Simple + -- or Salted S2K specifiers (both deprecated since RFC9580). + , decryptRejectDeprecatedSKESK :: Bool + -- | When 'True' (RFC9580 default), any packet received after the + -- message-integrity boundary (MDC for SEIPDv1, final AEAD tag for + -- SEIPDv2, or the outer encrypted-data packet for SED) is a hard error. + -- RFC9580 §5.13.2 requires that implementations detect and reject + -- data appended after the authenticated payload. Set to 'False' only + -- when interoperating with legacy implementations that emit trailing + -- garbage (implies 'lenientDecryptPolicy'). + , decryptRejectTrailingData :: Bool + -- | When 'True' (RFC9580 default), a payload with no version-aligned + -- ESK is a hard error even when misaligned ESKs are present. This is a + -- distinct concern from trailing-data rejection: a message could have + -- correct framing yet still carry only v6 PKESKs before a SEIPDv1 + -- payload (or only v4 SKESKs before a SEIPDv2 payload), which indicates + -- a mis-assembled message rather than an integrity violation. + -- Set to 'False' only when salvaging malformed legacy messages. + , decryptRejectESKVersionMismatch :: Bool + } deriving (Eq, Show) + +data OpenPGPPolicy = OpenPGPPolicy + { policyRFC :: OpenPGPRFC + , policyMessageEncryption :: MessageEncryptionPolicy + , policySecretKeyProtection :: Maybe SecretKeyProtectionPolicy + , policyGenerationDeprecations :: GenerationDeprecationPolicy + , policyDecrypt :: DecryptPolicy + } + +policyForRFC :: OpenPGPRFC -> OpenPGPPolicy +policyForRFC RFC2440 = + OpenPGPPolicy + { policyRFC = RFC2440 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = TripleDES + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 8 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> IteratedSalted SHA1 (requireSalt8 "RFC2440 message S2K" salt) 65536 + , messageSEIPDv2SymmetricAlgorithms = [] + } + , policySecretKeyProtection = Nothing + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [] + , deprecatedSymmetricAlgorithms = [] + } + , policyDecrypt = lenientDecryptPolicy + } +policyForRFC RFC4880 = + OpenPGPPolicy + { policyRFC = RFC4880 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = AES128 + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 8 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> IteratedSalted SHA256 (requireSalt8 "RFC4880 message S2K" salt) 65536 + , messageSEIPDv2SymmetricAlgorithms = [] + } + , policySecretKeyProtection = Nothing + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [DeprecatedMD5] + , deprecatedSymmetricAlgorithms = [] + } + , policyDecrypt = lenientDecryptPolicy + } +policyForRFC RFC9580 = + OpenPGPPolicy + { policyRFC = RFC9580 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = AES256 + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 16 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 message S2K" salt) 1 4 15 + , messageSEIPDv2SymmetricAlgorithms = [AES128, AES192, AES256] + } + , policySecretKeyProtection = + Just + SecretKeyProtectionPolicy + { secretKeyDefaultSymmetricAlgorithm = AES256 + , secretKeyDefaultAEADAlgorithm = OCB + , secretKeyDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 secret key S2K" salt) 1 4 15 + , secretKeyS2KSaltOctets = 16 + , secretKeyAEADNonceOctets = 15 + } + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160] + , deprecatedSymmetricAlgorithms = [IDEA, TripleDES, CAST5, Blowfish] + } + , policyDecrypt = defaultDecryptPolicy + } + +requireSalt8 :: String -> Salt -> Salt8 +requireSalt8 context salt = + case salt8FromSalt salt of + Just salt8 -> salt8 + Nothing -> error (context ++ " requires an 8-octet salt") + +requireSalt16 :: String -> Salt -> Salt16 +requireSalt16 context salt = + case salt16FromSalt salt of + Just salt16 -> salt16 + Nothing -> error (context ++ " requires a 16-octet salt") + +defaultPolicy :: OpenPGPPolicy +defaultPolicy = policyForRFC RFC9580 + +defaultPKESKVersionPolicy :: PKESKVersionPolicy +defaultPKESKVersionPolicy = PreferV6 + +defaultVerificationDefaults :: VerificationDefaults +defaultVerificationDefaults = + VerificationDefaults + { verificationDefaultStrict = True + , verificationDefaultStreaming = True + } + +-- | RFC9580-strict decrypt policy. Rejects unauthenticated SED ciphertext, +-- restricts session-key symmetric algorithms to AES-128/192/256 and AEAD to +-- EAX/OCB/GCM, and rejects SKESK packets carrying deprecated Simple or +-- Salted S2K specifiers. SEIPDv1 (MDC-protected) is still accepted for +-- interoperability with RFC4880 senders. +defaultDecryptPolicy :: DecryptPolicy +defaultDecryptPolicy = + DecryptPolicy + { decryptAllowSEDNoIntegrity = False + , decryptAllowSEIPDv1 = True + , decryptAllowedSymmetricAlgos = Just [AES128, AES192, AES256] + , decryptAllowedAEADAlgos = Just [EAX, OCB, GCM] + , decryptRejectDeprecatedSKESK = True + , decryptRejectTrailingData = True + , decryptRejectESKVersionMismatch = True + } + +-- | Permissive decrypt policy for interoperability with RFC4880 and RFC2440 +-- messages. No algorithm or integrity restrictions are applied. +lenientDecryptPolicy :: DecryptPolicy +lenientDecryptPolicy = + DecryptPolicy + { decryptAllowSEDNoIntegrity = True + , decryptAllowSEIPDv1 = True + , decryptAllowedSymmetricAlgos = Nothing + , decryptAllowedAEADAlgos = Nothing + , decryptRejectDeprecatedSKESK = False + , decryptRejectTrailingData = False + , decryptRejectESKVersionMismatch = False + } + +supportsSEIPDv2Symmetric :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool +supportsSEIPDv2Symmetric policy sa = + sa `elem` messageSEIPDv2SymmetricAlgorithms (policyMessageEncryption policy) + +secretKeyProtectionPolicyForKeyVersion :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy +secretKeyProtectionPolicyForKeyVersion policy V6 = policySecretKeyProtection policy +secretKeyProtectionPolicyForKeyVersion _ _ = Nothing + +ecdhKdfHashDigest :: HashAlgorithm -> B.ByteString -> Either String B.ByteString +ecdhKdfHashDigest SHA1 _ = Left "ECDH KDF hash algorithm SHA1 is disallowed by policy" +ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA224)) +ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA256)) +ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA384)) +ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA512)) +ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_256)) +ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_512)) +ecdhKdfHashDigest _ _ = Left "ECDH KDF hash algorithm is unsupported" + +validateTable30PolicyForRecipient :: + SomePKPayload -> HashAlgorithm -> SymmetricAlgorithm -> Either String () +validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA = + case allowedTable30EcdhParameterSets recipientPKP (_pubkey recipientPKP) of + Nothing -> Right () + Just (curveName, allowedParams) -> + if (kdfHA, kdfSA) `elem` allowedParams + then Right () + else + Left + ("RFC9580 Table 30 policy violation for " ++ + show (_keyVersion recipientPKP) ++ + " ECDH key on " ++ + curveName ++ + ": expected one of " ++ + show allowedParams ++ + ", got (" ++ + show kdfHA ++ + ", " ++ + show kdfSA ++ + ")") + +allowedTable30EcdhParameterSets :: + SomePKPayload + -> PKey + -> Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)]) +allowedTable30EcdhParameterSets recipientPKP (ECDHPubKey ecdhPub _ _) + | _keyVersion recipientPKP == V4 = + case ecdhPub of + EdDSAPubKey Ed25519 _ -> + Just + ( "Curve25519Legacy" + , [ (ha, sa) + | ha <- [SHA256, SHA384, SHA512] + , sa <- [AES128, AES192, AES256] + ] + ) + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> + Just ("NIST P-256", [(SHA256, AES128)]) + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> + Just ("NIST P-384", [(SHA384, AES192)]) + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> + Just ("NIST P-521", [(SHA512, AES256)]) + _ -> Nothing + | _keyVersion recipientPKP == V6 = + case ecdhPub of + EdDSAPubKey Ed25519 _ -> Just ("Curve25519Legacy", [(SHA256, AES128)]) + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> + Just ("NIST P-256", [(SHA256, AES128)]) + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> + Just ("NIST P-384", [(SHA384, AES192)]) + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> + Just ("NIST P-521", [(SHA512, AES256)]) + _ -> Nothing + | otherwise = Nothing +allowedTable30EcdhParameterSets _ _ = Nothing + +legacySecretKeyProtectionErrorMessage :: String +legacySecretKeyProtectionErrorMessage = + "re-encrypting legacy secret keys without SHA-1 protection is unsupported; explicit legacy override required" + +-- RFC9580/RFC4880 signature context validation predicates +-- These enforce which signature types are allowed in which structural contexts + +-- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or SignatureDirectlyOnAKey +isAllowedPrimaryKeySig :: SignaturePayload -> Bool +isAllowedPrimaryKeySig = maybe False isAllowedPrimaryKeySigType . sigType + +-- | RFC9580 §3.3: Subkey can only have SubkeyBindingSig or SubkeyRevocationSig +isAllowedSubkeySig :: SignaturePayload -> Bool +isAllowedSubkeySig = maybe False isAllowedSubkeySigType . sigType + +-- | RFC9580 §3.4: User ID can only have various certification types or CertRevocationSig +isAllowedUIDSig :: SignaturePayload -> Bool +isAllowedUIDSig = maybe False isAllowedUIDSigType . sigType + +-- | Test if a SigType is allowed on a primary key +isAllowedPrimaryKeySigType :: SigType -> Bool +isAllowedPrimaryKeySigType KeyRevocationSig = True +isAllowedPrimaryKeySigType SignatureDirectlyOnAKey = True +isAllowedPrimaryKeySigType _ = False + +-- | Test if a SigType is allowed on a subkey +isAllowedSubkeySigType :: SigType -> Bool +isAllowedSubkeySigType SubkeyBindingSig = True +isAllowedSubkeySigType SubkeyRevocationSig = True +isAllowedSubkeySigType _ = False + +-- | Test if a SigType is allowed on a User ID +isAllowedUIDSigType :: SigType -> Bool +isAllowedUIDSigType GenericCert = True +isAllowedUIDSigType PersonaCert = True +isAllowedUIDSigType CasualCert = True +isAllowedUIDSigType PositiveCert = True +isAllowedUIDSigType CertRevocationSig = True +isAllowedUIDSigType _ = False diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -1,47 +1,235 @@ --- S2K.hs: OpenPGP (RFC4880) string-to-key conversion --- Copyright © 2013-2016 Clint Adams +-- S2K.hs: OpenPGP (RFC9580) string-to-key conversion +-- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.S2K - ( string2Key + ( EncodedSessionKeyError(..) + , renderEncodedSessionKeyError + , S2KError(..) + , renderS2KError + , decodeOpenPGPEncodedSessionKey + , string2Key , skesk2Key + , skesk2SessionKey ) where -import Codec.Encryption.OpenPGP.BlockCipher (keySize) +import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), keySize, withSymmetricCipher) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) import Codec.Encryption.OpenPGP.Types -import Control.Monad.Loops (untilM_) -import Control.Monad.Trans.State.Lazy (execState, get, put) -import qualified Crypto.Hash as CH -import qualified Data.ByteArray as BA +import Data.Bits (shiftL) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import Data.Word (Word8, Word16) +import Crypto.Error (CryptoFailable(..)) +import qualified Crypto.Hash as CH +import qualified Crypto.KDF.Argon2 as Argon2 +import qualified Data.ByteArray as BA +import Data.Bifunctor (first) -string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString -string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp ha ksz bs +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 + +string2Key :: S2K -> Int -> BL.ByteString -> Either S2KError B.ByteString +string2Key (Simple ha) ksz bs = + B.take (fromIntegral ksz) <$> hashpp ha ksz bs string2Key (Salted ha salt) ksz bs = - string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt salt)) bs) + string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt8 salt)) bs) string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ - BL.append (BL.fromStrict (unSalt salt)) bs) -string2Key _ _ _ = error "FIXME: unimplemented S2K type" + BL.append (BL.fromStrict (unSalt8 salt)) bs) +string2Key (Argon2 salt t p encodedM) ksz pass = + argon2String2Key salt t p encodedM ksz pass +string2Key (OtherS2K t _) _ _ = + Left (S2KUnsupportedSpecifier t) -skesk2Key :: SKESK -> BL.ByteString -> B.ByteString -skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass -skesk2Key _ _ = error "FIXME" +skesk2Key :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString +skesk2Key skesk pass = snd <$> skesk2SessionKey skesk pass -hashpp :: HashAlgorithm -> Int -> BL.ByteString -> B.ByteString +skesk2SessionKey :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError (SymmetricAlgorithm, B.ByteString) +skesk2SessionKey (SKESK4Packet sa s2k Nothing) pass = do + keyLen <- first S2KUnsupportedAlgorithm (keySize sa) + sessionKey <- string2Key s2k keyLen pass + pure (sa, sessionKey) +skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) pass = do + keyLen <- first S2KUnsupportedAlgorithm (keySize sa) + kek <- string2Key s2k keyLen pass + decrypted <- + first S2KEncryptedSessionKeyCipherError $ + withSymmetricCipher sa kek + (\cipher -> + paddedCfbDecrypt + cipher + (B.replicate (blockSize cipher) 0) + (BL.toStrict esk)) + first S2KEncryptedSessionKeyDecodeError (decodeSKESK4EncryptedSessionKey decrypted) + +decodeOpenPGPEncodedSessionKey :: + B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) +decodeOpenPGPEncodedSessionKey encodedSessionKey = do + if B.length encodedSessionKey < 3 + then Left EncodedSessionKeyTooShort + else Right () + let symalgo = toFVal (B.head encodedSessionKey) + rest = B.tail encodedSessionKey + keyLen <- encodedSessionKeyKeyLength symalgo + if B.length rest < keyLen + 2 + then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length rest)) + else Right () + let (sessionKey, restAfterKey) = B.splitAt keyLen rest + checksumBytes = B.take 2 restAfterKey + actualChecksum = checksum16 sessionKey + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + if actualChecksum /= expectedChecksum + then Left EncodedSessionKeyChecksumMismatch + else Right (symalgo, sessionKey) + +decodeSKESK4EncryptedSessionKey :: + B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) +decodeSKESK4EncryptedSessionKey encodedSessionKey = do + if B.length encodedSessionKey < 1 + then Left EncodedSessionKeyTooShort + else Right () + let symalgo = toFVal (B.head encodedSessionKey) + sessionKey = B.tail encodedSessionKey + keyLen <- encodedSessionKeyKeyLength symalgo + if B.length sessionKey /= keyLen + then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length sessionKey)) + else Right (symalgo, sessionKey) + +encodedSessionKeyKeyLength :: + SymmetricAlgorithm -> Either EncodedSessionKeyError Int +encodedSessionKeyKeyLength symalgo = + first renderKeySizeError (keySize symalgo) + where + renderKeySizeError :: CipherError -> EncodedSessionKeyError + renderKeySizeError (UnsupportedAlgorithm sa) = + EncodedSessionKeyUnsupportedAlgorithm sa + renderKeySizeError (CipherInitFailed sa _) = + EncodedSessionKeyUnsupportedAlgorithm sa + renderKeySizeError (CipherOperationFailed _) = + EncodedSessionKeyUnsupportedAlgorithm symalgo + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral . + B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 + +argon2String2Key :: Salt16 -> Word8 -> Word8 -> Word8 -> Int -> BL.ByteString -> Either S2KError B.ByteString +argon2String2Key salt t p encodedM keyLen pass + | t == 0 = Left (S2KArgon2ParamError "Argon2 S2K pass count must be non-zero") + | p == 0 = Left (S2KArgon2ParamError "Argon2 S2K parallelism must be non-zero") + | encodedM > 31 = Left (S2KArgon2ParamError "Argon2 S2K encoded_m must be <= 31") + | encodedM < minEncodedM = Left (S2KArgon2ParamError "Argon2 S2K encoded_m is too small for parallelism") + | otherwise = + case Argon2.hash opts (BL.toStrict pass) (unSalt16 salt) keyLen of + CryptoPassed k -> Right k + CryptoFailed e -> Left (S2KArgon2Failed (show e)) + where + opts = + Argon2.defaultOptions + { Argon2.iterations = fromIntegral t + , Argon2.memory = fromIntegral (1 `shiftL` fromIntegral encodedM :: Int) + , Argon2.parallelism = fromIntegral p + , Argon2.variant = Argon2.Argon2id + , Argon2.version = Argon2.Version13 + } + minEncodedM = fromIntegral (3 + ceilLog2 (fromIntegral p :: Int)) + +ceilLog2 :: Int -> Int +ceilLog2 n + | n <= 1 = 0 + | otherwise = go 0 1 + where + go e v + | v >= n = e + | otherwise = go (e + 1) (v * 2) + +hashpp :: HashAlgorithm -> Int -> BL.ByteString -> Either S2KError B.ByteString hashpp ha keysize pp = - snd (execState (hashround `untilM_` bigEnough) (0, B.empty)) + go 0 B.empty where - hashround = - get >>= \(ctr, bs) -> - put (ctr + 1, bs `B.append` hf ha (nulpad ctr `BL.append` pp)) + go ctr acc + | B.length acc >= keysize = Right acc + | otherwise = do + digest <- hf ha (nulpad ctr `BL.append` pp) + go (ctr + 1) (acc `B.append` digest) nulpad = BL.pack . flip replicate 0 - bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize) - hf :: HashAlgorithm -> BL.ByteString -> B.ByteString - hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1) - hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512) - hf _ _ = error "FIXME: unimplemented S2K hash" + hf :: HashAlgorithm -> BL.ByteString -> Either S2KError B.ByteString + hf DeprecatedMD5 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.MD5)) + hf SHA1 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)) + hf SHA224 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA224)) + hf SHA256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA256)) + hf SHA384 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA384)) + hf SHA512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)) + hf SHA3_256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_256)) + hf SHA3_512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_512)) + hf (OtherHA ha') _ = Left (S2KUnsupportedHashAlgorithm (OtherHA ha')) diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -1,113 +1,699 @@ --- SecretKey.hs: OpenPGP (RFC4880) secret key encryption/decryption --- Copyright © 2013-2018 Clint Adams +-- SecretKey.hs: OpenPGP (RFC9580) secret key encryption/decryption +-- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + module Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey + , encryptPrivateKeyWithPolicyAndSaltAndIV , encryptPrivateKey - , encryptPrivateKeyIO - , reencryptSecretKeyIO + , changePrivateKeyPassphrase + , changePrivateKeyPassphraseRandom + , changeSecretKeyPassphrase + , changeSecretKeyPassphraseRandom + , reencryptSecretKeyRandomEither + , reencryptPrivateKeyTyped ) where -import Codec.Encryption.OpenPGP.BlockCipher (keySize, withSymmetricCipher) +import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce) -import Codec.Encryption.OpenPGP.Internal.HOBlockCipher -import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key) -import Codec.Encryption.OpenPGP.Serialize (getSecretKey) +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB + ( decryptWithOCBRFC7253With + , encryptWithOCBRFC7253 + ) +import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPPolicy(..) + , OpenPGPRFC(..) + , SecretKeyProtectionPolicy + , defaultPolicy + , legacySecretKeyProtectionErrorMessage + , secretKeyAEADNonceOctets + , secretKeyDefaultAEADAlgorithm + , secretKeyDefaultS2KForSalt + , secretKeyDefaultSymmetricAlgorithm + , secretKeyProtectionPolicyForKeyVersion + , secretKeyS2KSaltOctets + ) +import Codec.Encryption.OpenPGP.S2K + ( renderS2KError + , skesk2Key + , string2Key + ) +import Codec.Encryption.OpenPGP.Serialize (getSecretKey, putSKeyForPKPayload) import Codec.Encryption.OpenPGP.Types +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.RSA as R -import Crypto.Random.EntropyPool (createEntropyPool, getEntropyFrom) -import Data.Bifunctor (bimap) +import Crypto.Random.Types (MonadRandom, getRandomBytes) +import Control.Monad (when) +import Data.Bifunctor (bimap, first) import Data.Binary (put) import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail) -import Data.Binary.Put (runPut) +import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord16be, runPut) import qualified Data.ByteArray as BA +import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import Data.List (nub) +import Data.Word (Word8, Word16) -saBlockSize :: SymmetricAlgorithm -> Int -saBlockSize sa = - either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize)) +decryptPrivateKey :: + (SomePKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum +decryptPrivateKey (pkp, ska) pp = + case fromSKAddendumForPKPayload pkp ska of + Left err -> Left err + Right (SomeSKAddendumV skaV) -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp -decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum -decryptPrivateKey (pkp, ska@SUS16bit {}) pp = - either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp) -decryptPrivateKey (pkp, ska@SUSSHA1 {}) pp = - either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp) -decryptPrivateKey (_, SUSym {}) _ = error "SUSym key decryption not implemented" -decryptPrivateKey (_, ska@SUUnencrypted {}) _ = ska +decryptPrivateKeyTyped :: + SomePKPayload + -> SKAddendumV v + -> BL.ByteString + -> Either String (SKAddendumV v) +decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do + (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parse16BitProtectedSecretKey + pure (SKAUnencryptedLegacy sk cksum) +decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do + (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey + pure (SKAUnencryptedLegacy sk cksum) +decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do + (sk, _) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey + pure (SKAUnencryptedV6 sk) +decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do + sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp + pure (SKAUnencryptedV6 sk) +decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do + sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp + pure (SKAUnencryptedLegacy sk 0) +decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do + keyLen <- first renderCipherError (keySize sa) + dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) + p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) + (sk, cksum) <- parse16BitProtectedSecretKey pkp p + pure (SKAUnencryptedLegacy sk cksum) +decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do + keyLen <- first renderCipherError (keySize sa) + dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) + p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) + (sk, _) <- parse16BitProtectedSecretKey pkp p + pure (SKAUnencryptedV6 sk) +decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska +decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska -decryptSKA :: - (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum -decryptSKA (pkp, SUS16bit sa s2k iv payload) pp = do - let key = skesk2Key (SKESK 4 sa s2k Nothing) pp - p <- decryptNoNonce sa iv (BL.toStrict payload) key - (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the 16bit hash - let checksum = cksum - return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum? - where - getSecretKeyAndChecksum p = - bimap - (\(_, _, x) -> x) - (\(_, _, x) -> x) - (runGetOrFail - (getSecretKey pkp >>= \sk -> - getWord16be >>= \csum -> return (sk, csum)) - (BL.fromStrict p)) -- FIXME: check the 16bit hash -decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do - let key = skesk2Key (SKESK 4 sa s2k Nothing) pp - p <- decryptNoNonce sa iv (BL.toStrict payload) key - (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the SHA1 hash - let checksum = - sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p - return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum? - where - getSecretKeyAndChecksum p = - bimap - (\(_, _, x) -> x) - (\(_, _, x) -> x) - (runGetOrFail - (getSecretKey pkp >>= \sk -> - getRemainingLazyByteString >>= \csum -> return (sk, csum)) - (BL.fromStrict p)) -decryptSKA _ _ = Left "Unexpected codepath" +decryptS2KProtectedPayload :: + SomePKPayload + -> SymmetricAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> BL.ByteString + -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16)) + -> Either String (SKey, Word16) +decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do + dek <- first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp) + decrypted <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) + parser pkp decrypted +parse16BitProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16) +parse16BitProtectedSecretKey pkp p + | B.length p < 2 = Left "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 + cksum <- decodeChecksum checksumPayload + let expected = checksum16 skeyPayload + if cksum == expected + then Right (sk, cksum) + else + Left + ("16-bit secret key checksum mismatch (expected " ++ + show expected ++ ", got " ++ show cksum ++ ")") --- |generates pseudo-random salt and IV -encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum -encryptPrivateKeyIO ska pp = - saltiv >>= \(s, i) -> return (encryptPrivateKey s (IV i) ska pp) - where - saltiv = do - ep <- createEntropyPool - bb <- getEntropyFrom ep (8 + saBlockSize AES256) - return $ B.splitAt 8 bb +parseSHA1ProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16) +parseSHA1ProtectedSecretKey pkp p + | B.length p < 20 = Left "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" --- |8-octet salt, IV must be length of cipher blocksize +decodeSecretKey :: SomePKPayload -> B.ByteString -> Either String SKey +decodeSecretKey pkp payloadBytes = + bimap + (\(_, _, x) -> x) + (\(_, _, x) -> x) + (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes)) + +decodeChecksum :: B.ByteString -> Either String Word16 +decodeChecksum checksumBytes = + bimap + (\(_, _, x) -> x) + (\(_, _, x) -> x) + (runGetOrFail getWord16be (BL.fromStrict checksumBytes)) +decryptAEADPayloadCore :: + SomePKPayload + -> SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> BL.ByteString + -> Either String SKey +decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do + keyLen <- first renderCipherError (keySize sa) + keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) + let keyCandidates = [keyMaterial] + tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F] + infoCandidates = + nub + [ B.pack [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa] + | tag <- tagCandidates + ] + pkpBytes = BL.toStrict (runPut (put pkp)) + adCandidates = + nub + [B.cons tagByte pkpBytes | tagByte <- tagCandidates] + aaCandidates = [aa] + nonce = unIV iv + payloadStrict = BL.toStrict payload + tagLen = 16 + tryDecrypt candidateKeyMaterial info ad aaTry = do + when (B.length payloadStrict < tagLen) $ + Left "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 + kekCandidates = + nub + [ B.take keyLen candidateKeyMaterial + , (expand @CHA.SHA256 prk info keyLen :: B.ByteString) + , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString) + ] + tryKeks = go Nothing + where + go merr [] = + Left $ + "could not decrypt using any KEK candidate" ++ + maybe "" (\e -> " (last error: " ++ 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 + tryKeks kekCandidates + tryAll = go Nothing + where + go merr [] = + Left $ + "could not decrypt v6 AEAD secret key payload" ++ + maybe "" (\e -> " (last error: " ++ 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 + cleartext <- + tryAll + [ (k, i, a, m) + | k <- keyCandidates + , i <- infoCandidates + , a <- adCandidates + , m <- aaCandidates + ] + parseSecretKeyExact pkp cleartext + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral . + B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 + +decryptWithKey :: + SymmetricAlgorithm + -> AEADAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> CCT.AuthTag + -> Either String 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" + case aa of + OCB -> + withAESCipher + unsupportedSecretKeyAEADError + sa + kek + (\cipher -> decryptWithOCBRFC7253With authFailure cipher nonce ad ciphertext authTag) + _ -> do + mode <- aeadMode aa + expectedNonceLen <- aeadNonceSize aa + when (B.length nonce /= expectedNonceLen) $ + Left "invalid nonce size for v6 AEAD secret key payload" + withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher -> + first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead -> + maybe (Left "failed to authenticate v6 AEAD secret key payload") Right + (CCT.aeadSimpleDecrypt aead ad ciphertext authTag) + +aeadMode :: AEADAlgorithm -> Either String 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" + +aeadNonceSize :: AEADAlgorithm -> Either String Int +aeadNonceSize EAX = Right 16 +aeadNonceSize OCB = Right 15 +aeadNonceSize GCM = Right 12 +aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size" + +parseSecretKeyExact :: SomePKPayload -> B.ByteString -> Either String SKey +parseSecretKeyExact pkp cleartext = + case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) (BL.fromStrict cleartext) of + Left (_, _, err) -> Left 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 + +-- |generates pseudo-random salt and IV encryptPrivateKey :: - B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum -encryptPrivateKey _ _ ska@SUS16bit {} _ = ska -encryptPrivateKey _ _ ska@SUSSHA1 {} _ = ska -encryptPrivateKey _ _ ska@SUSym {} _ = ska -encryptPrivateKey salt iv (SUUnencrypted skey _) pp = - SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp)) - where - s2k = IteratedSalted SHA512 (Salt salt) 12058624 + MonadRandom m + => OpenPGPPolicy + -> SomePKPayload + -> SKAddendum + -> BL.ByteString + -> m (Either String SKAddendum) +encryptPrivateKey policy pkp ska pp = do + nextMaterial <- generateSecretKeyProtectionMaterial policy pkp + pure $ do + (salt, iv) <- nextMaterial + encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp -encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString -encryptSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) s2k iv pp = - either error id (encryptNoNonce AES256 s2k iv (BL.toStrict payload) key) +encryptPrivateKeyWithPolicyAndSaltAndIV :: + OpenPGPPolicy + -> SomePKPayload + -> Salt + -> IV + -> SKAddendum + -> BL.ByteString + -> Either String SKAddendum +encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp = + case ska of + SUUnencrypted skey _ -> + encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp + _ -> Right ska + +encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV :: + OpenPGPPolicy + -> SomePKPayload + -> Salt + -> IV + -> SKey + -> BL.ByteString + -> Either String SKAddendum +encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do + (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv + (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload)) <$> + encryptV6SKey pkp skey sa aa s2k iv pp + +changePrivateKeyPassphrase :: + (SomePKPayload, SKAddendum) + -> BL.ByteString + -> Salt + -> IV + -> BL.ByteString + -> Either String SKAddendum +changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do + decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase + case decrypted of + SUUnencrypted skey _ -> + reencryptPrivateKeyWithSaltAndIV pkp ska salt iv skey newPassphrase + _ -> + Left + "Unexpected codepath: decrypted private key material was not in unencrypted form" + +changePrivateKeyPassphraseRandom :: + MonadRandom m + => (SomePKPayload, SKAddendum) + -> BL.ByteString + -> BL.ByteString + -> m (Either String SKAddendum) +changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do + nextMaterial <- generateSecretKeyProtectionMaterial defaultPolicy pkp + pure $ do + (salt, iv) <- nextMaterial + changePrivateKeyPassphrase + (pkp, ska) + oldPassphrase + salt + iv + newPassphrase + +changeSecretKeyPassphrase :: + SecretKey + -> BL.ByteString + -> Salt + -> IV + -> BL.ByteString + -> Either String SecretKey +changeSecretKeyPassphrase sk oldPassphrase salt iv newPassphrase = do + ska <- + changePrivateKeyPassphrase + (_secretKeyPKPayload sk, _secretKeySKAddendum sk) + oldPassphrase + salt + iv + newPassphrase + return sk {_secretKeySKAddendum = ska} + +changeSecretKeyPassphraseRandom :: + MonadRandom m + => SecretKey + -> BL.ByteString + -> BL.ByteString + -> m (Either String SecretKey) +changeSecretKeyPassphraseRandom sk oldPassphrase newPassphrase = do + nextSKA <- + changePrivateKeyPassphraseRandom + (_secretKeyPKPayload sk, _secretKeySKAddendum sk) + oldPassphrase + newPassphrase + pure ((\ska -> sk {_secretKeySKAddendum = ska}) <$> nextSKA) + +encodeSKeyMaterial :: SKey -> Either String 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" + Just u -> Right (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))) + DSAPrivateKey (DSA_PrivateKey (DSA.PrivateKey _ x)) -> + Right (runPut (put (MPI x))) + ElGamalPrivateKey x -> + Right (runPut (put (MPI x))) + ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) -> + Right (runPut (put (MPI d))) + ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) -> + Right (runPut (put (MPI d))) + EdDSAPrivateKey _ bs -> + Right (runPut (put (MPI (os2ip bs)))) + X25519PrivateKey bs -> + Right (runPut (putByteString bs)) + X448PrivateKey bs -> + Right (runPut (putByteString bs)) + UnknownSKey bs -> + Right (runPut (putLazyByteString bs)) + +encryptV6SKey :: SomePKPayload + -> SKey + -> SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> Either String B.ByteString +encryptV6SKey pkp skey sa aa s2k iv pp = do + keyLen <- first renderCipherError (keySize sa) + keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) + payload <- encodeSKeyMaterial skey + let info = B.pack [0xC5, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa] + ad = B.cons 0xC5 (BL.toStrict (runPut (put pkp))) + prk = extract @CHA.SHA256 B.empty keyMaterial + kek = expand @CHA.SHA256 prk info keyLen :: B.ByteString + (tag, ciphertext) <- encryptWithKey sa aa kek ad (unIV iv) (BL.toStrict payload) + pure (ciphertext <> BA.convert (CCT.unAuthTag tag)) + +secretKeyProtectionMaterialLengths :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int) +secretKeyProtectionMaterialLengths policy pkp = + case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of + Just policy -> + Right (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy) + Nothing -> Left legacySecretKeyProtectionErrorMessage + +generateSecretKeyProtectionMaterial :: + MonadRandom m + => OpenPGPPolicy + -> SomePKPayload + -> m (Either String (Salt, IV)) +generateSecretKeyProtectionMaterial policy pkp = + case secretKeyProtectionMaterialLengths policy pkp of + Left err -> pure (Left err) + Right (saltLen, nonceLen) -> do + entropy <- getRandomBytes (saltLen + nonceLen) + let (saltBytes, ivBytes) = B.splitAt saltLen entropy + pure (Right (Salt saltBytes, IV ivBytes)) + +secretKeyProtectionDefaults :: + OpenPGPPolicy + -> SomePKPayload + -> Salt + -> IV + -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K) +secretKeyProtectionDefaults policy pkp salt iv = + case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of + Just policy -> do + when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $ + Left + ("v6 secret key S2K salt must be " ++ + show (secretKeyS2KSaltOctets policy) ++ " octets") + when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $ + Left + ("v6 secret key AEAD nonce must be " ++ + show (secretKeyAEADNonceOctets policy) ++ " octets") + pure + ( secretKeyDefaultSymmetricAlgorithm policy + , secretKeyDefaultAEADAlgorithm policy + , secretKeyDefaultS2KForSalt policy salt + ) + Nothing -> Left legacySecretKeyProtectionErrorMessage + +secretKeyProtectionPolicyForEncryption :: + OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy +secretKeyProtectionPolicyForEncryption policy V6 = + secretKeyProtectionPolicyForKeyVersion policy V6 +secretKeyProtectionPolicyForEncryption policy _ + | policyRFC policy == RFC9580 = Nothing + | otherwise = policySecretKeyProtection policy + +encryptWithKey :: + SymmetricAlgorithm + -> AEADAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String (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" + case aa of + OCB -> + withAESCipher + unsupportedSecretKeyAEADError + sa + kek + (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext) + _ -> do + mode <- aeadMode aa + withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher -> + first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead -> + pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) + +reencryptSecretKeyRandomEither :: + MonadRandom m => SecretKey -> BL.ByteString -> m (Either String SecretKey) +reencryptSecretKeyRandomEither sk pp = + changeSecretKeyPassphraseRandom sk pp pp + +-- | Version-preserving re-encryption of a typed secret-key addendum. +-- +-- Each constructor family is re-encrypted in kind: +-- * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy) +-- * SKA16bit / SKASHA1Legacy → same S2K family with updated salt +-- * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K) +-- * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy +-- * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys) +reencryptPrivateKeyTyped + :: SomePKPayload + -> SKAddendumV v + -> Salt + -> IV + -> SKey + -> BL.ByteString + -> Either String (SKAddendumV v) +reencryptPrivateKeyTyped pkp skaV salt iv skey pp = + case skaV of + SKAAEADV6 {} -> reencryptV6 + SKASHA1V6 {} -> reencryptV6 + SKASymV6 {} -> reencryptV6 + SKAUnencryptedV6 {} -> reencryptV6 + SKA16bit sa s2k _ _ -> + reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> + encryptProtectedSecretKey sa' s2k' iv' ct km checksum16Trailer (SKA16bit sa' s2k' iv') + SKASHA1Legacy sa s2k _ _ -> + reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> + encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv') + SKAAEADLegacy sa _aa s2k _ _ -> + reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> + encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv') + SKASymLegacy sa _ _ -> do + keyLen <- first renderCipherError (keySize sa) + keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) + cleartext <- legacySecretKeyPayload pkp skey + let clearWithChecksum = + BL.toStrict + (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))) + (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted)) <$> + first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial) + SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage where - key = string2Key s2k (keySize AES256) pp - algospecific = - runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u) - cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1 - payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum) - Just u = inverse p q -encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal + reencryptV6 = do + (sa, aa, s2k) <- secretKeyProtectionDefaults defaultPolicy pkp salt iv + (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload)) <$> + encryptV6SKey pkp skey sa aa s2k iv pp -reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey -reencryptSecretKeyIO sk pp = - encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n -> - return sk {_secretKeySKAddendum = n} +reencryptPrivateKeyWithSaltAndIV :: SomePKPayload + -> SKAddendum + -> Salt + -> IV + -> SKey + -> BL.ByteString + -> Either String SKAddendum +reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp = + case fromSKAddendumForPKPayload pkp originalSka of + Left err -> Left err + Right (SomeSKAddendumV skaV) -> + toSKAddendum <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp + +reencryptS2KProtectedSecretKey :: SomePKPayload + -> Salt + -> IV + -> SKey + -> BL.ByteString + -> SymmetricAlgorithm + -> S2K + -> (SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> Either String r) + -> Either String r +reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do + keyLen <- first renderCipherError (keySize sa) + let retargetedS2K = retargetS2K salt s2k + keyMaterial <- first renderS2KError (string2Key retargetedS2K keyLen pp) + cleartext <- legacySecretKeyPayload pkp skey + encryptFn sa retargetedS2K iv cleartext keyMaterial + +encryptLegacyCFBSecretKey :: SomePKPayload + -> SymmetricAlgorithm + -> IV + -> SKey + -> BL.ByteString + -> Either String SKAddendum +encryptLegacyCFBSecretKey pkp sa iv skey pp = do + keyLen <- first renderCipherError (keySize sa) + keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) + cleartext <- legacySecretKeyPayload pkp skey + let clearWithChecksum = + BL.toStrict (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))) + (\encrypted -> SUSym sa iv (BL.fromStrict encrypted)) <$> + first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial) + +encrypt16BitProtectedSecretKey :: + SymmetricAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> B.ByteString + -> Either String SKAddendum +encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial = + encryptProtectedSecretKey + sa + s2k + iv + cleartext + keyMaterial + checksum16Trailer + (\payload -> SUS16bit sa s2k iv payload) + +encryptSHA1ProtectedSecretKey :: + SymmetricAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> B.ByteString + -> Either String SKAddendum +encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial = + encryptProtectedSecretKey + sa + s2k + iv + cleartext + keyMaterial + sha1Trailer + (\payload -> SUSSHA1 sa s2k iv payload) + +encryptProtectedSecretKey :: + SymmetricAlgorithm + -> S2K + -> IV + -> BL.ByteString + -> B.ByteString + -> (BL.ByteString -> BL.ByteString) + -> (BL.ByteString -> r) + -> Either String r +encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do + let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext) + encrypted <- first renderCipherError (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial) + pure (mkAddendum (BL.fromStrict encrypted)) + +checksum16Trailer :: BL.ByteString -> BL.ByteString +checksum16Trailer cleartext = + runPut (putWord16be (checksum16 (BL.toStrict cleartext))) + +sha1Trailer :: BL.ByteString -> BL.ByteString +sha1Trailer cleartext = + BL.fromStrict (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1)) + +legacySecretKeyPayload :: SomePKPayload -> SKey -> Either String BL.ByteString +legacySecretKeyPayload pkp skey = + runPut <$> putSKeyForPKPayload pkp skey + +retargetS2K :: Salt -> S2K -> S2K +retargetS2K salt (Salted ha oldSalt) = + maybe (Salted ha oldSalt) (Salted ha) (salt8FromSalt salt) +retargetS2K salt (IteratedSalted ha oldSalt cnt) = + maybe (IteratedSalted ha oldSalt cnt) (\salt8 -> IteratedSalted ha salt8 cnt) (salt8FromSalt salt) +retargetS2K _ s2k = s2k 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 @@ -1,1495 +1,2989 @@ --- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) --- Copyright © 2012-2025 Clint Adams --- This software is released under the terms of the Expat license. --- (See the LICENSE file). -module Codec.Encryption.OpenPGP.Serialize - ( - -- * Serialization functions - putSKAddendum - , getSecretKey - -- * Utilities - , parsePkts - ) where - -import Control.Applicative (many, some) -import Control.Lens ((^.), _1) -import Control.Monad (guard, replicateM, replicateM_) -import Crypto.Number.Basic (numBits) -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.DSA as D -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Types as ECCT -import qualified Crypto.PubKey.RSA as R -import Data.Bifunctor (bimap) -import Data.Binary (Binary, get, put) -import Data.Binary.Get - ( ByteOffset - , Get - , getByteString - , getLazyByteString - , getRemainingLazyByteString - , getWord16be - , getWord16le - , getWord32be - , getWord8 - , runGetOrFail - ) -import Data.Binary.Put - ( Put - , putByteString - , putLazyByteString - , putWord16be - , putWord16le - , putWord32be - , putWord8 - , runPut - ) -import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Foldable as F -import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Word (Word16, Word32, Word8) -import Network.URI (nullURI, parseURI, uriToString) - -import Codec.Encryption.OpenPGP.Internal - ( curve2Curve - , curveFromCurve - , curveToCurveoidBS - , curveoidBSToCurve - , curveoidBSToEdSigningCurve - , edSigningCurveToCurveoidBS - , multiplicativeInverse - , pubkeyToMPIs - ) -import Codec.Encryption.OpenPGP.Types - -instance Binary SigSubPacket where - get = getSigSubPacket - put = putSigSubPacket - --- instance Binary (Set NotationFlag) where --- put = putNotationFlagSet -instance Binary CompressionAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary PubKeyAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary HashAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary SymmetricAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary MPI where - get = getMPI - put = putMPI - -instance Binary SigType where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary UserAttrSubPacket where - get = getUserAttrSubPacket - put = putUserAttrSubPacket - -instance Binary S2K where - get = getS2K - put = putS2K - -instance Binary PKESK where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary Signature where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary SKESK where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary OnePassSignature where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary SecretKey where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary PublicKey where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary SecretSubkey where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary CompressedData where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary SymEncData where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary Marker where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary LiteralData where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary Trust where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary UserId where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary PublicSubkey where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary UserAttribute where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary SymEncIntegrityProtectedData where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary ModificationDetectionCode where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary OtherPacket where - get = fmap fromPkt getPkt - put = putPkt . toPkt - -instance Binary Pkt where - get = getPkt - put = putPkt - -instance Binary a => Binary (Block a) where - get = Block `fmap` many get - put = mapM_ put . unBlock - -instance Binary PKPayload where - get = getPKPayload - put = putPKPayload - -instance Binary SignaturePayload where - get = getSignaturePayload - put = putSignaturePayload - -instance Binary TK where - get = undefined - put = putTK - -getSigSubPacket :: Get SigSubPacket -getSigSubPacket = do - l <- fmap fromIntegral getSubPacketLength - (crit, pt) <- getSigSubPacketType - getSigSubPacket' pt crit l - where - getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket - getSigSubPacket' pt crit l - | pt == 2 = do - et <- fmap ThirtyTwoBitTimeStamp getWord32be - return $ SigSubPacket crit (SigCreationTime et) - | pt == 3 = do - et <- fmap ThirtyTwoBitDuration getWord32be - return $ SigSubPacket crit (SigExpirationTime et) - | pt == 4 = do - e <- get - return $ SigSubPacket crit (ExportableCertification e) - | pt == 5 = do - tl <- getWord8 - ta <- getWord8 - return $ SigSubPacket crit (TrustSignature tl ta) - | pt == 6 = do - apdre <- getLazyByteString (l - 2) - nul <- getWord8 - guard (nul == 0) - return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) - | pt == 7 = do - r <- get - return $ SigSubPacket crit (Revocable r) - | pt == 9 = do - et <- fmap ThirtyTwoBitDuration getWord32be - return $ SigSubPacket crit (KeyExpirationTime et) - | pt == 11 = do - sa <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) - | pt == 12 = do - rclass <- getWord8 - guard (testBit rclass 7) - algid <- get - fp <- getLazyByteString 20 - return $ - SigSubPacket - crit - (RevocationKey - (bsToFFSet . BL.singleton $ rclass .&. 0x7f) - algid - (TwentyOctetFingerprint fp)) - | pt == 16 = do - keyid <- getLazyByteString (l - 1) - return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) - | pt == 20 = do - flags <- getLazyByteString 4 - nl <- getWord16be - vl <- getWord16be - nn <- getLazyByteString (fromIntegral nl) - nv <- getLazyByteString (fromIntegral vl) - return $ - SigSubPacket - crit - (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv)) - | pt == 21 = do - ha <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredHashAlgorithms ha) - | pt == 22 = do - ca <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) - | pt == 23 = do - ksps <- getLazyByteString (l - 1) - return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) - | pt == 24 = do - pks <- getLazyByteString (l - 1) - return $ SigSubPacket crit (PreferredKeyServer pks) - | pt == 25 = do - primacy <- get - return $ SigSubPacket crit (PrimaryUserId primacy) - | pt == 26 = do - url <- - fmap - (URL . fromMaybe nullURI . parseURI . T.unpack . - decodeUtf8With lenientDecode) - (getByteString (fromIntegral (l - 1))) - return $ SigSubPacket crit (PolicyURL url) - | pt == 27 = do - kfs <- getLazyByteString (l - 1) - return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) - | pt == 28 = do - uid <- getByteString (fromIntegral (l - 1)) - return $ - SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid)) - | pt == 29 = do - rcode <- getWord8 - rreason <- - fmap - (decodeUtf8With lenientDecode) - (getByteString (fromIntegral (l - 2))) - return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) - | pt == 30 = do - fbs <- getLazyByteString (l - 1) - return $ SigSubPacket crit (Features (bsToFFSet fbs)) - | pt == 31 = do - pka <- get - ha <- get - hash <- getLazyByteString (l - 3) - return $ SigSubPacket crit (SignatureTarget pka ha hash) - | pt == 32 = do - spbs <- getLazyByteString (l - 1) - case runGetOrFail get spbs of - Left (_, _, e) -> fail ("embedded signature subpacket " ++ e) - Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp) - | pt == 33 = do - kv <- getWord8 - fp <- - getLazyByteString - (if kv == 4 - then 20 - else 32) - return $ - SigSubPacket crit (IssuerFingerprint kv (TwentyOctetFingerprint fp)) - | pt > 99 && pt < 111 = do - payload <- getLazyByteString (l - 1) - return $ SigSubPacket crit (UserDefinedSigSub pt payload) - | otherwise = do - payload <- getLazyByteString (l - 1) - return $ SigSubPacket crit (OtherSigSub pt payload) - -putSigSubPacket :: SigSubPacket -> Put -putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 2 - putWord32be . unThirtyTwoBitTimeStamp $ et -putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 3 - putWord32be . unThirtyTwoBitDuration $ et -putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do - putSubPacketLength 2 - putSigSubPacketType crit 4 - put e -putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do - putSubPacketLength 3 - putSigSubPacketType crit 5 - put tl - put ta -putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do - putSubPacketLength . fromIntegral $ (2 + BL.length apdre) - putSigSubPacketType crit 6 - putLazyByteString apdre - putWord8 0 -putSigSubPacket (SigSubPacket crit (Revocable r)) = do - putSubPacketLength 2 - putSigSubPacketType crit 7 - put r -putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 9 - putWord32be . unThirtyTwoBitDuration $ et -putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do - putSubPacketLength . fromIntegral $ (1 + length ess) - putSigSubPacketType crit 11 - mapM_ put ess -putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do - putSubPacketLength 23 - putSigSubPacketType crit 12 - putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ - Set.insert (RClOther 0) rclass - put algid - putLazyByteString (unTOF fp) -- 20 octets -putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do - putSubPacketLength 9 - putSigSubPacketType crit 16 - putLazyByteString (unEOKI keyid) -- 8 octets -putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do - putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) - putSigSubPacketType crit 20 - putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs - putWord16be . fromIntegral . BL.length $ nn - putWord16be . fromIntegral . BL.length $ nv - putLazyByteString nn - putLazyByteString nv -putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do - putSubPacketLength . fromIntegral $ (1 + length ehs) - putSigSubPacketType crit 21 - mapM_ put ehs -putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do - putSubPacketLength . fromIntegral $ (1 + length ecs) - putSigSubPacketType crit 22 - mapM_ put ecs -putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do - let kbs = ffSetToBS ksps - putSubPacketLength . fromIntegral $ (1 + BL.length kbs) - putSigSubPacketType crit 23 - putLazyByteString kbs -putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do - putSubPacketLength . fromIntegral $ (1 + BL.length ks) - putSigSubPacketType crit 24 - putLazyByteString ks -putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do - putSubPacketLength 2 - putSigSubPacketType crit 25 - put primacy -putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do - let bs = encodeUtf8 (T.pack (uriToString id uri "")) - putSubPacketLength . fromIntegral $ (1 + B.length bs) - putSigSubPacketType crit 26 - putByteString bs -putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do - let kbs = ffSetToBS kfs - putSubPacketLength . fromIntegral $ (1 + BL.length kbs) - putSigSubPacketType crit 27 - putLazyByteString kbs -putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do - let bs = encodeUtf8 userid - putSubPacketLength . fromIntegral $ (1 + B.length bs) - putSigSubPacketType crit 28 - putByteString bs -putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do - let reasonbs = encodeUtf8 rreason - putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) - putSigSubPacketType crit 29 - putWord8 . fromFVal $ rcode - putByteString reasonbs -putSigSubPacket (SigSubPacket crit (Features fs)) = do - let fbs = ffSetToBS fs - putSubPacketLength . fromIntegral $ (1 + BL.length fbs) - putSigSubPacketType crit 30 - putLazyByteString fbs -putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do - putSubPacketLength . fromIntegral $ (3 + BL.length hash) - putSigSubPacketType crit 31 - put pka - put ha - putLazyByteString hash -putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do - let spb = runPut (put sp) - putSubPacketLength . fromIntegral $ (1 + BL.length spb) - putSigSubPacketType crit 32 - putLazyByteString spb -putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do - let fpb = unTOF fp - putSubPacketLength . fromIntegral $ (2 + BL.length fpb) - putSigSubPacketType crit 33 - putWord8 kv - putLazyByteString fpb -putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = - putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) -putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do - putSubPacketLength . fromIntegral $ (1 + BL.length payload) - putSigSubPacketType crit ptype - putLazyByteString payload - -getSubPacketLength :: Get Word32 -getSubPacketLength = getSubPacketLength' =<< getWord8 - where - getSubPacketLength' :: Integral a => Word8 -> Get a - getSubPacketLength' f - | f < 192 = return . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + - (fromIntegral secondOctet :: Int) + - 192 - | f == 255 = do - len <- getWord32be - return . fromIntegral $ len - | otherwise = fail "Partial body length invalid." - -putSubPacketLength :: Word32 -> Put -putSubPacketLength l - | l < 192 = putWord8 (fromIntegral l) - | l < 8384 = - putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> - putWord8 (fromIntegral (l - 192) .&. 0xff) - | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l) - | otherwise = error ("too big (" ++ show l ++ ")") - -getSigSubPacketType :: Get (Bool, Word8) -getSigSubPacketType = do - x <- getWord8 - return - (if x .&. 128 == 128 - then (True, x .&. 127) - else (False, x)) - -putSigSubPacketType :: Bool -> Word8 -> Put -putSigSubPacketType False sst = putWord8 sst -putSigSubPacketType True sst = putWord8 (sst .|. 0x80) - -bsToFFSet :: FutureFlag a => ByteString -> Set a -bsToFFSet bs = - Set.fromAscList . concat . snd $ - mapAccumL - (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7])) - 0 - (BL.unpack bs) - where - shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] - -ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString -ffSetToFixedLengthBS len ffs = - BL.take - (fromIntegral len) - (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) - -ffSetToBS :: FutureFlag a => Set a -> ByteString -ffSetToBS = BL.pack . ffSetToBS' - where - ffSetToBS' :: FutureFlag a => Set a -> [Word8] - ffSetToBS' ks - | Set.null ks = [] -- FIXME: should this be [0]? - | otherwise = - map - ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . - Set.toAscList) . - (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)) - [0 .. fromFFlag (Set.findMax ks) `div` 8] - -fromS2K :: S2K -> ByteString -fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] -fromS2K (Salted hashalgo salt) - | B.length (unSalt salt) == 8 = - BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append` - (BL.fromStrict . unSalt) salt - | otherwise = error "Confusing salt size" -fromS2K (IteratedSalted hashalgo salt count) - | B.length (unSalt salt) == 8 = - BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append` - (BL.fromStrict . unSalt) salt `BL.snoc` - encodeIterationCount count - | otherwise = error "Confusing salt size" -fromS2K (OtherS2K _ bs) = bs - -getPacketLength :: Get Integer -getPacketLength = do - firstOctet <- getWord8 - getPacketLength' firstOctet - where - getPacketLength' :: Integral a => Word8 -> Get a - getPacketLength' f - | f < 192 = return . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + - (fromIntegral secondOctet :: Int) + - 192 - | f == 255 = do - len <- getWord32be - return . fromIntegral $ len - | otherwise = fail "Partial body length support missing." --FIXME - -putPacketLength :: Integer -> Put -putPacketLength l - | l < 192 = putWord8 (fromIntegral l) - | l < 8384 = - putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> - putWord8 (fromIntegral (l - 192) .&. 0xff) - | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l) - | otherwise = error "partial body length support needed" -- FIXME - -getS2K :: Get S2K -getS2K = getS2K' =<< getWord8 - where - getS2K' :: Word8 -> Get S2K - getS2K' t - | t == 0 = do - ha <- getWord8 - return $ Simple (toFVal ha) - | t == 1 = do - ha <- getWord8 - salt <- getByteString 8 - return $ Salted (toFVal ha) (Salt salt) - | t == 3 = do - ha <- getWord8 - salt <- getByteString 8 - count <- getWord8 - return $ - IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count) - | otherwise = do - bs <- getRemainingLazyByteString - return $ OtherS2K t bs - -putS2K :: S2K -> Put -putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) -putS2K (Salted hashalgo salt) = - error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt) -putS2K (IteratedSalted ha salt count) = do - putWord8 3 - put ha - putByteString (unSalt salt) - putWord8 $ encodeIterationCount count -putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs - -getPacketTypeAndPayload :: Get (Word8, ByteString) -getPacketTypeAndPayload = do - tag <- getWord8 - guard (testBit tag 7) - case tag .&. 0x40 of - 0x00 -> do - let t = shiftR (tag .&. 0x3c) 2 - case tag .&. 0x03 of - 0 -> do - len <- getWord8 - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 1 -> do - len <- getWord16be - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 2 -> do - len <- getWord32be - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 3 -> do - bs <- getRemainingLazyByteString - return (t, bs) - _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." - 0x40 -> do - len <- fmap fromIntegral getPacketLength - bs <- getLazyByteString len - return (tag .&. 0x3f, bs) - _ -> error "This should never happen (getPacketTypeAndPayload/???)." - -getPkt :: Get Pkt -getPkt = do - (t, pl) <- getPacketTypeAndPayload - case runGetOrFail (getPkt' t (BL.length pl)) pl of - Left (_, _, e) -> return $! BrokenPacketPkt e t pl - Right (_, _, p) -> return p - where - getPkt' :: Word8 -> ByteOffset -> Get Pkt - getPkt' t len - | t == 1 = do - pv <- getWord8 - eokeyid <- getLazyByteString 8 - pka <- getWord8 - mpib <- getRemainingLazyByteString - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail ("PKESK MPIs " ++ e) - Right (_, _, sk) -> - return $ - PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk) - | t == 2 = do - bs <- getRemainingLazyByteString - case runGetOrFail get bs of - Left (_, _, e) -> fail ("signature packet " ++ e) - Right (_, _, sp) -> return $ SignaturePkt sp - | t == 3 = do - pv <- getWord8 - symalgo <- getWord8 - s2k <- getS2K - esk <- getRemainingLazyByteString - return $ - SKESKPkt - pv - (toFVal symalgo) - s2k - (if BL.null esk - then Nothing - else Just esk) - | t == 4 = do - pv <- getWord8 - sigtype <- getWord8 - ha <- getWord8 - pka <- getWord8 - skeyid <- getLazyByteString 8 - nested <- getWord8 - return $ - OnePassSignaturePkt - pv - (toFVal sigtype) - (toFVal ha) - (toFVal pka) - (EightOctetKeyId skeyid) - (nested == 0) - | t == 5 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - ska <- getSKAddendum pkp - return $ SecretKeyPkt pkp ska - case ps of - Left (_, _, err) -> fail ("secret key " ++ err) - Right (_, _, key) -> return key - | t == 6 = do - pkp <- getPKPayload - return $ PublicKeyPkt pkp - | t == 7 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - ska <- getSKAddendum pkp - return $ SecretSubkeyPkt pkp ska - case ps of - Left (_, _, err) -> fail ("secret subkey " ++ err) - Right (_, _, key) -> return key - | t == 8 = do - ca <- getWord8 - cdata <- getLazyByteString (len - 1) - return $ CompressedDataPkt (toFVal ca) cdata - | t == 9 = do - sdata <- getLazyByteString len - return $ SymEncDataPkt sdata - | t == 10 = do - marker <- getLazyByteString len - return $ MarkerPkt marker - | t == 11 = do - dt <- getWord8 - flen <- getWord8 - fn <- getLazyByteString (fromIntegral flen) - ts <- fmap ThirtyTwoBitTimeStamp getWord32be - ldata <- getLazyByteString (len - (6 + fromIntegral flen)) - return $ LiteralDataPkt (toFVal dt) fn ts ldata - | t == 12 = do - tdata <- getLazyByteString len - return $ TrustPkt tdata - | t == 13 = do - udata <- getByteString (fromIntegral len) - return . UserIdPkt . decodeUtf8With lenientDecode $ udata - | t == 14 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - return $ PublicSubkeyPkt pkp - case ps of - Left (_, _, err) -> fail ("public subkey " ++ err) - Right (_, _, key) -> return key - | t == 17 = do - bs <- getLazyByteString len - case runGetOrFail (many getUserAttrSubPacket) bs of - Left (_, _, err) -> fail ("user attribute " ++ err) - Right (_, _, uas) -> return $ UserAttributePkt uas - | t == 18 = do - pv <- getWord8 -- should be 1 - b <- getLazyByteString (len - 1) - return $ SymEncIntegrityProtectedDataPkt pv b - | t == 19 = do - hash <- getLazyByteString 20 - return $ ModificationDetectionCodePkt hash - | otherwise = do - payload <- getLazyByteString len - return $ OtherPacketPkt t payload - -getUserAttrSubPacket :: Get UserAttrSubPacket -getUserAttrSubPacket = do - l <- fmap fromIntegral getSubPacketLength - t <- getWord8 - getUserAttrSubPacket' t l - where - getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket - getUserAttrSubPacket' t l - | t == 1 = do - _ <- getWord16le -- ihlen - hver <- getWord8 -- should be 1 - iformat <- getWord8 - nuls <- getLazyByteString 12 -- should be NULs - bs <- getLazyByteString (l - 17) - if hver /= 1 || nuls /= BL.pack (replicate 12 0) - then fail "Corrupt UAt subpacket" - else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs - | otherwise = do - bs <- getLazyByteString (l - 1) - return $ OtherUASub t bs - -putUserAttrSubPacket :: UserAttrSubPacket -> Put -putUserAttrSubPacket ua = do - let sp = runPut $ putUserAttrSubPacket' ua - putSubPacketLength . fromIntegral . BL.length $ sp - putLazyByteString sp - where - putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do - putWord8 1 - putWord16le 16 - putWord8 1 - putWord8 (fromFVal iformat) - replicateM_ 12 $ putWord8 0 - putLazyByteString idata - putUserAttrSubPacket' (OtherUASub t bs) = do - putWord8 t - putLazyByteString bs - -putPkt :: Pkt -> Put -putPkt (PKESKPkt pv eokeyid pka mpis) = do - putWord8 (0xc0 .|. 1) - let bsk = runPut $ F.mapM_ put mpis - putPacketLength . fromIntegral $ 10 + BL.length bsk - putWord8 pv -- must be 3 - putLazyByteString (unEOKI eokeyid) -- must be 8 octets - putWord8 $ fromIntegral . fromFVal $ pka - putLazyByteString bsk -putPkt (SignaturePkt sp) = do - putWord8 (0xc0 .|. 2) - let bs = runPut $ put sp - putLengthThenPayload bs -putPkt (SKESKPkt pv symalgo s2k mesk) = do - putWord8 (0xc0 .|. 3) - let bs2k = fromS2K s2k - let bsk = fromMaybe BL.empty mesk - putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk - putWord8 pv -- should be 4 - putWord8 $ fromIntegral . fromFVal $ symalgo - putLazyByteString bs2k - putLazyByteString bsk -putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do - putWord8 (0xc0 .|. 4) - let bs = - runPut $ do - putWord8 pv -- should be 3 - putWord8 $ fromIntegral . fromFVal $ sigtype - putWord8 $ fromIntegral . fromFVal $ ha - putWord8 $ fromIntegral . fromFVal $ pka - putLazyByteString (unEOKI skeyid) - putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean? - putLengthThenPayload bs -putPkt (SecretKeyPkt pkp ska) = do - putWord8 (0xc0 .|. 5) - let bs = runPut (putPKPayload pkp >> putSKAddendum ska) - putLengthThenPayload bs -putPkt (PublicKeyPkt pkp) = do - putWord8 (0xc0 .|. 6) - let bs = runPut $ putPKPayload pkp - putLengthThenPayload bs -putPkt (SecretSubkeyPkt pkp ska) = do - putWord8 (0xc0 .|. 7) - let bs = runPut (putPKPayload pkp >> putSKAddendum ska) - putLengthThenPayload bs -putPkt (CompressedDataPkt ca cdata) = do - putWord8 (0xc0 .|. 8) - let bs = - runPut $ do - putWord8 $ fromIntegral . fromFVal $ ca - putLazyByteString cdata - putLengthThenPayload bs -putPkt (SymEncDataPkt b) = do - putWord8 (0xc0 .|. 9) - putLengthThenPayload b -putPkt (MarkerPkt b) = do - putWord8 (0xc0 .|. 10) - putLengthThenPayload b -putPkt (LiteralDataPkt dt fn ts b) = do - putWord8 (0xc0 .|. 11) - let bs = - runPut $ do - putWord8 $ fromIntegral . fromFVal $ dt - putWord8 $ fromIntegral . BL.length $ fn - putLazyByteString fn - putWord32be . unThirtyTwoBitTimeStamp $ ts - putLazyByteString b - putLengthThenPayload bs -putPkt (TrustPkt b) = do - putWord8 (0xc0 .|. 12) - putLengthThenPayload b -putPkt (UserIdPkt u) = do - putWord8 (0xc0 .|. 13) - let bs = encodeUtf8 u - putPacketLength . fromIntegral $ B.length bs - putByteString bs -putPkt (PublicSubkeyPkt pkp) = do - putWord8 (0xc0 .|. 14) - let bs = runPut $ putPKPayload pkp - putLengthThenPayload bs -putPkt (UserAttributePkt us) = do - putWord8 (0xc0 .|. 17) - let bs = runPut $ mapM_ put us - putLengthThenPayload bs -putPkt (SymEncIntegrityProtectedDataPkt pv b) = do - putWord8 (0xc0 .|. 18) - putPacketLength . fromIntegral $ BL.length b + 1 - putWord8 pv -- should be 1 - putLazyByteString b -putPkt (ModificationDetectionCodePkt hash) = do - putWord8 (0xc0 .|. 19) - putLengthThenPayload hash -putPkt (OtherPacketPkt t payload) = do - putWord8 (0xc0 .|. t) -- FIXME: restrict t - putLengthThenPayload payload -putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) - -putLengthThenPayload :: ByteString -> Put -putLengthThenPayload bs = do - putPacketLength . fromIntegral $ BL.length bs - putLazyByteString bs - -getMPI :: Get MPI -getMPI = do - mpilen <- getWord16be - bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) - return $ MPI (os2ip bs) - -getPubkey :: PubKeyAlgorithm -> Get PKey -getPubkey RSA = do - MPI n <- get - MPI e <- get - return $ - RSAPubKey - (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)) -getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA -getPubkey DeprecatedRSASignOnly = getPubkey RSA -getPubkey DSA = do - MPI p <- get - MPI q <- get - MPI g <- get - MPI y <- get - return $ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y)) -getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal -getPubkey ForbiddenElgamal = do - MPI p <- get - MPI g <- get - MPI y <- get - return $ ElGamalPubKey p g y -getPubkey ECDSA = do - curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved - curveoid <- getByteString (fromIntegral curvelength) - MPI mpi <- getMPI -- FIXME: check length against curve type? - case curveoidBSToCurve curveoid of - Left e -> fail e - Right Curve25519 -> return $ EdDSAPubKey Ed25519 (EPoint mpi) - Right curve -> - case bs2Point (i2osp mpi) of - Left e -> fail e - Right point -> - return . ECDSAPubKey . ECDSA_PublicKey . - ECDSA.PublicKey (curve2Curve curve) $ - point -getPubkey ECDH = do - ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA - kdflen <- getWord8 -- FIXME: should be 3, test for 0 or 0xFF as they are reserved - one <- getWord8 -- FIXME: should be 1 - kdfHA <- get - kdfSA <- get - return $ ECDHPubKey ed kdfHA kdfSA -getPubkey EdDSA = do - curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved - curveoid <- getByteString (fromIntegral curvelength) - MPI mpi <- getMPI -- FIXME: check length against curve type? - case curveoidBSToEdSigningCurve curveoid of - Left e -> fail e - Right Ed25519 -> return . EdDSAPubKey Ed25519 $ EPoint mpi -getPubkey _ = UnknownPKey <$> getRemainingLazyByteString - -bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint -bs2Point bs = - let xy = B.drop 1 bs - in let l = B.length xy - in if B.head bs == 0x04 - then return - (uncurry - ECCT.Point - (bimap os2ip os2ip (B.splitAt (div l 2) xy))) - else Left $ "unknown type of point: " ++ show (B.unpack bs) - -putPubkey :: PKey -> Put -putPubkey (UnknownPKey bs) = putLazyByteString bs -putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> - mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff -putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> - mapM_ put (pubkeyToMPIs p) >> - putWord8 0x03 >> - putWord8 0x01 >> - put kha >> - put ksa -- FIXME: do not output length 0 or 0xff -putPubkey p@(ECDHPubKey (EdDSAPubKey curve _) kha ksa) = - let Right curveoidbs = curveToCurveoidBS (ed2ec curve) - in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> - mapM_ put (pubkeyToMPIs p) >> - putWord8 0x03 >> - putWord8 0x01 >> - put kha >> - put ksa -- FIXME: do not output length 0 or 0xff - where - ed2ec Ed25519 = Curve25519 -putPubkey p@(EdDSAPubKey curve _) = - let Right curveoidbs = edSigningCurveToCurveoidBS curve - in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> - mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff -putPubkey p = mapM_ put (pubkeyToMPIs p) - -getSecretKey :: PKPayload -> Get SKey -getSecretKey pkp - | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do - MPI d <- get - MPI p <- get - MPI q <- get - MPI _ <- get -- u - let dP = 0 - dQ = 0 - qinv = 0 - pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp ^. pubkey) - return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv)) - | _pkalgo pkp == DSA = do - MPI x <- get - return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x)) - | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do - MPI x <- get - return $ ElGamalPrivateKey x - | _pkalgo pkp == ECDSA = do - MPI pn <- get - let pubcurve = - (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) - (pkp ^. pubkey) - return $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn)) - | _pkalgo pkp == ECDH -- FIXME: deduplicate this and above - = do - MPI pn <- get - let pubcurve = - (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) - (pkp ^. pubkey) - return $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn)) - -putSKey :: SKey -> Put -putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = - put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u) - where - u = multiplicativeInverse q p - -putMPI :: MPI -> Put -putMPI (MPI i) = do - let bs = i2osp i - putWord16be . fromIntegral . numBits $ i - putByteString bs - -getPKPayload :: Get PKPayload -getPKPayload = do - version <- getWord8 - ctime <- fmap ThirtyTwoBitTimeStamp getWord32be - if version `elem` [2, 3] - then do - v3e <- getWord16be - pka <- get - pk <- getPubkey pka - return $! PKPayload DeprecatedV3 ctime v3e pka pk - else do - pka <- get - pk <- getPubkey pka - return $! PKPayload V4 ctime 0 pka pk - -putPKPayload :: PKPayload -> Put -putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do - putWord8 3 - putWord32be . unThirtyTwoBitTimeStamp $ ctime - putWord16be v3e - put pka - putPubkey pk -putPKPayload (PKPayload V4 ctime _ pka pk) = do - putWord8 4 - putWord32be . unThirtyTwoBitTimeStamp $ ctime - put pka - putPubkey pk - -getSKAddendum :: PKPayload -> Get SKAddendum -getSKAddendum pkp = do - s2kusage <- getWord8 - case s2kusage of - 0 -> do - sk <- getSecretKey pkp - checksum <- getWord16be -- FIXME: validate checksum? - return $ SUUnencrypted sk checksum - 255 -> do - symenc <- getWord8 - s2k <- getS2K - case s2k -- FIXME: this is a mess - of - OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty - _ -> do - iv <- getByteString (symEncBlockSize . toFVal $ symenc) - encryptedblock <- getRemainingLazyByteString - return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock - 254 -> do - symenc <- getWord8 - s2k <- getS2K - case s2k -- FIXME: this is a mess - of - OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty - _ -> do - iv <- getByteString (symEncBlockSize . toFVal $ symenc) - encryptedblock <- getRemainingLazyByteString - return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock - symenc -> do - iv <- getByteString (symEncBlockSize . toFVal $ symenc) - encryptedblock <- getRemainingLazyByteString - return $ SUSym (toFVal symenc) (IV iv) encryptedblock - -putSKAddendum :: SKAddendum -> Put -putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do - putWord8 254 - put symenc - put s2k - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendum (SUUnencrypted sk checksum) = do - putWord8 0 - let skb = runPut (putSKey sk) - putLazyByteString skb - putWord16be - (if checksum == 0 - then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb - else checksum) -- FIXME: be saner -putSKAddendum _ = error "Type not supported" - -symEncBlockSize :: SymmetricAlgorithm -> Int -symEncBlockSize Plaintext = 0 -symEncBlockSize IDEA = 8 -symEncBlockSize TripleDES = 8 -symEncBlockSize CAST5 = 8 -symEncBlockSize Blowfish = 8 -symEncBlockSize AES128 = 16 -symEncBlockSize AES192 = 16 -symEncBlockSize AES256 = 16 -symEncBlockSize Twofish = 16 -symEncBlockSize Camellia128 = 16 -symEncBlockSize _ = 8 -- FIXME - -decodeIterationCount :: Word8 -> IterationCount -decodeIterationCount c = - IterationCount - ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)) - -encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table? -encodeIterationCount 1024 = 0 -encodeIterationCount 1088 = 1 -encodeIterationCount 1152 = 2 -encodeIterationCount 1216 = 3 -encodeIterationCount 1280 = 4 -encodeIterationCount 1344 = 5 -encodeIterationCount 1408 = 6 -encodeIterationCount 1472 = 7 -encodeIterationCount 1536 = 8 -encodeIterationCount 1600 = 9 -encodeIterationCount 1664 = 10 -encodeIterationCount 1728 = 11 -encodeIterationCount 1792 = 12 -encodeIterationCount 1856 = 13 -encodeIterationCount 1920 = 14 -encodeIterationCount 1984 = 15 -encodeIterationCount 2048 = 16 -encodeIterationCount 2176 = 17 -encodeIterationCount 2304 = 18 -encodeIterationCount 2432 = 19 -encodeIterationCount 2560 = 20 -encodeIterationCount 2688 = 21 -encodeIterationCount 2816 = 22 -encodeIterationCount 2944 = 23 -encodeIterationCount 3072 = 24 -encodeIterationCount 3200 = 25 -encodeIterationCount 3328 = 26 -encodeIterationCount 3456 = 27 -encodeIterationCount 3584 = 28 -encodeIterationCount 3712 = 29 -encodeIterationCount 3840 = 30 -encodeIterationCount 3968 = 31 -encodeIterationCount 4096 = 32 -encodeIterationCount 4352 = 33 -encodeIterationCount 4608 = 34 -encodeIterationCount 4864 = 35 -encodeIterationCount 5120 = 36 -encodeIterationCount 5376 = 37 -encodeIterationCount 5632 = 38 -encodeIterationCount 5888 = 39 -encodeIterationCount 6144 = 40 -encodeIterationCount 6400 = 41 -encodeIterationCount 6656 = 42 -encodeIterationCount 6912 = 43 -encodeIterationCount 7168 = 44 -encodeIterationCount 7424 = 45 -encodeIterationCount 7680 = 46 -encodeIterationCount 7936 = 47 -encodeIterationCount 8192 = 48 -encodeIterationCount 8704 = 49 -encodeIterationCount 9216 = 50 -encodeIterationCount 9728 = 51 -encodeIterationCount 10240 = 52 -encodeIterationCount 10752 = 53 -encodeIterationCount 11264 = 54 -encodeIterationCount 11776 = 55 -encodeIterationCount 12288 = 56 -encodeIterationCount 12800 = 57 -encodeIterationCount 13312 = 58 -encodeIterationCount 13824 = 59 -encodeIterationCount 14336 = 60 -encodeIterationCount 14848 = 61 -encodeIterationCount 15360 = 62 -encodeIterationCount 15872 = 63 -encodeIterationCount 16384 = 64 -encodeIterationCount 17408 = 65 -encodeIterationCount 18432 = 66 -encodeIterationCount 19456 = 67 -encodeIterationCount 20480 = 68 -encodeIterationCount 21504 = 69 -encodeIterationCount 22528 = 70 -encodeIterationCount 23552 = 71 -encodeIterationCount 24576 = 72 -encodeIterationCount 25600 = 73 -encodeIterationCount 26624 = 74 -encodeIterationCount 27648 = 75 -encodeIterationCount 28672 = 76 -encodeIterationCount 29696 = 77 -encodeIterationCount 30720 = 78 -encodeIterationCount 31744 = 79 -encodeIterationCount 32768 = 80 -encodeIterationCount 34816 = 81 -encodeIterationCount 36864 = 82 -encodeIterationCount 38912 = 83 -encodeIterationCount 40960 = 84 -encodeIterationCount 43008 = 85 -encodeIterationCount 45056 = 86 -encodeIterationCount 47104 = 87 -encodeIterationCount 49152 = 88 -encodeIterationCount 51200 = 89 -encodeIterationCount 53248 = 90 -encodeIterationCount 55296 = 91 -encodeIterationCount 57344 = 92 -encodeIterationCount 59392 = 93 -encodeIterationCount 61440 = 94 -encodeIterationCount 63488 = 95 -encodeIterationCount 65536 = 96 -encodeIterationCount 69632 = 97 -encodeIterationCount 73728 = 98 -encodeIterationCount 77824 = 99 -encodeIterationCount 81920 = 100 -encodeIterationCount 86016 = 101 -encodeIterationCount 90112 = 102 -encodeIterationCount 94208 = 103 -encodeIterationCount 98304 = 104 -encodeIterationCount 102400 = 105 -encodeIterationCount 106496 = 106 -encodeIterationCount 110592 = 107 -encodeIterationCount 114688 = 108 -encodeIterationCount 118784 = 109 -encodeIterationCount 122880 = 110 -encodeIterationCount 126976 = 111 -encodeIterationCount 131072 = 112 -encodeIterationCount 139264 = 113 -encodeIterationCount 147456 = 114 -encodeIterationCount 155648 = 115 -encodeIterationCount 163840 = 116 -encodeIterationCount 172032 = 117 -encodeIterationCount 180224 = 118 -encodeIterationCount 188416 = 119 -encodeIterationCount 196608 = 120 -encodeIterationCount 204800 = 121 -encodeIterationCount 212992 = 122 -encodeIterationCount 221184 = 123 -encodeIterationCount 229376 = 124 -encodeIterationCount 237568 = 125 -encodeIterationCount 245760 = 126 -encodeIterationCount 253952 = 127 -encodeIterationCount 262144 = 128 -encodeIterationCount 278528 = 129 -encodeIterationCount 294912 = 130 -encodeIterationCount 311296 = 131 -encodeIterationCount 327680 = 132 -encodeIterationCount 344064 = 133 -encodeIterationCount 360448 = 134 -encodeIterationCount 376832 = 135 -encodeIterationCount 393216 = 136 -encodeIterationCount 409600 = 137 -encodeIterationCount 425984 = 138 -encodeIterationCount 442368 = 139 -encodeIterationCount 458752 = 140 -encodeIterationCount 475136 = 141 -encodeIterationCount 491520 = 142 -encodeIterationCount 507904 = 143 -encodeIterationCount 524288 = 144 -encodeIterationCount 557056 = 145 -encodeIterationCount 589824 = 146 -encodeIterationCount 622592 = 147 -encodeIterationCount 655360 = 148 -encodeIterationCount 688128 = 149 -encodeIterationCount 720896 = 150 -encodeIterationCount 753664 = 151 -encodeIterationCount 786432 = 152 -encodeIterationCount 819200 = 153 -encodeIterationCount 851968 = 154 -encodeIterationCount 884736 = 155 -encodeIterationCount 917504 = 156 -encodeIterationCount 950272 = 157 -encodeIterationCount 983040 = 158 -encodeIterationCount 1015808 = 159 -encodeIterationCount 1048576 = 160 -encodeIterationCount 1114112 = 161 -encodeIterationCount 1179648 = 162 -encodeIterationCount 1245184 = 163 -encodeIterationCount 1310720 = 164 -encodeIterationCount 1376256 = 165 -encodeIterationCount 1441792 = 166 -encodeIterationCount 1507328 = 167 -encodeIterationCount 1572864 = 168 -encodeIterationCount 1638400 = 169 -encodeIterationCount 1703936 = 170 -encodeIterationCount 1769472 = 171 -encodeIterationCount 1835008 = 172 -encodeIterationCount 1900544 = 173 -encodeIterationCount 1966080 = 174 -encodeIterationCount 2031616 = 175 -encodeIterationCount 2097152 = 176 -encodeIterationCount 2228224 = 177 -encodeIterationCount 2359296 = 178 -encodeIterationCount 2490368 = 179 -encodeIterationCount 2621440 = 180 -encodeIterationCount 2752512 = 181 -encodeIterationCount 2883584 = 182 -encodeIterationCount 3014656 = 183 -encodeIterationCount 3145728 = 184 -encodeIterationCount 3276800 = 185 -encodeIterationCount 3407872 = 186 -encodeIterationCount 3538944 = 187 -encodeIterationCount 3670016 = 188 -encodeIterationCount 3801088 = 189 -encodeIterationCount 3932160 = 190 -encodeIterationCount 4063232 = 191 -encodeIterationCount 4194304 = 192 -encodeIterationCount 4456448 = 193 -encodeIterationCount 4718592 = 194 -encodeIterationCount 4980736 = 195 -encodeIterationCount 5242880 = 196 -encodeIterationCount 5505024 = 197 -encodeIterationCount 5767168 = 198 -encodeIterationCount 6029312 = 199 -encodeIterationCount 6291456 = 200 -encodeIterationCount 6553600 = 201 -encodeIterationCount 6815744 = 202 -encodeIterationCount 7077888 = 203 -encodeIterationCount 7340032 = 204 -encodeIterationCount 7602176 = 205 -encodeIterationCount 7864320 = 206 -encodeIterationCount 8126464 = 207 -encodeIterationCount 8388608 = 208 -encodeIterationCount 8912896 = 209 -encodeIterationCount 9437184 = 210 -encodeIterationCount 9961472 = 211 -encodeIterationCount 10485760 = 212 -encodeIterationCount 11010048 = 213 -encodeIterationCount 11534336 = 214 -encodeIterationCount 12058624 = 215 -encodeIterationCount 12582912 = 216 -encodeIterationCount 13107200 = 217 -encodeIterationCount 13631488 = 218 -encodeIterationCount 14155776 = 219 -encodeIterationCount 14680064 = 220 -encodeIterationCount 15204352 = 221 -encodeIterationCount 15728640 = 222 -encodeIterationCount 16252928 = 223 -encodeIterationCount 16777216 = 224 -encodeIterationCount 17825792 = 225 -encodeIterationCount 18874368 = 226 -encodeIterationCount 19922944 = 227 -encodeIterationCount 20971520 = 228 -encodeIterationCount 22020096 = 229 -encodeIterationCount 23068672 = 230 -encodeIterationCount 24117248 = 231 -encodeIterationCount 25165824 = 232 -encodeIterationCount 26214400 = 233 -encodeIterationCount 27262976 = 234 -encodeIterationCount 28311552 = 235 -encodeIterationCount 29360128 = 236 -encodeIterationCount 30408704 = 237 -encodeIterationCount 31457280 = 238 -encodeIterationCount 32505856 = 239 -encodeIterationCount 33554432 = 240 -encodeIterationCount 35651584 = 241 -encodeIterationCount 37748736 = 242 -encodeIterationCount 39845888 = 243 -encodeIterationCount 41943040 = 244 -encodeIterationCount 44040192 = 245 -encodeIterationCount 46137344 = 246 -encodeIterationCount 48234496 = 247 -encodeIterationCount 50331648 = 248 -encodeIterationCount 52428800 = 249 -encodeIterationCount 54525952 = 250 -encodeIterationCount 56623104 = 251 -encodeIterationCount 58720256 = 252 -encodeIterationCount 60817408 = 253 -encodeIterationCount 62914560 = 254 -encodeIterationCount 65011712 = 255 -encodeIterationCount n = error ("invalid iteration count" ++ show n) - -getSignaturePayload :: Get SignaturePayload -getSignaturePayload = do - pv <- getWord8 - case pv of - 3 -> do - hashlen <- getWord8 - guard (hashlen == 5) - st <- getWord8 - ctime <- fmap ThirtyTwoBitTimeStamp getWord32be - eok <- getLazyByteString 8 - pka <- get - ha <- get - left16 <- getWord16be - mpib <- getRemainingLazyByteString - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) - Right (_, _, mpis) -> - return $ - SigV3 - (toFVal st) - ctime - (EightOctetKeyId eok) - (toFVal pka) - (toFVal ha) - left16 - (NE.fromList mpis) - 4 -> do - st <- getWord8 - pka <- get - ha <- get - hlen <- getWord16be - hb <- getLazyByteString (fromIntegral hlen) - let hashed = - case runGetOrFail (many getSigSubPacket) hb of - Left (_, _, err) -> fail ("v4 sig hasheds " ++ err) - Right (_, _, h) -> h - ulen <- getWord16be - ub <- getLazyByteString (fromIntegral ulen) - let unhashed = - case runGetOrFail (many getSigSubPacket) ub of - Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) - Right (_, _, u) -> u - left16 <- getWord16be - mpib <- getRemainingLazyByteString - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail ("v4 sig MPIs " ++ e) - Right (_, _, mpis) -> - return $ - SigV4 - (toFVal st) - (toFVal pka) - (toFVal ha) - hashed - unhashed - left16 - (NE.fromList mpis) - _ -> do - bs <- getRemainingLazyByteString - return $ SigVOther pv bs - -putSignaturePayload :: SignaturePayload -> Put -putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do - putWord8 3 - putWord8 5 -- hashlen - put st - putWord32be . unThirtyTwoBitTimeStamp $ ctime - putLazyByteString (unEOKI eok) - put pka - put ha - putWord16be left16 - F.mapM_ put mpis -putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do - putWord8 4 - put st - put pka - put ha - let hb = runPut $ mapM_ put hashed - putWord16be . fromIntegral . BL.length $ hb - putLazyByteString hb - let ub = runPut $ mapM_ put unhashed - putWord16be . fromIntegral . BL.length $ ub - putLazyByteString ub - putWord16be left16 - F.mapM_ put mpis -putSignaturePayload (SigVOther pv bs) = do - putWord8 pv - putLazyByteString bs - -putTK :: TK -> Put -putTK key = do - let pkp = key ^. tkKey . _1 - maybe - (put (PublicKey pkp)) - (\ska -> put (SecretKey pkp ska)) - (snd (key ^. tkKey)) - mapM_ (put . Signature) (_tkRevs key) - mapM_ putUid' (_tkUIDs key) - mapM_ putUat' (_tkUAts key) - mapM_ putSub' (_tkSubs key) - where - putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps - putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps - putSub' (p, sps) = put p >> mapM_ (put . Signature) sps - --- | Parse the packets from a ByteString, with no error reporting -parsePkts :: ByteString -> [Pkt] -parsePkts lbs = - case runGetOrFail (some getPkt) lbs of - Left (_, _, e) -> [] - Right (_, _, p) -> p +-- Serialize.hs: OpenPGP (RFC9580) serialization (using binary) +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} + +module Codec.Encryption.OpenPGP.Serialize + ( + -- * Serialization functions + putPkt + , putPktEither + , putSKAddendum + , getSecretKey + , putSKeyForPKPayload + -- * Utilities + , dearmorIfAsciiArmored + , WireRepInput(..) + , wireRepRefFromInput + , PktParseError(..) + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + , conduitParsePktsWithWireRep + ) where + +import Control.Applicative (many, some) +import Control.Arrow ((***)) +import Control.Lens ((^.), _1) +import Control.Monad (guard, replicateM, replicateM_, when) +import Crypto.Number.Basic (numBits) +import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.DSA as D +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA as R +import Data.Bifunctor (bimap) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( ByteOffset + , Get + , bytesRead + , getByteString + , getLazyByteString + , getRemainingLazyByteString + , getWord16be + , getWord16le + , getWord32be + , getWord8 + , lookAhead + , runGetOrFail + ) +import Data.Binary.Put + ( Put + , putByteString + , putLazyByteString + , putWord16be + , putWord16le + , putWord32be + , putWord8 + , runPut + ) +import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import qualified Data.Foldable as F +import Data.Int (Int64) +import Data.List (mapAccumL) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Word (Word16, Word32, Word8) +import Network.URI (nullURI, parseURI, uriToString) + +import Codec.Encryption.OpenPGP.Internal + ( curve2Curve + , curveFromCurve + , curveToCurveoidBS + , curveoidBSToCurve + , curveoidBSToEdSigningCurve + , edSigningCurveToCurveoidBS + , leftPadTo + , pubkeyToMPIs + ) +import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..)) +import Data.Conduit (ConduitT, await, yield) +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes +import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P + +instance Binary SigSubPacket where + get = getSigSubPacket + put = putSigSubPacket + +-- instance Binary (Set NotationFlag) where +-- put = putNotationFlagSet +instance Binary CompressionAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary PubKeyAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary HashAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary SymmetricAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary MPI where + get = getMPI + put = putMPI + +instance Binary SigType where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary UserAttrSubPacket where + get = getUserAttrSubPacket + put = putUserAttrSubPacket + +instance Binary S2K where + get = getS2K + put = putS2K + +instance Binary (PKESK 'PKESKV3) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (PKESK 'PKESKV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Signature where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (SKESK 'SKESKV4) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (SKESK 'SKESKV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (OnePassSignature 'OPSV3) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (OnePassSignature 'OPSV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SecretKey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary PublicKey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SecretSubkey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary CompressedData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SymEncData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Marker where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary LiteralData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Trust where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary UserId where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary PublicSubkey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary UserAttribute where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SymEncIntegrityProtectedData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary ModificationDetectionCode where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary OtherPacket where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Pkt where + get = getPkt + put = putPkt + +instance Binary a => Binary (Block a) where + get = Block `fmap` many get + put = mapM_ put . unBlock + +instance Binary SomePKPayload where + get = getPKPayload + put = putPKPayload + +instance Binary SignaturePayload where + get = getSignaturePayload + put = putSignaturePayload + +instance Binary TKUnknown where + get = fail "Binary TKUnknown decode is not implemented" + put = putTK + +getSigSubPacket :: Get SigSubPacket +getSigSubPacket = do + l <- fmap fromIntegral getSubPacketLength + (crit, pt) <- getSigSubPacketType + getSigSubPacket' pt crit l + where + getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket + getSigSubPacket' pt crit l + | pt == 2 = do + et <- fmap ThirtyTwoBitTimeStamp getWord32be + return $ SigSubPacket crit (SigCreationTime et) + | pt == 3 = do + et <- fmap ThirtyTwoBitDuration getWord32be + return $ SigSubPacket crit (SigExpirationTime et) + | pt == 4 = do + e <- get + return $ SigSubPacket crit (ExportableCertification e) + | pt == 5 = do + tl <- getWord8 + ta <- getWord8 + return $ SigSubPacket crit (TrustSignature tl ta) + | pt == 6 = do + apdre <- getLazyByteString (l - 2) + nul <- getWord8 + guard (nul == 0) + return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) + | pt == 7 = do + r <- get + return $ SigSubPacket crit (Revocable r) + | pt == 9 = do + et <- fmap ThirtyTwoBitDuration getWord32be + return $ SigSubPacket crit (KeyExpirationTime et) + | pt == 11 = do + sa <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) + | pt == 12 = do + rclass <- getWord8 + guard (testBit rclass 7) + algid <- get + fp <- getLazyByteString (fromIntegral l - 3) + return $ + SigSubPacket + crit + (RevocationKey + (bsToFFSet . BL.singleton $ rclass .&. 0x7f) + algid + (Fingerprint fp)) + | pt == 16 = do + keyid <- getLazyByteString (l - 1) + return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) + | pt == 20 = do + flags <- getLazyByteString 4 + nl <- getWord16be + vl <- getWord16be + nn <- getLazyByteString (fromIntegral nl) + nv <- getLazyByteString (fromIntegral vl) + return $ + SigSubPacket + crit + (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv)) + | pt == 21 = do + ha <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredHashAlgorithms ha) + | pt == 22 = do + ca <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) + | pt == 23 = do + ksps <- getLazyByteString (l - 1) + return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) + | pt == 24 = do + pks <- getLazyByteString (l - 1) + return $ SigSubPacket crit (PreferredKeyServer pks) + | pt == 25 = do + primacy <- get + return $ SigSubPacket crit (PrimaryUserId primacy) + | pt == 26 = do + url <- + fmap + (URL . fromMaybe nullURI . parseURI . T.unpack . + decodeUtf8With lenientDecode) + (getByteString (fromIntegral (l - 1))) + return $ SigSubPacket crit (PolicyURL url) + | pt == 27 = do + kfs <- getLazyByteString (l - 1) + return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) + | pt == 28 = do + uid <- getByteString (fromIntegral (l - 1)) + return $ + SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid)) + | pt == 29 = do + rcode <- getWord8 + rreason <- + fmap + (decodeUtf8With lenientDecode) + (getByteString (fromIntegral (l - 2))) + return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) + | pt == 30 = do + fbs <- getLazyByteString (l - 1) + return $ SigSubPacket crit (Features (bsToFFSet fbs)) + | pt == 31 = do + pka <- get + ha <- get + hash <- getLazyByteString (l - 3) + return $ SigSubPacket crit (SignatureTarget pka ha hash) + | pt == 32 = do + spbs <- getLazyByteString (l - 1) + case runGetOrFail get spbs of + Left (_, _, e) -> fail ("embedded signature subpacket " ++ e) + Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp) + | pt == 33 = do + when (l /= 22 && l /= 34) $ + fail ("invalid issuer fingerprint subpacket length: " ++ show l) + kv <- getWord8 + let fpLen = l - 2 + when (fpLen /= 20 && fpLen /= 32) $ + fail ("invalid issuer fingerprint length: " ++ show fpLen) + case BTypes.packetVersionToIssuerFingerprintVersion kv of + Nothing -> + fail ("invalid issuer fingerprint version marker: " ++ show kv) + Just ifVersion -> do + fp <- + case kv of + 4 -> getLazyByteString (fromIntegral fpLen) + 6 -> getLazyByteString (fromIntegral fpLen) + _ -> fail ("invalid issuer fingerprint version marker: " ++ show kv) + return $ + SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp)) + | pt > 99 && pt < 111 = do + payload <- getLazyByteString (l - 1) + return $ SigSubPacket crit (UserDefinedSigSub pt payload) + | otherwise = do + payload <- getLazyByteString (l - 1) + return $ SigSubPacket crit (OtherSigSub pt payload) + +putSigSubPacket :: SigSubPacket -> Put +putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 2 + putWord32be . unThirtyTwoBitTimeStamp $ et +putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 3 + putWord32be . unThirtyTwoBitDuration $ et +putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do + putSubPacketLength 2 + putSigSubPacketType crit 4 + put e +putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do + putSubPacketLength 3 + putSigSubPacketType crit 5 + put tl + put ta +putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do + putSubPacketLength . fromIntegral $ (2 + BL.length apdre) + putSigSubPacketType crit 6 + putLazyByteString apdre + putWord8 0 +putSigSubPacket (SigSubPacket crit (Revocable r)) = do + putSubPacketLength 2 + putSigSubPacketType crit 7 + put r +putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 9 + putWord32be . unThirtyTwoBitDuration $ et +putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do + putSubPacketLength . fromIntegral $ (1 + length ess) + putSigSubPacketType crit 11 + mapM_ put ess +putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do + let fpLen = BL.length (unFingerprint fp) + putSubPacketLength (fromIntegral (3 + fpLen)) -- type(1) + rclass(1) + algid(1) + fingerprint + putSigSubPacketType crit 12 + putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ + Set.insert (RClOther 0) rclass + put algid + putLazyByteString (unFingerprint fp) +putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do + putSubPacketLength 9 + putSigSubPacketType crit 16 + putLazyByteString (unEOKI keyid) -- 8 octets +putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do + putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) + putSigSubPacketType crit 20 + putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs + putWord16be . fromIntegral . BL.length $ nn + putWord16be . fromIntegral . BL.length $ nv + putLazyByteString nn + putLazyByteString nv +putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do + putSubPacketLength . fromIntegral $ (1 + length ehs) + putSigSubPacketType crit 21 + mapM_ put ehs +putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do + putSubPacketLength . fromIntegral $ (1 + length ecs) + putSigSubPacketType crit 22 + mapM_ put ecs +putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do + let kbs = ffSetToBS ksps + putSubPacketLength . fromIntegral $ (1 + BL.length kbs) + putSigSubPacketType crit 23 + putLazyByteString kbs +putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do + putSubPacketLength . fromIntegral $ (1 + BL.length ks) + putSigSubPacketType crit 24 + putLazyByteString ks +putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do + putSubPacketLength 2 + putSigSubPacketType crit 25 + put primacy +putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do + let bs = encodeUtf8 (T.pack (uriToString id uri "")) + putSubPacketLength . fromIntegral $ (1 + B.length bs) + putSigSubPacketType crit 26 + putByteString bs +putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do + let kbs = ffSetToBS kfs + putSubPacketLength . fromIntegral $ (1 + BL.length kbs) + putSigSubPacketType crit 27 + putLazyByteString kbs +putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do + let bs = encodeUtf8 userid + putSubPacketLength . fromIntegral $ (1 + B.length bs) + putSigSubPacketType crit 28 + putByteString bs +putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do + let reasonbs = encodeUtf8 rreason + putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) + putSigSubPacketType crit 29 + putWord8 . fromFVal $ rcode + putByteString reasonbs +putSigSubPacket (SigSubPacket crit (Features fs)) = do + let fbs = ffSetToBS fs + putSubPacketLength . fromIntegral $ (1 + BL.length fbs) + putSigSubPacketType crit 30 + putLazyByteString fbs +putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do + putSubPacketLength . fromIntegral $ (3 + BL.length hash) + putSigSubPacketType crit 31 + put pka + put ha + putLazyByteString hash +putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do + let spb = runPut (put sp) + putSubPacketLength . fromIntegral $ (1 + BL.length spb) + putSigSubPacketType crit 32 + putLazyByteString spb +putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do + let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv + let fpb = unFingerprint fp + when (BL.length fpb /= 20 && BL.length fpb /= 32) $ + error ("invalid issuer fingerprint length: " ++ show (BL.length fpb)) + putSubPacketLength . fromIntegral $ (2 + BL.length fpb) + putSigSubPacketType crit 33 + putWord8 kv' + putLazyByteString fpb +putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = + putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) +putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do + putSubPacketLength . fromIntegral $ (1 + BL.length payload) + putSigSubPacketType crit ptype + putLazyByteString payload + +getSubPacketLength :: Get Word32 +getSubPacketLength = getSubPacketLength' =<< getWord8 + where + getSubPacketLength' :: Integral a => Word8 -> Get a + getSubPacketLength' f + | f < 192 = return . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f == 255 = do + len <- getWord32be + return . fromIntegral $ len + | otherwise = fail "Partial body length invalid." + +putSubPacketLength :: Word32 -> Put +putSubPacketLength l + | l < 192 = putWord8 (fromIntegral l) + | l < 8384 = + putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> + putWord8 (fromIntegral (l - 192) .&. 0xff) + | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l) + | otherwise = error ("too big (" ++ show l ++ ")") + +getSigSubPacketType :: Get (Bool, Word8) +getSigSubPacketType = do + x <- getWord8 + return + (if x .&. 128 == 128 + then (True, x .&. 127) + else (False, x)) + +putSigSubPacketType :: Bool -> Word8 -> Put +putSigSubPacketType False sst = putWord8 sst +putSigSubPacketType True sst = putWord8 (sst .|. 0x80) + +bsToFFSet :: FutureFlag a => ByteString -> Set a +bsToFFSet bs = + Set.fromAscList . concat . snd $ + mapAccumL + (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7])) + 0 + (BL.unpack bs) + where + shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] + +ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString +ffSetToFixedLengthBS len ffs = + BL.take + (fromIntegral len) + (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) + +ffSetToBS :: FutureFlag a => Set a -> ByteString +ffSetToBS = BL.pack . ffSetToBS' + where + ffSetToBS' :: FutureFlag a => Set a -> [Word8] + ffSetToBS' ks + -- Emit a single zero octet for an empty flag set so encoded flag + -- subpackets always carry an explicit flags byte. + | Set.null ks = [0] + | otherwise = + map + ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . + Set.toAscList) . + (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)) + [0 .. fromFFlag (Set.findMax ks) `div` 8] + +fromS2K :: S2K -> ByteString +fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] +fromS2K (Salted hashalgo salt) = + BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append` + (BL.fromStrict . unSalt8) salt +fromS2K (IteratedSalted hashalgo salt count) = + BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append` + (BL.fromStrict . unSalt8) salt `BL.snoc` + encodeIterationCount count +fromS2K (Argon2 salt t p encodedM) = + BL.pack [4] `BL.append` (BL.fromStrict . unSalt16) salt `BL.append` + BL.pack [t, p, encodedM] +fromS2K (OtherS2K _ bs) = bs + +getPacketLength :: Get Integer +getPacketLength = do + firstOctet <- getWord8 + lenOrPartial <- lengthOctetToLength firstOctet + case lenOrPartial of + Left _ -> + fail "Partial body length is invalid in this context" + Right len -> return len + where + lengthOctetToLength :: Word8 -> Get (Either Integer Integer) + lengthOctetToLength f + | f < 192 = return . Right . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . Right . fromIntegral $ + shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f < 255 = + return . Left . fromIntegral $ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) + | otherwise = do + len <- getWord32be + return . Right . fromIntegral $ len + +putPacketLength :: Integer -> Put +putPacketLength l + | l < 192 = putWord8 (fromIntegral l) + | l < 8384 = + putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> + putWord8 (fromIntegral (l - 192) .&. 0xff) + | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l) + | otherwise = error "packet length exceeds 32-bit definite length encoding" + +putPartialLength :: Word8 -> Put +putPartialLength n = putWord8 (224 + n) + +getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64) +getPacketLengthFromOctet f + | f < 192 = return . Right . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . Right . fromIntegral $ + shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f < 255 = + return . Left . fromIntegral $ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) + | otherwise = do + len <- getWord32be + return . Right . fromIntegral $ len + +getS2K :: Get S2K +getS2K = getS2K' =<< getWord8 + where + getS2K' :: Word8 -> Get S2K + getS2K' t + | t == 0 = do + ha <- getWord8 + return $ Simple (toFVal ha) + | t == 1 = do + ha <- getWord8 + salt <- getByteString 8 + return $ Salted (toFVal ha) (Salt8 salt) + | t == 3 = do + ha <- getWord8 + salt <- getByteString 8 + count <- getWord8 + return $ + IteratedSalted (toFVal ha) (Salt8 salt) (decodeIterationCount count) + | t == 4 = do + salt <- getByteString 16 + passes <- getWord8 + parallelism <- getWord8 + encodedM <- getWord8 + return $ Argon2 (Salt16 salt) passes parallelism encodedM + | otherwise = do + bs <- getRemainingLazyByteString + return $ OtherS2K t bs + +putS2K :: S2K -> Put +putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) +putS2K (Salted hashalgo salt) = + error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt) +putS2K (IteratedSalted ha salt count) = do + putWord8 3 + put ha + putByteString (unSalt8 salt) + putWord8 $ encodeIterationCount count +putS2K (Argon2 salt t p encodedM) = do + putWord8 4 + putByteString (unSalt16 salt) + putWord8 t + putWord8 p + putWord8 encodedM +putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs + +v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 +v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm + +getPacketTypeAndPayload :: Get (Word8, ByteString) +getPacketTypeAndPayload = do + tag <- getWord8 + guard (testBit tag 7) + case tag .&. 0x40 of + 0x00 -> do + let t = shiftR (tag .&. 0x3c) 2 + case tag .&. 0x03 of + 0 -> do + len <- getWord8 + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 1 -> do + len <- getWord16be + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 2 -> do + len <- getWord32be + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 3 -> do + bs <- getRemainingLazyByteString + return (t, bs) + _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." + 0x40 -> do + firstLenOctet <- getWord8 + bs <- getPacketPayloadFromLengthOctet firstLenOctet + return (tag .&. 0x3f, bs) + _ -> error "This should never happen (getPacketTypeAndPayload/???)." + where + getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString + getPacketPayloadFromLengthOctet lenOctet = do + lenOrPartial <- getPacketLengthFromOctet lenOctet + case lenOrPartial of + Right len -> getLazyByteString len + Left partialLen -> do + chunk <- getLazyByteString partialLen + rest <- getRemainingPartialPayload + return (chunk <> rest) + getRemainingPartialPayload :: Get ByteString + getRemainingPartialPayload = do + lenOctet <- getWord8 + lenOrPartial <- getPacketLengthFromOctet lenOctet + case lenOrPartial of + Right len -> getLazyByteString len + Left partialLen -> do + chunk <- getLazyByteString partialLen + (chunk <>) <$> getRemainingPartialPayload + +getPkt :: Get Pkt +getPkt = do + (t, pl) <- getPacketTypeAndPayload + case runGetOrFail (getPkt' t (BL.length pl)) pl of + Left (_, _, e) -> return $! BrokenPacketPkt e t pl + Right (_, _, p) -> return p + where + parseLegacyPKESK :: PacketVersion -> BL.ByteString -> Either String Pkt + parseLegacyPKESK pv body = do + (_, _, (eokeyid, pkaRaw, mpib)) <- + bimap (\(_, _, e) -> e) id $ + runGetOrFail + (do eokeyid <- getLazyByteString 8 + pka <- getWord8 + mpib <- getRemainingLazyByteString + pure (eokeyid, pka, mpib)) + body + let pka = toFVal pkaRaw + sk <- parseLegacyPKESKMPIs pka mpib + pure $ + PKESKPkt + (PKESKPayloadV3Packet (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)) + + parseLegacyPKESKMPIs :: PubKeyAlgorithm -> BL.ByteString -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKMPIs pka mpib = do + case parseLegacyPKESKMPIsStrict pka mpib of + Right sk -> pure sk + Left strictErr + | pka == X25519 -> + case parseLegacyPKESKX25519V3Octets mpib of + Right sk -> Right sk + Left octetErr -> + Left + (strictErr ++ + "; also failed to parse RFC9580 X25519 v3 octet layout: " ++ + octetErr) + | pka == ECDH -> + case parseLegacyPKESKECDHOctets mpib of + Right sk -> Right sk + Left octetErr -> + Left + (strictErr ++ + "; also failed to parse RFC6637 ECDH v3 octet layout: " ++ + octetErr) + | otherwise -> Left strictErr + + parseLegacyPKESKMPIsStrict :: + PubKeyAlgorithm -> BL.ByteString -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKMPIsStrict pka mpib = do + (rest, _, sk) <- + bimap (\(_, _, e) -> 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) + + parseLegacyPKESKX25519V3Octets :: BL.ByteString -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKX25519V3Octets mpib = do + if BL.length mpib < 33 + then Left "X25519 v3 PKESK octet layout is too short" + 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" + else Right () + if B.null eskWithAlgo + then Left "X25519 v3 PKESK octet layout must include a symmetric algorithm octet" + else Right () + let symAlgo = B.head eskWithAlgo + if symAlgo `elem` [fromIntegral (fromFVal AES128), fromIntegral (fromFVal AES192), fromIntegral (fromFVal AES256)] + then pure (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)]) + else + Left + ("X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet " ++ + show 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) + parseLegacyPKESKECDHOctets mpib = do + (rest, _, ephMPI) <- + bimap (\(_, _, e) -> 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" + 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)) + 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") + pure (ephMPI NE.:| [MPI (os2ip wrapped)]) + + parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI] + parserForLegacyPKESKMPIs pka = + case expectedLegacyPKESKMPIArity pka of + Just mpiCount -> replicateM mpiCount getMPI + Nothing -> some getMPI + + expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int + expectedLegacyPKESKMPIArity pka + | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1 + | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] = Just 2 + | otherwise = Nothing + + validateV4SKESKEncryptedSessionKeyS2K :: S2K -> Maybe BL.ByteString -> Get () + validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure () + validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) = + fail + "v4 SKESK packets with encrypted session keys must not use Simple S2K" + validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure () + + parseV6PKESK :: BL.ByteString -> Either String Pkt + parseV6PKESK body = do + (_, _, (recipientKeyIdentifier, pka, esk)) <- + bimap (\(_, _, e) -> e) id $ + runGetOrFail + (do keyIdentifierLen <- getWord8 + recipientKeyIdentifier <- getLazyByteString (fromIntegral keyIdentifierLen) + pka <- getWord8 + esk <- getRemainingLazyByteString + pure (recipientKeyIdentifier, pka, esk)) + body + validateV6PKESKRecipientIdentifier recipientKeyIdentifier + pure $ + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) 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 + | t == 1 = do + pv <- getWord8 + body <- getRemainingLazyByteString + if pv == 6 + then case parseV6PKESK body of + Right pkt -> return pkt + Left v6Err -> fail ("PKESK v6 parse failed: " ++ v6Err) + else case parseLegacyPKESK pv body of + Right pkt -> return pkt + Left legacyErr -> fail ("PKESK MPIs " ++ legacyErr) + | t == 2 = do + bs <- getRemainingLazyByteString + case runGetOrFail get bs of + Left (_, _, e) -> fail ("signature packet " ++ e) + Right (_, _, sp) -> return $ SignaturePkt sp + | t == 3 = do + pv <- getWord8 + let getV6SKESKParams = do + symalgoWord <- getWord8 + aeadWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing bytes in v6 SKESK S2K specifier" + | otherwise -> pure parsed + let symalgo = toFVal symalgoWord + aead = toFVal aeadWord + ivLen = fromIntegral (aeadNonceSize aead) + iv <- getLazyByteString ivLen + pure (symalgo, aead, s2k, iv) + case pv of + 6 -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symalgo, aead, s2k, iv) <- + case runGetOrFail getV6SKESKParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing v6 SKESK parameters" + | otherwise -> pure parsed + payload <- getRemainingLazyByteString + when (BL.length payload < 16) $ + fail "v6 SKESK payload must include encrypted session key and authentication tag" + let (esk, tag) = BL.splitAt (BL.length payload - 16) payload + return $ + SKESKPkt + (SKESKPayloadV6Packet + (SKESKPayloadV6 + symalgo + aead + s2k + iv + esk + tag)) + 4 -> do + symalgo <- getWord8 + s2k <- getS2K + esk <- getRemainingLazyByteString + let mesk = if BL.null esk then Nothing else Just esk + validateV4SKESKEncryptedSessionKeyS2K s2k mesk + return $ + SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 + (toFVal symalgo) + s2k + mesk)) + _ -> fail ("unsupported SKESK packet version " ++ show pv) + | t == 4 = do + pv <- getWord8 + sigtype <- toFVal <$> getWord8 + ha <- toFVal <$> getWord8 + pka <- toFVal <$> getWord8 + case pv of + 3 -> do + skeyid <- getLazyByteString 8 + nested <- getWord8 >>= parseOPSNestedFlag + return $ + OnePassSignaturePkt + (OPSPayloadV3Packet + (OPSPayloadV3 + pv + sigtype + ha + pka + (EightOctetKeyId skeyid) + nested)) + 6 -> do + saltSize <- getWord8 + expectedSaltSize <- + maybe + (fail ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) + pure + (v6SaltSizeForHashAlgorithm ha) + when (saltSize /= expectedSaltSize) $ + fail + ("OPS v6 salt size mismatch for " ++ + show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) + salt <- SignatureSalt <$> getLazyByteString (fromIntegral saltSize) + signerFingerprint <- getLazyByteString 32 + nested <- getWord8 >>= parseOPSNestedFlag + return $ + OnePassSignaturePkt + (OPSPayloadV6Packet + (OPSPayloadV6 + sigtype + ha + pka + salt + signerFingerprint + nested)) + _ -> fail ("Unsupported OPS version: " ++ show pv) + | t == 5 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + ska <- getSKAddendum pkp + return $ SecretKeyPkt pkp ska + case ps of + Left (_, _, err) -> fail ("secret key " ++ err) + Right (_, _, pkt) -> return pkt + | t == 6 = do + pkp <- getPKPayload + return $ PublicKeyPkt pkp + | t == 7 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + ska <- getSKAddendum pkp + return $ SecretSubkeyPkt pkp ska + case ps of + Left (_, _, err) -> fail ("secret subkey " ++ err) + Right (_, _, pkt) -> return pkt + | t == 8 = do + ca <- getWord8 + cdata <- getLazyByteString (len - 1) + return $ CompressedDataPkt (toFVal ca) cdata + | t == 9 = do + sdata <- getLazyByteString len + return $ SymEncDataPkt sdata + | t == 10 = do + marker <- getLazyByteString len + return $ MarkerPkt marker + | t == 11 = do + dt <- getWord8 + flen <- getWord8 + fn <- getLazyByteString (fromIntegral flen) + ts <- fmap ThirtyTwoBitTimeStamp getWord32be + ldata <- getLazyByteString (len - (6 + fromIntegral flen)) + return $ LiteralDataPkt (toFVal dt) fn ts ldata + | t == 12 = do + tdata <- getLazyByteString len + return $ TrustPkt tdata + | t == 13 = do + udata <- getByteString (fromIntegral len) + return . UserIdPkt . decodeUtf8With lenientDecode $ udata + | t == 14 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + return $ PublicSubkeyPkt pkp + case ps of + Left (_, _, err) -> fail ("public subkey " ++ err) + Right (_, _, pkt) -> return pkt + | t == 17 = do + bs <- getLazyByteString len + case runGetOrFail (many getUserAttrSubPacket) bs of + Left (_, _, err) -> fail ("user attribute " ++ err) + Right (_, _, uas) -> return $ UserAttributePkt uas + | t == 18 = do + pv <- getWord8 + case pv of + 1 -> do + b <- getLazyByteString (len - 1) + return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b) + 2 -> do + when (len < 36) $ + fail "SEIPD v2 packet too short" + symalgo <- toFVal <$> getWord8 + aeadalgo <- toFVal <$> getWord8 + chunkSize <- getWord8 + salt <- Salt <$> getByteString 32 + encrypted <- getLazyByteString (len - 36) + validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted + return $ + SymEncIntegrityProtectedDataPkt + (SEIPD2 + symalgo + aeadalgo + chunkSize + salt + encrypted) + _ -> fail ("Unsupported SEIPD version: " ++ show pv) + | t == 19 = do + hash <- getLazyByteString 20 + return $ ModificationDetectionCodePkt hash + | otherwise = do + payload <- getLazyByteString len + return $ OtherPacketPkt t payload + +getUserAttrSubPacket :: Get UserAttrSubPacket +getUserAttrSubPacket = do + l <- fmap fromIntegral getSubPacketLength + t <- getWord8 + getUserAttrSubPacket' t l + where + getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket + getUserAttrSubPacket' t l + | t == 1 = do + _ <- getWord16le -- ihlen + hver <- getWord8 -- should be 1 + iformat <- getWord8 + nuls <- getLazyByteString 12 -- should be NULs + bs <- getLazyByteString (l - 17) + if hver /= 1 || nuls /= BL.pack (replicate 12 0) + then fail "Corrupt UAt subpacket" + else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs + | otherwise = do + bs <- getLazyByteString (l - 1) + return $ OtherUASub t bs + +putUserAttrSubPacket :: UserAttrSubPacket -> Put +putUserAttrSubPacket ua = do + let sp = runPut $ putUserAttrSubPacket' ua + putSubPacketLength . fromIntegral . BL.length $ sp + putLazyByteString sp + where + putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do + putWord8 1 + putWord16le 16 + putWord8 1 + putWord8 (fromFVal iformat) + replicateM_ 12 $ putWord8 0 + putLazyByteString idata + putUserAttrSubPacket' (OtherUASub t bs) = do + putWord8 t + putLazyByteString bs + +-- | Serialize PKESKv3 session-key material. +-- For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used: +-- MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes. +-- All other algorithms use the standard MPI sequence. +putPKESKv3SessionKeyMaterial :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put +putPKESKv3SessionKeyMaterial pka mpis + | pka `elem` [ECDH, X25519] + , (ephMPI NE.:| [wrappedMPI]) <- mpis = do + put ephMPI + let rawWrapped = i2osp (unMPI wrappedMPI) + -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that + -- leading-zero bytes stripped by i2osp are restored. + targetLen = headDef (B.length rawWrapped) (filter (>= B.length rawWrapped) [32, 40, 48]) + paddedWrapped = leftPadTo targetLen rawWrapped + putWord8 (fromIntegral (B.length paddedWrapped)) + putByteString paddedWrapped + | otherwise = F.mapM_ put mpis + where + headDef d [] = d + headDef _ (x:_) = x + +putPkt :: Pkt -> Put +putPkt (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eokeyid pka mpis))) = do + putWord8 (0xc0 .|. 1) + let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis + putPacketLength . fromIntegral $ 10 + BL.length bsk + putWord8 pv -- must be 3 + putLazyByteString (unEOKI eokeyid) -- must be 8 octets + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString bsk +putPkt (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = do + putWord8 (0xc0 .|. 1) + let keyIdentifierLen = BL.length recipientKeyIdentifier + when (keyIdentifierLen > 255) $ + error "PKESK v6 recipient key identifier must fit in one octet" + putPacketLength . fromIntegral $ 3 + keyIdentifierLen + BL.length esk + putWord8 6 + putWord8 (fromIntegral keyIdentifierLen) + putLazyByteString recipientKeyIdentifier + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString esk +putPkt (SignaturePkt sp) = do + putWord8 (0xc0 .|. 2) + let bs = runPut $ put sp + putLengthThenPayload bs +putPkt (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k mesk))) = do + putWord8 (0xc0 .|. 3) + let bs2k = fromS2K s2k + let bsk = fromMaybe BL.empty mesk + putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk + putWord8 4 + putWord8 $ fromIntegral . fromFVal $ symalgo + putLazyByteString bs2k + putLazyByteString bsk +putPkt (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag))) = do + putWord8 (0xc0 .|. 3) + let bs2k = fromS2K s2k + let params = + BL.pack + [ fromIntegral (fromFVal symalgo) + , fromIntegral (fromFVal aead) + , fromIntegral (BL.length bs2k) + ] <> + bs2k <> iv + putPacketLength . fromIntegral $ 2 + BL.length params + BL.length esk + BL.length tag + putWord8 6 + putWord8 (fromIntegral (BL.length params)) + putLazyByteString params + putLazyByteString esk + putLazyByteString tag +putPkt (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv sigtype ha pka skeyid nested))) = do + putWord8 (0xc0 .|. 4) + let bs = + runPut $ do + putWord8 pv -- should be 3 + putWord8 $ fromIntegral . fromFVal $ sigtype + putWord8 $ fromIntegral . fromFVal $ ha + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString (unEOKI skeyid) + putWord8 . fromIntegral . fromEnum $ not nested + putLengthThenPayload bs +putPkt (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested))) = do + putWord8 (0xc0 .|. 4) + let saltBytes = unSignatureSalt salt + saltSize = BL.length saltBytes + expectedSaltSize = + maybe + (error ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) + id + (v6SaltSizeForHashAlgorithm ha) + when (fromIntegral saltSize /= expectedSaltSize) $ + error + ("OPS v6 salt size mismatch for " ++ + show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) + when (BL.length signerFingerprint /= 32) $ + error "OPS v6 signer fingerprint must be exactly 32 octets" + let bs = + runPut $ do + putWord8 6 + putWord8 $ fromIntegral . fromFVal $ sigtype + putWord8 $ fromIntegral . fromFVal $ ha + putWord8 $ fromIntegral . fromFVal $ pka + putWord8 (fromIntegral saltSize) + putLazyByteString saltBytes + putLazyByteString signerFingerprint + putWord8 . fromIntegral . fromEnum $ not nested + putLengthThenPayload bs +putPkt (SecretKeyPkt pkp ska) = do + putWord8 (0xc0 .|. 5) + let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) + putLengthThenPayload bs +putPkt (PublicKeyPkt pkp) = do + putWord8 (0xc0 .|. 6) + let bs = runPut $ putPKPayload pkp + putLengthThenPayload bs +putPkt (SecretSubkeyPkt pkp ska) = do + putWord8 (0xc0 .|. 7) + let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) + putLengthThenPayload bs +putPkt (CompressedDataPkt ca cdata) = do + putWord8 (0xc0 .|. 8) + let bs = + runPut $ do + putWord8 $ fromIntegral . fromFVal $ ca + putLazyByteString cdata + putLengthThenPayload bs +putPkt (SymEncDataPkt b) = do + putWord8 (0xc0 .|. 9) + putLengthThenPayload b +putPkt (MarkerPkt b) = do + putWord8 (0xc0 .|. 10) + putLengthThenPayload b +putPkt (LiteralDataPkt dt fn ts b) = do + putWord8 (0xc0 .|. 11) + let bs = + runPut $ do + putWord8 $ fromIntegral . fromFVal $ dt + putWord8 $ fromIntegral . BL.length $ fn + putLazyByteString fn + putWord32be . unThirtyTwoBitTimeStamp $ ts + putLazyByteString b + putLengthThenPayload bs +putPkt (TrustPkt b) = do + putWord8 (0xc0 .|. 12) + putLengthThenPayload b +putPkt (UserIdPkt u) = do + putWord8 (0xc0 .|. 13) + let bs = encodeUtf8 u + putPacketLength . fromIntegral $ B.length bs + putByteString bs +putPkt (PublicSubkeyPkt pkp) = do + putWord8 (0xc0 .|. 14) + let bs = runPut $ putPKPayload pkp + putLengthThenPayload bs +putPkt (UserAttributePkt us) = do + putWord8 (0xc0 .|. 17) + let bs = runPut $ mapM_ put us + putLengthThenPayload bs +putPkt (SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)) = do + putWord8 (0xc0 .|. 18) + putPacketLength . fromIntegral $ BL.length b + 1 + putWord8 pv -- should be 1 + putLazyByteString b +putPkt (SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aeadalgo chunkSize salt b)) = do + when (B.length (unSalt salt) /= 32) $ + error "SEIPD v2 salt must be exactly 32 octets" + when (chunkSize > 16) $ + error "SEIPD v2 chunk size octet must be between 0 and 16" + case symalgo of + OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> error "SEIPD v2 cannot use plaintext cipher" + _ -> return () + case aeadalgo of + OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm" + _ -> return () + putWord8 (0xc0 .|. 18) + putPacketLength . fromIntegral $ BL.length b + 36 + putWord8 2 + putWord8 (fromFVal symalgo) + putWord8 (fromFVal aeadalgo) + putWord8 chunkSize + putByteString (unSalt salt) + putLazyByteString b +putPkt (ModificationDetectionCodePkt hash) = do + putWord8 (0xc0 .|. 19) + putLengthThenPayload hash +putPkt (OtherPacketPkt t payload) = do + when (t > 63) $ + error ("cannot serialize OtherPacket packet tag > 63: " ++ show t) + putWord8 (0xc0 .|. t) + putLengthThenPayload payload +putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) + +-- | Validate a packet before serialization to catch constraint violations early. +-- Returns Left with descriptive error if validation fails. +validatePkt :: Pkt -> Either String () +validatePkt (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))) = do + let keyIdentifierLen = BL.length recipientKeyIdentifier + when (keyIdentifierLen > 255) $ + Left "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)" + Right () +validatePkt (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _))) = do + let saltBytes = unSignatureSalt salt + saltSize = BL.length saltBytes + expectedSaltSize <- + case v6SaltSizeForHashAlgorithm ha of + Nothing -> Left $ "signature hash algorithm does not define a V6 salt size: " ++ show ha + Just sz -> Right sz + when (fromIntegral saltSize /= expectedSaltSize) $ + Left + ("OPS v6 salt size mismatch for " ++ + show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) + when (BL.length signerFingerprint /= 32) $ + Left "OPS v6 signer fingerprint must be exactly 32 octets" + Right () +validatePkt (SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aeadalgo chunkSize salt _)) = do + when (B.length (unSalt salt) /= 32) $ + Left "SEIPD v2 salt must be exactly 32 octets" + when (chunkSize > 16) $ + Left "SEIPD v2 chunk size octet must be between 0 and 16" + case symalgo of + OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> Left "SEIPD v2 cannot use plaintext cipher" + _ -> Right () + case aeadalgo of + OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm" + _ -> Right () +validatePkt (OtherPacketPkt t _) = do + when (t > 63) $ + Left ("cannot serialize OtherPacket packet tag > 63: " ++ show 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 = case validatePkt pkt of + Left err -> Left err + Right () -> Right (putPkt pkt) + +putLengthThenPayload :: ByteString -> Put +putLengthThenPayload bs = do + let len = BL.length bs + if len < fromIntegral (0x100000000 :: Integer) + then do + putPacketLength (fromIntegral len) + putLazyByteString bs + else putPartialLengthPayload bs + where + maxPartialChunkSize :: Int64 + maxPartialChunkSize = 1 `shiftL` (30 :: Int) + putPartialLengthPayload :: ByteString -> Put + putPartialLengthPayload payload + | BL.length payload > maxPartialChunkSize = do + let (chunk, rest) = BL.splitAt maxPartialChunkSize payload + putPartialLength 30 + putLazyByteString chunk + putPartialLengthPayload rest + | otherwise = do + putPacketLength (fromIntegral (BL.length payload)) + putLazyByteString payload + +validateSEIPDv2Header :: + SymmetricAlgorithm -> AEADAlgorithm -> Word8 -> ByteString -> Get () +validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do + when (chunkSize > 16) $ + fail "SEIPD v2 chunk size octet must be between 0 and 16" + when (BL.null encrypted) $ + fail "SEIPD v2 payload is missing encrypted data and final authentication tag" + case symalgo of + OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> fail "SEIPD v2 cannot use plaintext cipher" + _ -> return () + case aeadalgo of + OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm" + _ -> return () + +getMPI :: Get MPI +getMPI = do + mpilen <- getWord16be + bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) + return $ MPI (os2ip bs) + +getPubkey :: PubKeyAlgorithm -> Get PKey +getPubkey RSA = do + MPI n <- get + MPI e <- get + return $ + RSAPubKey + (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)) +getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA +getPubkey DeprecatedRSASignOnly = getPubkey RSA +getPubkey DSA = do + MPI p <- get + MPI q <- get + MPI g <- get + MPI y <- get + return $ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y)) +getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal +getPubkey ForbiddenElgamal = do + MPI p <- get + MPI g <- get + MPI y <- get + return $ ElGamalPubKey p g y +getPubkey ECDSA = do + curvelength <- getWord8 + when (curvelength == 0 || curvelength == 0xff) $ + fail "invalid ECC curve OID length octet (reserved value)" + curveoid <- getByteString (fromIntegral curvelength) + MPI mpi <- getMPI + case curveoidBSToCurve curveoid of + Left e -> fail e + Right Curve25519 -> + EdDSAPubKey P.Ed25519 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi) + Right curve -> + case bs2Point (i2osp mpi) of + Left e -> fail e + Right point -> + return . ECDSAPubKey . ECDSA_PublicKey . + ECDSA.PublicKey (curve2Curve curve) $ + point +getPubkey ECDH = do + ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA + kdflen <- getWord8 + when (kdflen == 0 || kdflen == 0xff) $ + fail "invalid ECDH KDF field length octet (reserved value)" + when (kdflen /= 3) $ + fail ("invalid ECDH KDF field length: " ++ show kdflen) + one <- getWord8 + when (one /= 1) $ + fail ("invalid ECDH KDF reserved octet: " ++ show one) + kdfHA <- get + kdfSA <- get + return $ ECDHPubKey ed kdfHA kdfSA +getPubkey EdDSA = do + curvelength <- getWord8 + when (curvelength == 0 || curvelength == 0xff) $ + fail "invalid EdDSA curve OID length octet (reserved value)" + curveoid <- getByteString (fromIntegral curvelength) + MPI mpi <- getMPI + case curveoidBSToEdSigningCurve curveoid of + Left e -> fail e + Right P.Ed25519 -> + EdDSAPubKey P.Ed25519 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi) + Right P.Ed448 -> + EdDSAPubKey P.Ed448 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi) +getPubkey pka | pka == BTypes.Ed25519 = + parseFixedLengthOrLegacyPubkey + 32 + (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict) + (getPubkey EdDSA) +getPubkey pka | pka == BTypes.Ed448 = + parseFixedLengthOrLegacyPubkey + 57 + (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict) + (getPubkey EdDSA) +getPubkey X25519 = + parseFixedLengthOrLegacyPubkey + 32 + (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict) + (getPubkey ECDH) +getPubkey X448 = + parseFixedLengthOrLegacyPubkey + 56 + (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict) + (getPubkey ECDH) +getPubkey _ = UnknownPKey <$> getRemainingLazyByteString + +parseFixedLengthOrLegacyPubkey :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey +parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do + remaining <- lookAhead getRemainingLazyByteString + if BL.length remaining == expectedLen + then decodeFixed <$> getLazyByteString expectedLen + else legacyParser + +getPubkeyV6 :: PubKeyAlgorithm -> Get PKey +getPubkeyV6 pka + | pka == BTypes.Ed25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 32) $ + fail "invalid v6 Ed25519 public key length" + return $ EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.Ed448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 57) $ + fail "invalid v6 Ed448 public key length" + return $ EdDSAPubKey P.Ed448 (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.X25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 32) $ + fail "invalid v6 X25519 public key length" + return $ EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.X448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 56) $ + fail "invalid v6 X448 public key length" + return $ EdDSAPubKey P.Ed448 (NativeEPoint (EPoint (os2ip bs))) + | otherwise = getPubkey pka + +bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint +bs2Point bs = + if B.null bs + then Left "empty EC point encoding" + 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) + else if odd l + then Left "malformed EC point encoding: odd coordinate payload length" + else + return + (uncurry + ECCT.Point + ((os2ip *** os2ip) (B.splitAt (div l 2) xy))) + +putPubkey :: PKey -> Put +putPubkey (UnknownPKey bs) = putLazyByteString bs +putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = + let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) + in putCurveOID curveoidbs >> + mapM_ put (pubkeyToMPIs p) +putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) = + let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) + in putCurveOID curveoidbs >> + mapM_ put (pubkeyToMPIs p) >> + putECDHKDFParams kha ksa +putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = + let Right curveoidbs = curveToCurveoidBS (ed2ec curve) + in putCurveOID curveoidbs >> + mapM_ put (pubkeyToMPIs p) >> + putECDHKDFParams kha ksa + where + ed2ec P.Ed25519 = Curve25519 + ed2ec P.Ed448 = Curve448 +putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) = + let Right curveoidbs = edSigningCurveToCurveoidBS curve + in putCurveOID curveoidbs >> + mapM_ put (pubkeyToMPIs p) +putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) = + error ("legacy ECDH serialization requires a prefixed-native " ++ show curve ++ " point") +putPubkey (EdDSAPubKey curve (NativeEPoint _)) = + error ("legacy EdDSA serialization requires a prefixed-native " ++ show curve ++ " point") +putPubkey p = mapM_ put (pubkeyToMPIs p) + +putPubkeyV6 :: PKey -> Put +putPubkeyV6 (EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint x))) = do + let bs = fixedLengthOctets 32 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 (EdDSAPubKey P.Ed448 (NativeEPoint (EPoint x))) = do + let bs = fixedLengthOctets 57 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 (ECDHPubKey (EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint x))) kha ksa) = do + let bs = fixedLengthOctets 32 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs + put kha + put ksa +putPubkeyV6 (ECDHPubKey (EdDSAPubKey P.Ed448 (NativeEPoint (EPoint x))) kha ksa) = do + let bs = fixedLengthOctets 56 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs + put kha + put ksa +putPubkeyV6 p = putPubkey p + +fixedLengthOctets :: Int -> Integer -> B.ByteString +fixedLengthOctets targetLen x = + let bs = i2osp x + in if B.length bs > targetLen + then error ("public key element does not fit in " ++ show targetLen ++ " octets") + else B.replicate (targetLen - B.length bs) 0 <> bs + +validatePrefixedNativePoint :: Int -> String -> Integer -> Get EPoint +validatePrefixedNativePoint targetLen label i = + let bs = i2osp i + in if B.length bs /= targetLen + 1 + then + fail + ("invalid " ++ label ++ " public key length: expected " ++ + show (targetLen + 1) ++ " octets with 0x40 prefix, got " ++ show (B.length bs)) + else + if B.head bs /= 0x40 + then fail ("invalid " ++ label ++ " public key: missing 0x40 prefix") + else pure (EPoint i) + +putCurveOID :: B.ByteString -> Put +putCurveOID oid = do + let oidLength = B.length oid + when (oidLength == 0 || oidLength == 0xff) $ + error "curve OID length cannot use reserved values 0 or 255" + putWord8 (fromIntegral oidLength) + putByteString oid + +putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put +putECDHKDFParams kdfHA kdfSA = do + let kdfLengthOctet = 0x03 + when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $ + error "ECDH KDF field length cannot use reserved values 0 or 255" + putWord8 kdfLengthOctet + putWord8 0x01 + put kdfHA + put kdfSA + +parseOPSNestedFlag :: Word8 -> Get NestedFlag +parseOPSNestedFlag 0 = pure True +parseOPSNestedFlag 1 = pure False +parseOPSNestedFlag other = + fail ("invalid OPS nested flag octet: " ++ show other) + +getSecretKey :: SomePKPayload -> Get SKey +getSecretKey pkp + | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do + MPI d <- get + MPI p <- get + MPI q <- get + MPI _ <- get -- u + case inverse q p of + Nothing -> fail "invalid RSA secret key: q has no inverse modulo p" + Just qinv -> do + let dP = d `mod` (p - 1) + dQ = d `mod` (q - 1) + pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp) + return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv)) + | _pkalgo pkp == DSA = do + MPI x <- get + return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x)) + | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do + MPI x <- get + return $ ElGamalPrivateKey x + | _pkalgo pkp == ECDSA = do + let pubcurve = + (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) + (_pubkey pkp) + getECDSAScalarPrivateKey pubcurve + | _pkalgo pkp == ECDH + = do + pubcurve <- ecdhPrivateCurveFromPKPayload pkp + getECDHScalarPrivateKey pubcurve + | _pkalgo pkp == X25519 = do + if _keyVersion pkp == V6 + then do + sk <- getByteString 32 + return $ X25519PrivateKey sk + else do + pubcurve <- ecdhPrivateCurveFromPKPayload pkp + getECDHScalarPrivateKey pubcurve + | _pkalgo pkp == X448 = do + if _keyVersion pkp == V6 + then do + sk <- getByteString 56 + return $ X448PrivateKey sk + else UnknownSKey <$> getRemainingLazyByteString + | _pkalgo pkp == EdDSA = do + if _keyVersion pkp == V6 + then do + case _pubkey pkp of + EdDSAPubKey P.Ed25519 _ -> EdDSAPrivateKey P.Ed25519 <$> getByteString 32 + EdDSAPubKey P.Ed448 _ -> EdDSAPrivateKey P.Ed448 <$> getByteString 57 + _ -> UnknownSKey <$> getRemainingLazyByteString + else do + MPI x <- get + case _pubkey pkp of + EdDSAPubKey P.Ed25519 _ -> + return $ EdDSAPrivateKey P.Ed25519 (leftPadTo 32 (i2osp x)) + EdDSAPubKey P.Ed448 _ -> + return $ EdDSAPrivateKey P.Ed448 (leftPadTo 57 (i2osp x)) + _ -> return $ UnknownSKey (BL.fromStrict (i2osp x)) + | otherwise = UnknownSKey <$> getRemainingLazyByteString + +getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey +getECDSAScalarPrivateKey curve = do + MPI pn <- get + pure $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) + +getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey +getECDHScalarPrivateKey curve = do + MPI pn <- get + pure $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) + +ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve +ecdhPrivateCurveFromPKPayload pkp = + case _pubkey pkp of + ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ -> + pure (ECDSA.public_curve p) + ECDHPubKey (EdDSAPubKey P.Ed25519 _) _ _ -> + pure (curve2Curve Curve25519) + ECDHPubKey (EdDSAPubKey P.Ed448 _) _ _ -> + pure (curve2Curve Curve448) + other -> + fail + ("ECDH/X25519 secret key requires an ECDH public key packet, got " ++ + show other) + +putSKey :: SKey -> Either String 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)" +putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) = + Right (put (MPI x)) +putSKey (ElGamalPrivateKey x) = + Right (put (MPI x)) +putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = + Right (put (MPI d)) +putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = + Right (put (MPI d)) +putSKey (EdDSAPrivateKey P.Ed25519 sk) = Right (putByteString sk) +putSKey (EdDSAPrivateKey P.Ed448 sk) = Right (putByteString sk) +putSKey (X25519PrivateKey sk) = Right (putByteString sk) +putSKey (X448PrivateKey sk) = Right (putByteString sk) +putSKey (UnknownSKey bs) = Right (putLazyByteString bs) + +putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put +putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs) + | _keyVersion pkp == V6 = putSKey sk + | otherwise = Right (put (MPI (os2ip bs))) +putSKeyForPKPayload _ sk = putSKey sk + +putMPI :: MPI -> Put +putMPI (MPI i) = do + let bs = i2osp i + putWord16be . fromIntegral . numBits $ i + putByteString bs + +data PKPayloadReadCase where + PKPayloadReadCaseV3 :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase + PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase + PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase + +pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase +pkPayloadReadCase version = + case version of + 2 -> do + v3e <- getWord16be + pka <- get + pure (PKPayloadReadCaseV3 v3e pka) + 3 -> do + v3e <- getWord16be + pka <- get + pure (PKPayloadReadCaseV3 v3e pka) + 4 -> PKPayloadReadCaseV4 <$> get + 6 -> PKPayloadReadCaseV6 <$> get + _ -> fail ("unsupported key packet version " ++ show version) + +getPKPayload :: Get SomePKPayload +getPKPayload = do + version <- getWord8 + ctime <- fmap ThirtyTwoBitTimeStamp getWord32be + readCase <- pkPayloadReadCase version + case readCase of + PKPayloadReadCaseV3 v3e pka -> do + pk <- getPubkey pka + pure $! PKPayload DeprecatedV3 ctime v3e pka pk + PKPayloadReadCaseV4 pka -> do + pk <- getPubkey pka + pure $! PKPayload V4 ctime 0 pka pk + PKPayloadReadCaseV6 pka -> do + pk <- getPubkeyV6 pka + pure $! PKPayload V6 ctime 0 pka pk + +data PKPayloadWriteCase where + PKPayloadWriteCaseV3 :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase + PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase + PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase + +pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase +pkPayloadWriteCase (SomePKPayload pkp) = + case pkp of + PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp + PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp + PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp + +putPKPayload :: SomePKPayload -> Put +putPKPayload pkpSome = + case pkPayloadWriteCase pkpSome of + PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do + putWord8 3 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + putWord16be v3e + put pka + putPubkey pk + PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do + putWord8 4 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + put pka + putPubkeyV4ForAlgorithm pka pk + PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do + putWord8 6 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + put pka + putPubkeyV6 pk + +putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put +putPubkeyV4ForAlgorithm pka pk + | pka == BTypes.Ed25519 = putPubkeyV4Fixed 32 P.Ed25519 pk + | pka == BTypes.Ed448 = putPubkeyV4Fixed 57 P.Ed448 pk + | pka == BTypes.X25519 = putPubkeyV4Fixed 32 P.Ed25519 pk + | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.Ed448 pk + | otherwise = putPubkey pk + +putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put +putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x))) + | curve == expectedCurve = putByteString (fixedLengthOctets targetLen x) +putPubkeyV4Fixed _ _ pk = putPubkey pk + +getSKAddendum :: SomePKPayload -> Get SKAddendum +getSKAddendum (SomePKPayload pkp) = + toSKAddendum <$> getSKAddendumTyped pkp + +getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v) +getSKAddendumTyped pkp = do + s2kusage <- getWord8 + let pkpSome = SomePKPayload pkp + getLegacyS2KProtected constructor = do + symencWord <- getWord8 + s2k <- getS2K + let symenc = toFVal symencWord + case s2k of + OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty + _ -> do + blockSize <- either fail pure (symEncBlockSize symenc) + iv <- IV <$> getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return $ constructor symenc s2k iv encryptedblock + case s2kusage of + 0 -> + case pkp of + PKPayloadV6 {} -> do + sk <- getSecretKey pkpSome + return (SKAUnencryptedV6 sk) + PKPayloadV3 {} -> do + rest <- lookAhead getRemainingLazyByteString + secretLen <- + case runGetOrFail + (do + start <- bytesRead + _ <- getSecretKey pkpSome + end <- bytesRead + pure (end - start)) + rest of + Left (_, _, err) -> fail err + Right (_, _, len) -> pure len + sk <- getSecretKey pkpSome + checksum <- getWord16be + let expectedChecksum = + checksum16Bytes (BL.toStrict (BL.take secretLen rest)) + when (checksum /= expectedChecksum) $ + fail + ("legacy unencrypted secret-key checksum mismatch: expected " ++ + show expectedChecksum ++ ", got " ++ show checksum) + return (SKAUnencryptedLegacy sk checksum) + PKPayloadV4 {} -> do + rest <- lookAhead getRemainingLazyByteString + secretLen <- + case runGetOrFail + (do + start <- bytesRead + _ <- getSecretKey pkpSome + end <- bytesRead + pure (end - start)) + rest of + Left (_, _, err) -> fail err + Right (_, _, len) -> pure len + sk <- getSecretKey pkpSome + checksum <- getWord16be + let expectedChecksum = + checksum16Bytes (BL.toStrict (BL.take secretLen rest)) + when (checksum /= expectedChecksum) $ + fail + ("legacy unencrypted secret-key checksum mismatch: expected " ++ + show expectedChecksum ++ ", got " ++ show checksum) + return (SKAUnencryptedLegacy sk checksum) + 255 -> + case pkp of + PKPayloadV6 {} -> + fail "v6 secret key packets MUST NOT use s2k usage 255" + PKPayloadV3 {} -> + getLegacyS2KProtected SKA16bit + PKPayloadV4 {} -> + getLegacyS2KProtected SKA16bit + 254 -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symenc, s2k, iv) <- + case runGetOrFail getV6CFBParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing v6 CFB parameters" + | otherwise -> pure parsed + encryptedblock <- getRemainingLazyByteString + return (SKASHA1V6 symenc s2k (IV iv) encryptedblock) + PKPayloadV3 {} -> + getLegacyS2KProtected SKASHA1Legacy + PKPayloadV4 {} -> + getLegacyS2KProtected SKASHA1Legacy + where + getV6CFBParams = do + symencWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing bytes in v6 S2K specifier" + | otherwise -> pure parsed + iv <- getRemainingLazyByteString + let symenc = toFVal symencWord + blockSize <- either fail pure (symEncBlockSize symenc) + when (BL.length iv /= fromIntegral blockSize) $ + fail "invalid v6 CFB IV length" + pure (symenc, s2k, BL.toStrict iv) + 253 -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symenc, aead, s2k, iv) <- + case runGetOrFail getV6AEADParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing v6 AEAD parameters" + | otherwise -> pure parsed + encryptedblock <- getRemainingLazyByteString + return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock) + PKPayloadV3 {} -> do + (symenc, aead, s2k, iv) <- getLegacyAEADParams + encryptedblock <- getRemainingLazyByteString + return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) + PKPayloadV4 {} -> do + (symenc, aead, s2k, iv) <- getLegacyAEADParams + encryptedblock <- getRemainingLazyByteString + return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) + where + getV6AEADParams :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) + getV6AEADParams = do + symencWord <- getWord8 + aeadWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> fail "unexpected trailing bytes in v6 S2K specifier" + | otherwise -> pure parsed + iv <- getRemainingLazyByteString + let symenc = toFVal symencWord + aead = toFVal aeadWord + when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $ + fail "invalid v6 AEAD IV length" + pure (symenc, aead, s2k, BL.toStrict iv) + -- v3/v4: no cumulative-params-length octet, no S2K-size octet + getLegacyAEADParams :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) + getLegacyAEADParams = do + symencWord <- getWord8 + aeadWord <- getWord8 + s2k <- getS2K + let aead = toFVal aeadWord + iv <- BL.toStrict <$> getLazyByteString (fromIntegral (aeadNonceSize aead)) + pure (toFVal symencWord, aead, s2k, iv) + symenc -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + iv <- getByteString (fromIntegral paramsLen) + let symencAlg = toFVal symenc + blockSize <- either fail pure (symEncBlockSize symencAlg) + when (B.length iv /= blockSize) $ + fail "invalid v6 CFB IV length" + encryptedblock <- getRemainingLazyByteString + return (SKASymV6 symencAlg (IV iv) encryptedblock) + PKPayloadV3 {} -> do + blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) + iv <- getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) + PKPayloadV4 {} -> do + blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) + iv <- getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) + +putSKAddendum :: SKAddendum -> Either String Put +putSKAddendum (SUS16bit symenc s2k iv encryptedblock) = + Right $ do + putWord8 255 + put symenc + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = + Right $ do + putWord8 254 + put symenc + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) = + Right $ do + putWord8 253 + put symenc + putWord8 (fromFVal aead) + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSym symenc iv encryptedblock) = + Right $ do + put symenc + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUUnencrypted sk checksum) = + do + putSecret <- putSKey sk + Right $ do + putWord8 0 + let skb = runPut putSecret + putLazyByteString skb + putWord16be + (if checksum == 0 + then checksum16Bytes (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 + Left e -> error e + Right (SomeSKAddendumV skaV) -> + putSKAddendumForPKPayloadTyped pkp skaV + +putSKAddendumForPKPayloadTyped :: + SomePKPayload + -> SKAddendumV v + -> Put +putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do + putWord8 0 + let putSecret = + case putSKeyForPKPayload pkp sk of + Left err -> error err + Right p -> p + skb = runPut putSecret + putLazyByteString skb + putWord16be + (if checksum == 0 + then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb + else checksum) +putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) = do + putWord8 0 + let putSecret = + case putSKeyForPKPayload pkp sk of + Left err -> error err + Right p -> p + skb = runPut putSecret + putLazyByteString skb +putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do + let s2kbs = runPut (put s2k) + paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) + putWord8 254 + putWord8 (fromIntegral paramsLen) + put symenc + putWord8 (fromIntegral (BL.length s2kbs)) + putLazyByteString s2kbs + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKAAEADV6 symenc aead s2k iv encryptedblock) = do + let s2kbs = runPut (put s2k) + paramsLen = 1 + 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) + putWord8 253 + putWord8 (fromIntegral paramsLen) + put symenc + putWord8 (fromFVal aead) + putWord8 (fromIntegral (BL.length s2kbs)) + putLazyByteString s2kbs + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKAAEADLegacy symenc aead s2k iv encryptedblock) = do + putWord8 253 + put symenc + putWord8 (fromFVal aead) + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKASymV6 symenc iv encryptedblock) = do + putWord8 (fromFVal symenc) + putWord8 (fromIntegral (B.length (unIV iv))) + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ skaV = + case putSKAddendum (toSKAddendum skaV) of + Left e -> error e + Right p -> p + +aeadNonceSize :: AEADAlgorithm -> Int +aeadNonceSize EAX = 16 +aeadNonceSize OCB = 15 +aeadNonceSize GCM = 12 +aeadNonceSize (OtherAEADAlgo _) = 0 + +symEncBlockSize :: SymmetricAlgorithm -> Either String Int +symEncBlockSize Plaintext = Right 0 +symEncBlockSize IDEA = Right 8 +symEncBlockSize TripleDES = Right 8 +symEncBlockSize CAST5 = Right 8 +symEncBlockSize Blowfish = Right 8 +symEncBlockSize AES128 = Right 16 +symEncBlockSize AES192 = Right 16 +symEncBlockSize AES256 = Right 16 +symEncBlockSize Twofish = Right 16 +symEncBlockSize Camellia128 = Right 16 +symEncBlockSize Camellia192 = Right 16 +symEncBlockSize Camellia256 = Right 16 +symEncBlockSize sa = + Left ("unsupported symmetric algorithm for secret-key IV sizing: " ++ show sa) + +decodeIterationCount :: Word8 -> IterationCount +decodeIterationCount c = + IterationCount + ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)) + +encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table? +encodeIterationCount 1024 = 0 +encodeIterationCount 1088 = 1 +encodeIterationCount 1152 = 2 +encodeIterationCount 1216 = 3 +encodeIterationCount 1280 = 4 +encodeIterationCount 1344 = 5 +encodeIterationCount 1408 = 6 +encodeIterationCount 1472 = 7 +encodeIterationCount 1536 = 8 +encodeIterationCount 1600 = 9 +encodeIterationCount 1664 = 10 +encodeIterationCount 1728 = 11 +encodeIterationCount 1792 = 12 +encodeIterationCount 1856 = 13 +encodeIterationCount 1920 = 14 +encodeIterationCount 1984 = 15 +encodeIterationCount 2048 = 16 +encodeIterationCount 2176 = 17 +encodeIterationCount 2304 = 18 +encodeIterationCount 2432 = 19 +encodeIterationCount 2560 = 20 +encodeIterationCount 2688 = 21 +encodeIterationCount 2816 = 22 +encodeIterationCount 2944 = 23 +encodeIterationCount 3072 = 24 +encodeIterationCount 3200 = 25 +encodeIterationCount 3328 = 26 +encodeIterationCount 3456 = 27 +encodeIterationCount 3584 = 28 +encodeIterationCount 3712 = 29 +encodeIterationCount 3840 = 30 +encodeIterationCount 3968 = 31 +encodeIterationCount 4096 = 32 +encodeIterationCount 4352 = 33 +encodeIterationCount 4608 = 34 +encodeIterationCount 4864 = 35 +encodeIterationCount 5120 = 36 +encodeIterationCount 5376 = 37 +encodeIterationCount 5632 = 38 +encodeIterationCount 5888 = 39 +encodeIterationCount 6144 = 40 +encodeIterationCount 6400 = 41 +encodeIterationCount 6656 = 42 +encodeIterationCount 6912 = 43 +encodeIterationCount 7168 = 44 +encodeIterationCount 7424 = 45 +encodeIterationCount 7680 = 46 +encodeIterationCount 7936 = 47 +encodeIterationCount 8192 = 48 +encodeIterationCount 8704 = 49 +encodeIterationCount 9216 = 50 +encodeIterationCount 9728 = 51 +encodeIterationCount 10240 = 52 +encodeIterationCount 10752 = 53 +encodeIterationCount 11264 = 54 +encodeIterationCount 11776 = 55 +encodeIterationCount 12288 = 56 +encodeIterationCount 12800 = 57 +encodeIterationCount 13312 = 58 +encodeIterationCount 13824 = 59 +encodeIterationCount 14336 = 60 +encodeIterationCount 14848 = 61 +encodeIterationCount 15360 = 62 +encodeIterationCount 15872 = 63 +encodeIterationCount 16384 = 64 +encodeIterationCount 17408 = 65 +encodeIterationCount 18432 = 66 +encodeIterationCount 19456 = 67 +encodeIterationCount 20480 = 68 +encodeIterationCount 21504 = 69 +encodeIterationCount 22528 = 70 +encodeIterationCount 23552 = 71 +encodeIterationCount 24576 = 72 +encodeIterationCount 25600 = 73 +encodeIterationCount 26624 = 74 +encodeIterationCount 27648 = 75 +encodeIterationCount 28672 = 76 +encodeIterationCount 29696 = 77 +encodeIterationCount 30720 = 78 +encodeIterationCount 31744 = 79 +encodeIterationCount 32768 = 80 +encodeIterationCount 34816 = 81 +encodeIterationCount 36864 = 82 +encodeIterationCount 38912 = 83 +encodeIterationCount 40960 = 84 +encodeIterationCount 43008 = 85 +encodeIterationCount 45056 = 86 +encodeIterationCount 47104 = 87 +encodeIterationCount 49152 = 88 +encodeIterationCount 51200 = 89 +encodeIterationCount 53248 = 90 +encodeIterationCount 55296 = 91 +encodeIterationCount 57344 = 92 +encodeIterationCount 59392 = 93 +encodeIterationCount 61440 = 94 +encodeIterationCount 63488 = 95 +encodeIterationCount 65536 = 96 +encodeIterationCount 69632 = 97 +encodeIterationCount 73728 = 98 +encodeIterationCount 77824 = 99 +encodeIterationCount 81920 = 100 +encodeIterationCount 86016 = 101 +encodeIterationCount 90112 = 102 +encodeIterationCount 94208 = 103 +encodeIterationCount 98304 = 104 +encodeIterationCount 102400 = 105 +encodeIterationCount 106496 = 106 +encodeIterationCount 110592 = 107 +encodeIterationCount 114688 = 108 +encodeIterationCount 118784 = 109 +encodeIterationCount 122880 = 110 +encodeIterationCount 126976 = 111 +encodeIterationCount 131072 = 112 +encodeIterationCount 139264 = 113 +encodeIterationCount 147456 = 114 +encodeIterationCount 155648 = 115 +encodeIterationCount 163840 = 116 +encodeIterationCount 172032 = 117 +encodeIterationCount 180224 = 118 +encodeIterationCount 188416 = 119 +encodeIterationCount 196608 = 120 +encodeIterationCount 204800 = 121 +encodeIterationCount 212992 = 122 +encodeIterationCount 221184 = 123 +encodeIterationCount 229376 = 124 +encodeIterationCount 237568 = 125 +encodeIterationCount 245760 = 126 +encodeIterationCount 253952 = 127 +encodeIterationCount 262144 = 128 +encodeIterationCount 278528 = 129 +encodeIterationCount 294912 = 130 +encodeIterationCount 311296 = 131 +encodeIterationCount 327680 = 132 +encodeIterationCount 344064 = 133 +encodeIterationCount 360448 = 134 +encodeIterationCount 376832 = 135 +encodeIterationCount 393216 = 136 +encodeIterationCount 409600 = 137 +encodeIterationCount 425984 = 138 +encodeIterationCount 442368 = 139 +encodeIterationCount 458752 = 140 +encodeIterationCount 475136 = 141 +encodeIterationCount 491520 = 142 +encodeIterationCount 507904 = 143 +encodeIterationCount 524288 = 144 +encodeIterationCount 557056 = 145 +encodeIterationCount 589824 = 146 +encodeIterationCount 622592 = 147 +encodeIterationCount 655360 = 148 +encodeIterationCount 688128 = 149 +encodeIterationCount 720896 = 150 +encodeIterationCount 753664 = 151 +encodeIterationCount 786432 = 152 +encodeIterationCount 819200 = 153 +encodeIterationCount 851968 = 154 +encodeIterationCount 884736 = 155 +encodeIterationCount 917504 = 156 +encodeIterationCount 950272 = 157 +encodeIterationCount 983040 = 158 +encodeIterationCount 1015808 = 159 +encodeIterationCount 1048576 = 160 +encodeIterationCount 1114112 = 161 +encodeIterationCount 1179648 = 162 +encodeIterationCount 1245184 = 163 +encodeIterationCount 1310720 = 164 +encodeIterationCount 1376256 = 165 +encodeIterationCount 1441792 = 166 +encodeIterationCount 1507328 = 167 +encodeIterationCount 1572864 = 168 +encodeIterationCount 1638400 = 169 +encodeIterationCount 1703936 = 170 +encodeIterationCount 1769472 = 171 +encodeIterationCount 1835008 = 172 +encodeIterationCount 1900544 = 173 +encodeIterationCount 1966080 = 174 +encodeIterationCount 2031616 = 175 +encodeIterationCount 2097152 = 176 +encodeIterationCount 2228224 = 177 +encodeIterationCount 2359296 = 178 +encodeIterationCount 2490368 = 179 +encodeIterationCount 2621440 = 180 +encodeIterationCount 2752512 = 181 +encodeIterationCount 2883584 = 182 +encodeIterationCount 3014656 = 183 +encodeIterationCount 3145728 = 184 +encodeIterationCount 3276800 = 185 +encodeIterationCount 3407872 = 186 +encodeIterationCount 3538944 = 187 +encodeIterationCount 3670016 = 188 +encodeIterationCount 3801088 = 189 +encodeIterationCount 3932160 = 190 +encodeIterationCount 4063232 = 191 +encodeIterationCount 4194304 = 192 +encodeIterationCount 4456448 = 193 +encodeIterationCount 4718592 = 194 +encodeIterationCount 4980736 = 195 +encodeIterationCount 5242880 = 196 +encodeIterationCount 5505024 = 197 +encodeIterationCount 5767168 = 198 +encodeIterationCount 6029312 = 199 +encodeIterationCount 6291456 = 200 +encodeIterationCount 6553600 = 201 +encodeIterationCount 6815744 = 202 +encodeIterationCount 7077888 = 203 +encodeIterationCount 7340032 = 204 +encodeIterationCount 7602176 = 205 +encodeIterationCount 7864320 = 206 +encodeIterationCount 8126464 = 207 +encodeIterationCount 8388608 = 208 +encodeIterationCount 8912896 = 209 +encodeIterationCount 9437184 = 210 +encodeIterationCount 9961472 = 211 +encodeIterationCount 10485760 = 212 +encodeIterationCount 11010048 = 213 +encodeIterationCount 11534336 = 214 +encodeIterationCount 12058624 = 215 +encodeIterationCount 12582912 = 216 +encodeIterationCount 13107200 = 217 +encodeIterationCount 13631488 = 218 +encodeIterationCount 14155776 = 219 +encodeIterationCount 14680064 = 220 +encodeIterationCount 15204352 = 221 +encodeIterationCount 15728640 = 222 +encodeIterationCount 16252928 = 223 +encodeIterationCount 16777216 = 224 +encodeIterationCount 17825792 = 225 +encodeIterationCount 18874368 = 226 +encodeIterationCount 19922944 = 227 +encodeIterationCount 20971520 = 228 +encodeIterationCount 22020096 = 229 +encodeIterationCount 23068672 = 230 +encodeIterationCount 24117248 = 231 +encodeIterationCount 25165824 = 232 +encodeIterationCount 26214400 = 233 +encodeIterationCount 27262976 = 234 +encodeIterationCount 28311552 = 235 +encodeIterationCount 29360128 = 236 +encodeIterationCount 30408704 = 237 +encodeIterationCount 31457280 = 238 +encodeIterationCount 32505856 = 239 +encodeIterationCount 33554432 = 240 +encodeIterationCount 35651584 = 241 +encodeIterationCount 37748736 = 242 +encodeIterationCount 39845888 = 243 +encodeIterationCount 41943040 = 244 +encodeIterationCount 44040192 = 245 +encodeIterationCount 46137344 = 246 +encodeIterationCount 48234496 = 247 +encodeIterationCount 50331648 = 248 +encodeIterationCount 52428800 = 249 +encodeIterationCount 54525952 = 250 +encodeIterationCount 56623104 = 251 +encodeIterationCount 58720256 = 252 +encodeIterationCount 60817408 = 253 +encodeIterationCount 62914560 = 254 +encodeIterationCount 65011712 = 255 +encodeIterationCount n = error ("invalid iteration count" ++ show n) + +getSignaturePayload :: Get SignaturePayload +getSignaturePayload = do + pv <- getWord8 + case pv of + 3 -> do + hashlen <- getWord8 + guard (hashlen == 5) + st <- getWord8 + ctime <- fmap ThirtyTwoBitTimeStamp getWord32be + eok <- getLazyByteString 8 + pka <- get + ha <- get + left16 <- getWord16be + mpib <- getRemainingLazyByteString + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) + Right (_, _, mpis) -> + return $ + SigV3 + (toFVal st) + ctime + (EightOctetKeyId eok) + (toFVal pka) + (toFVal ha) + left16 + (NE.fromList mpis) + 4 -> do + st <- getWord8 + pkaOctet <- get + ha <- get + let pka = toFVal pkaOctet :: PubKeyAlgorithm + hlen <- getWord16be + hb <- getLazyByteString (fromIntegral hlen) + let hashed = + case runGetOrFail (many getSigSubPacket) hb of + Left (_, _, err) -> fail ("v4 sig hasheds " ++ err) + Right (_, _, h) -> h + ulen <- getWord16be + ub <- getLazyByteString (fromIntegral ulen) + let unhashed = + case runGetOrFail (many getSigSubPacket) ub of + Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) + Right (_, _, u) -> u + left16 <- getWord16be + mpib <- getRemainingLazyByteString + let parseV4MPIs parseErrPrefix = + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail (parseErrPrefix ++ e) + Right (_, _, mpis) -> + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList mpis) + if pka == BTypes.Ed25519 + then + if BL.length mpib == 64 + then do + let sig = BL.toStrict mpib + (rbs, sbs) = B.splitAt 32 sig + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) + else parseV4MPIs "v4 Ed25519 legacy MPIs " + else + if pka == BTypes.Ed448 + then + if BL.length mpib == 114 + then do + let sig = BL.toStrict mpib + (rbs, sbs) = B.splitAt 57 sig + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) + else parseV4MPIs "v4 Ed448 legacy MPIs " + else parseV4MPIs "v4 sig MPIs " + 6 -> do + st <- getWord8 + pka <- get + ha <- get + hlen <- getWord32be + hb <- getLazyByteString (fromIntegral hlen) + let hashed = + case runGetOrFail (many getSigSubPacket) hb of + Left (_, _, err) -> fail ("v6 sig hasheds " ++ err) + Right (_, _, h) -> h + ulen <- getWord32be + ub <- getLazyByteString (fromIntegral ulen) + let unhashed = + case runGetOrFail (many getSigSubPacket) ub of + Left (_, _, err) -> fail ("v6 sig unhasheds " ++ err) + Right (_, _, u) -> u + left16 <- getWord16be + saltSize <- getWord8 + let haVal = (toFVal ha :: HashAlgorithm) + expectedSaltSize <- + maybe + (fail ("signature hash algorithm does not define a V6 salt size: " ++ show haVal)) + pure + (v6SaltSizeForHashAlgorithm haVal) + when (saltSize /= expectedSaltSize) $ + fail + ("v6 signature salt size mismatch for " ++ + show haVal ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) + saltbs <- getByteString (fromIntegral saltSize) + let salt = SignatureSalt (BL.fromStrict saltbs) + if pka == BTypes.Ed25519 + then do + sig <- getByteString 64 + let (rbs, sbs) = B.splitAt 32 sig + mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + else + if pka == BTypes.Ed448 + then do + sig <- getByteString 114 + let (rbs, sbs) = B.splitAt 57 sig + mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + else do + mpib <- getRemainingLazyByteString + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail ("v6 sig MPIs " ++ e) + Right (_, _, mpis) -> + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + _ -> do + bs <- getRemainingLazyByteString + return $ SigVOther pv bs + +putSignaturePayload :: SignaturePayload -> Put +putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do + putWord8 3 + putWord8 5 -- hashlen + put st + putWord32be . unThirtyTwoBitTimeStamp $ ctime + putLazyByteString (unEOKI eok) + put pka + put ha + putWord16be left16 + F.mapM_ put mpis +putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do + putWord8 4 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord16be . fromIntegral . BL.length $ hb + putLazyByteString hb + let ub = runPut $ mapM_ put unhashed + putWord16be . fromIntegral . BL.length $ ub + putLazyByteString ub + putWord16be left16 + if pka == BTypes.Ed25519 + then + case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 32 r) + putByteString (padN 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) + _ -> 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 + (error ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) + id + (v6SaltSizeForHashAlgorithm ha) + actualSaltSize = fromIntegral (BL.length (unSignatureSalt salt)) + when (actualSaltSize /= expectedSaltSize) $ + error + ("v6 signature salt size mismatch for " ++ + show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show actualSaltSize) + putWord8 6 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord32be . fromIntegral . BL.length $ hb + putLazyByteString hb + let ub = runPut $ mapM_ put unhashed + putWord32be . fromIntegral . BL.length $ ub + putLazyByteString ub + putWord16be left16 + putWord8 . fromIntegral . BL.length . unSignatureSalt $ salt + putByteString (BL.toStrict (unSignatureSalt salt)) + if pka == BTypes.Ed25519 + then + case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 32 r) + putByteString (padN 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) + _ -> 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 + +putTK :: TKUnknown -> Put +putTK tk = do + let pkp = tk ^. tkuKey . _1 + maybe + (put (PublicKey pkp)) + (\ska -> put (SecretKey pkp ska)) + (snd (tk ^. tkuKey)) + mapM_ (put . Signature) (_tkuRevs tk) + mapM_ putUid' (_tkuUIDs tk) + mapM_ putUat' (_tkuUAts tk) + mapM_ putSub' (_tkuSubs tk) + where + putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps + putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps + putSub' (p, sps) = put p >> mapM_ (put . Signature) sps + +-- | Parse the packets from a ByteString, with no error reporting +parsePkts :: ByteString -> [Pkt] +parsePkts = reverse . fst . parsePktsAccum 0 [] + +-- | Parse packets from a ByteString and report the first parse failure. +parsePktsEither :: ByteString -> Either PktParseError [Pkt] +parsePktsEither lbs = + case parsePktsAccum 0 [] lbs of + (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 + | BL.null lbs = (acc, Nothing) + | otherwise = + case runGetOrFail getPkt lbs of + Left (_, parseOffset, msg) -> (acc, err parseOffset msg) + Right (rest, consumed, pkt) -> + parsePktsAccum (offset + consumed) (pkt : acc) rest + where + err parseOffset msg = + Just + PktParseError + { pktParseErrorOffset = offset + parseOffset + , pktParseErrorMessage = msg + } + +armorPayload :: Armor -> ByteString +armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs) +armorPayload (ClearSigned _ _ inner) = armorPayload inner + +dearmorIfAsciiArmored :: ByteString -> Either String (Bool, ByteString) +dearmorIfAsciiArmored bs + | BLC8.isPrefixOf (BLC8.pack "-----BEGIN PGP ") (BLC8.dropWhile (`elem` (" \t\r\n" :: String)) bs) = + case AA.decodeLazy bs of + Left err -> Left err + Right [] -> Left "ASCII armor decode succeeded but returned no blocks" + Right (a:_) -> Right (True, armorPayload a) + | otherwise = Right (False, bs) + +data WireRepInput = + WireRepInput + { wireRepInputRef :: WireRepRef + , wireRepInputPayload :: ByteString + } + +wireRepRefFromInput :: Maybe T.Text -> ByteString -> Either String WireRepInput +wireRepRefFromInput mname bs = + (\(wasArmored, payload) -> + WireRepInput + { wireRepInputRef = BTypes.mkWireRepRef mname wasArmored payload + , wireRepInputPayload = payload + }) <$> + dearmorIfAsciiArmored bs + +data ParseState = + ParseState + { psOffset :: Int64 + , psIndex :: Int + , psSource :: WireRepRef + , psRemaining :: BL.ByteString + } + +-- | Parse packets from a source bytestream, preserving packet provenance. +parsePktsWithWireRep :: WireRepRef -> ByteString -> [PktWithWireRep] +parsePktsWithWireRep src input = go initialState + where + initialState = + ParseState + { psOffset = 0 + , psIndex = 0 + , psSource = src + , psRemaining = input + } + go state + | BL.null (psRemaining state) = [] + | otherwise = + case runGetOrFail getPkt (psRemaining state) of + Left (_, _, _) -> [] + Right (rest, consumed, pkt) -> + let raw = BL.take consumed (psRemaining state) + newState = + state + { psOffset = psOffset state + consumed + , psIndex = psIndex state + 1 + , psRemaining = rest + } + pktWithSource = + PktWithWireRep + (psSource state) + (ByteRange (psOffset state) consumed) + raw + (psIndex state) + pkt + in pktWithSource : go newState + +conduitParsePktsWithWireRep :: + Monad m => Maybe T.Text -> ConduitT B.ByteString PktWithWireRep m () +conduitParsePktsWithWireRep mname = go (UndecidedInput []) + where + go !state = do + mchunk <- await + case mchunk of + Nothing -> mapM_ yield (finishConduitState mname state) + Just chunk -> + let !nextState = consumeConduitChunk chunk state + in go nextState + +data ConduitParseState + = UndecidedInput ![B.ByteString] + | ArmoredInput ![B.ByteString] + | BinaryInput !BinaryParseState + +data BinaryParseState = + BinaryParseState + { bpsLength :: !Int64 + , bpsOffset :: !Int64 + , bpsIndex :: !Int + , bpsBuffer :: !B.ByteString + , bpsParsedRev :: [ParsedPacketChunk] + } + +data ArmorPrefixDecision + = PrefixNeedsMore + | PrefixIsArmored + | PrefixIsBinary + +consumeConduitChunk :: B.ByteString -> ConduitParseState -> ConduitParseState +consumeConduitChunk chunk (UndecidedInput chunksRev) = + let prefixChunksRev = chunk : chunksRev + prefix = B.concat (reverse prefixChunksRev) + in case classifyArmorPrefix prefix of + PrefixNeedsMore -> UndecidedInput prefixChunksRev + PrefixIsArmored -> ArmoredInput prefixChunksRev + PrefixIsBinary -> feedBinaryChunk prefix initialBinaryParseState +consumeConduitChunk chunk (ArmoredInput chunksRev) = ArmoredInput (chunk : chunksRev) +consumeConduitChunk chunk (BinaryInput state) = BinaryInput (advanceBinaryParseState chunk state) + +finishConduitState :: Maybe T.Text -> ConduitParseState -> [PktWithWireRep] +finishConduitState mname (UndecidedInput chunksRev) = + finalizeBinaryParseState + mname + (advanceBinaryParseState (B.concat (reverse chunksRev)) initialBinaryParseState) +finishConduitState mname (ArmoredInput chunksRev) = + let input = BL.fromChunks (reverse chunksRev) + WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = payload + } = + either + (const + WireRepInput + { wireRepInputRef = BTypes.mkWireRepRef mname False input + , wireRepInputPayload = input + }) + id + (wireRepRefFromInput mname input) + in parsePktsWithWireRep src payload +finishConduitState mname (BinaryInput state) = finalizeBinaryParseState mname state + +initialBinaryParseState :: BinaryParseState +initialBinaryParseState = + BinaryParseState + { bpsLength = 0 + , bpsOffset = 0 + , bpsIndex = 0 + , bpsBuffer = B.empty + , bpsParsedRev = [] + } + +feedBinaryChunk :: B.ByteString -> BinaryParseState -> ConduitParseState +feedBinaryChunk chunk = BinaryInput . advanceBinaryParseState chunk + +advanceBinaryParseState :: B.ByteString -> BinaryParseState -> BinaryParseState +advanceBinaryParseState chunk state = + let !nextLength = bpsLength state + fromIntegral (B.length chunk) + !(nextOffset, nextIndex, nextBuffer, nextParsedRev) = + drainParsedPackets + (bpsOffset state) + (bpsIndex state) + (bpsBuffer state <> chunk) + (bpsParsedRev state) + in BinaryParseState + { bpsLength = nextLength + , bpsOffset = nextOffset + , bpsIndex = nextIndex + , bpsBuffer = nextBuffer + , bpsParsedRev = nextParsedRev + } + +finalizeBinaryParseState :: Maybe T.Text -> BinaryParseState -> [PktWithWireRep] +finalizeBinaryParseState mname state = + let src = BTypes.mkWireRepRefWithLength mname False (bpsLength state) + in map (toPktWithWireRep src) (reverse (bpsParsedRev state)) + +classifyArmorPrefix :: B.ByteString -> ArmorPrefixDecision +classifyArmorPrefix prefix = + case B.dropWhile isLeadingArmorWhitespace prefix of + rest + | B.null rest -> PrefixNeedsMore + | armorHeader `B.isPrefixOf` rest -> PrefixIsArmored + | rest `B.isPrefixOf` armorHeader -> PrefixNeedsMore + | otherwise -> PrefixIsBinary + where + armorHeader = BLC8.toStrict (BLC8.pack "-----BEGIN PGP ") + isLeadingArmorWhitespace w = w `elem` map (fromIntegral . fromEnum) (" \t\r\n" :: String) + +data ParsedPacketChunk = + ParsedPacketChunk + { ppcRange :: ByteRange + , ppcRaw :: ByteString + , ppcIndex :: Int + , ppcValue :: Pkt + } + +toPktWithWireRep :: WireRepRef -> ParsedPacketChunk -> PktWithWireRep +toPktWithWireRep src ppc = + PktWithWireRep src (ppcRange ppc) (ppcRaw ppc) (ppcIndex ppc) (ppcValue ppc) + +drainParsedPackets :: + Int64 + -> Int + -> B.ByteString + -> [ParsedPacketChunk] + -> (Int64, Int, B.ByteString, [ParsedPacketChunk]) +drainParsedPackets !offset !idx !buffer acc + | B.null buffer = (offset, idx, B.empty, acc) + | otherwise = + case runGetOrFail getPkt (BL.fromStrict buffer) of + Left _ -> (offset, idx, buffer, acc) + Right (rest, consumed, pkt) -> + let !consumedLen = fromIntegral consumed + !nextOffset = offset + consumed + !nextIdx = idx + 1 + !nextBuffer = BL.toStrict rest + parsedPacket = + ParsedPacketChunk + { ppcRange = ByteRange offset consumed + , ppcRaw = BL.fromStrict (B.take consumedLen buffer) + , ppcIndex = idx + , ppcValue = pkt + } + in drainParsedPackets + nextOffset + nextIdx + nextBuffer + (parsedPacket : acc) diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -1,7 +1,11 @@ --- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes --- Copyright © 2012-2020 Clint Adams +-- SerializeForSigs.hs: OpenPGP (RFC9580) special serialization for signature purposes +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.SerializeForSigs ( putPKPforFingerprinting , putPartialSigforSigning @@ -12,6 +16,7 @@ , putKeyforSigning , putSigforSigning , payloadForSig + , payloadForSigWith ) where import Control.Lens ((^.)) @@ -30,11 +35,69 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word8) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), pubkeyToMPIs) import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Subpackets (TextNormalizationMode(..)) import Codec.Encryption.OpenPGP.Types +data SignatureSerializationCase where + SignatureSerializationCaseV4 :: + SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase + SignatureSerializationCaseV6 :: + SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase + +fromPktSignatureSerializationCase :: Pkt -> Maybe SignatureSerializationCase +fromPktSignatureSerializationCase pkt = + case fromPktEitherSomeSignatureV pkt of + Right (SomeSignatureV (SignatureV4Packet payload)) -> + Just (SignatureSerializationCaseV4 payload) + Right (SomeSignatureV (SignatureV6Packet payload)) -> + Just (SignatureSerializationCaseV6 payload) + _ -> Nothing + +putPartialSigforSigningCase :: SignatureSerializationCase -> Put +putPartialSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ _ _)) = do + putWord8 4 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord16be . fromIntegral . BL.length $ hb + putLazyByteString hb +putPartialSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha _salt hashed _ _ _)) = do + putWord8 6 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord32be . fromIntegral . BL.length $ hb + putLazyByteString hb + +putSigTrailerCase :: SignatureSerializationCase -> Put +putSigTrailerCase (SignatureSerializationCaseV4 (SigPayloadV4Data _ _ _ hs _ _ _)) = do + putWord8 0x04 + putWord8 0xff + putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs + -- this +6 seems like a bug in RFC4880 +putSigTrailerCase signatureCase@(SignatureSerializationCaseV6 _) = do + putWord8 0x06 + putWord8 0xff + putWord32be . fromIntegral . (+ 6) . BL.length $ runPut (putPartialSigforSigningCase signatureCase) + +putSigforSigningCase :: SignatureSerializationCase -> Put +putSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ left16 mpis)) = do + putWord8 0x88 + let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis) + putWord32be . fromIntegral . BL.length $ bs + putLazyByteString bs +putSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha salt hashed _ left16 mpis)) = do + putWord8 0xC2 + let bs = runPut $ put (SigV6 st pka ha salt hashed [] left16 mpis) + putWord32be . fromIntegral . BL.length $ bs + putLazyByteString bs + putPKPforFingerprinting :: Pkt -> Put putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) @@ -43,6 +106,11 @@ let bs = runPut $ put pkp putWord16be . fromIntegral $ BL.length bs putLazyByteString bs +putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V6 _ _ _ _)) = do + putWord8 0x9B + let bs = runPut $ put pkp + putWord32be . fromIntegral $ BL.length bs + putLazyByteString bs putPKPforFingerprinting _ = error "This should never happen (putPKPforFingerprinting)" @@ -52,24 +120,16 @@ in putByteString bs putPartialSigforSigning :: Pkt -> Put -putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do - putWord8 4 - put st - put pka - put ha - let hb = runPut $ mapM_ put hashed - putWord16be . fromIntegral . BL.length $ hb - putLazyByteString hb -putPartialSigforSigning _ = - error "This should never happen (putPartialSigforSigning)" +putPartialSigforSigning pkt = + case fromPktSignatureSerializationCase pkt of + Just signatureCase -> putPartialSigforSigningCase signatureCase + Nothing -> error ("putPartialSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt)) putSigTrailer :: Pkt -> Put -putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do - putWord8 0x04 - putWord8 0xff - putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs - -- this +6 seems like a bug in RFC4880 -putSigTrailer _ = error "This should never happen (putSigTrailer)" +putSigTrailer pkt = + case fromPktSignatureSerializationCase pkt of + Just signatureCase -> putSigTrailerCase signatureCase + Nothing -> error "This should never happen (putSigTrailer)" putUforSigning :: Pkt -> Put putUforSigning u@(UserIdPkt _) = putUIDforSigning u @@ -93,12 +153,10 @@ putUAtforSigning _ = error "This should never happen (putUAtforSigning)" putSigforSigning :: Pkt -> Put -putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do - putWord8 0x88 - let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis) - putWord32be . fromIntegral . BL.length $ bs - putLazyByteString bs -putSigforSigning _ = error "Non-V4 not implemented." +putSigforSigning pkt = + case fromPktSignatureSerializationCase pkt of + Just signatureCase -> putSigforSigningCase signatureCase + Nothing -> error ("putSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt)) putKeyforSigning :: Pkt -> Put putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp @@ -110,7 +168,12 @@ ("This should never happen (putKeyforSigning) " ++ show (pktTag x) ++ "/" ++ show x) -putKeyForSigning' :: PKPayload -> Put +putKeyForSigning' :: SomePKPayload -> Put +putKeyForSigning' pkp@(PKPayload V6 _ _ _ _) = do + putWord8 0x9B + let bs = runPut $ put pkp + putWord32be . fromIntegral . BL.length $ bs + putLazyByteString bs putKeyForSigning' pkp = do putWord8 0x99 let bs = runPut $ put pkp @@ -118,8 +181,12 @@ putLazyByteString bs payloadForSig :: SigType -> PktStreamContext -> ByteString -payloadForSig BinarySig state = fromPkt (lastLD state) ^. literalDataPayload -payloadForSig CanonicalTextSig state = payloadForSig BinarySig state +payloadForSig BinarySig state = + case (fromPktEither (lastLD state) :: Either String LiteralData) of + Right ld -> ld ^. literalDataPayload + Left err -> error ("payloadForSig expected literal data packet: " ++ err) +payloadForSig CanonicalTextSig state = + stripTrailingWhitespacePerLine (canonicalizeLineEndings (payloadForSig BinarySig state)) payloadForSig StandaloneSig _ = BL.empty payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) @@ -127,7 +194,7 @@ payloadForSig CasualCert state = payloadForSig GenericCert state payloadForSig PositiveCert state = payloadForSig GenericCert state payloadForSig SubkeyBindingSig state = - kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well + kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig SignatureDirectlyOnAKey state = @@ -137,8 +204,47 @@ payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state = - kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures -payloadForSig st _ = error ("I dunno how to " ++ show st) + -- RFC 9580 §5.2.1: 0x30 revokes a UID certification when a UID/UAt is in + -- scope, but when there is no UID/UAt in scope it revokes a direct-key sig + -- (0x1F) and the payload is just the primary key material. + case lastUIDorUAt state of + UserIdPkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) + UserAttributePkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) + _ -> runPut (putKeyforSigning (lastPrimaryKey state)) +payloadForSig st _ = error ("payloadForSig: unhandled signature type " ++ show st) + +-- | Like 'payloadForSig' but accepts an explicit 'TextNormalizationMode' +-- that controls whether trailing whitespace is stripped for CanonicalTextSig. +-- +-- Use 'RFC9580Strict' for inline type 0x01 document signatures. +-- Use 'CleartextCompat' (or 'payloadForSig') for cleartext-armored messages. +payloadForSigWith :: TextNormalizationMode -> SigType -> PktStreamContext -> ByteString +payloadForSigWith RFC9580Strict CanonicalTextSig state = + canonicalizeLineEndings (payloadForSig BinarySig state) +payloadForSigWith _ st state = payloadForSig st state + +canonicalizeLineEndings :: ByteString -> ByteString +canonicalizeLineEndings = BL.pack . go . BL.unpack + where + go [] = [] + go (0x0d:0x0a:rest) = 0x0d : 0x0a : go rest + go (0x0d:rest) = 0x0d : 0x0a : go rest + go (0x0a:rest) = 0x0d : 0x0a : go rest + go (w:rest) = w : go rest + +stripTrailingWhitespacePerLine :: ByteString -> ByteString +stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack + where + go lineRev [] = reverseTrimmed lineRev + go lineRev (0x0d:0x0a:rest) = + reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest + go lineRev (w:rest) = go (w : lineRev) rest + + reverseTrimmed :: [Word8] -> [Word8] + reverseTrimmed = reverse . dropWhile isTrailingWhitespace + + isTrailingWhitespace :: Word8 -> Bool + isTrailingWhitespace w = w == 0x20 || w == 0x09 kandUPayload :: Pkt -> Pkt -> ByteString kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) diff --git a/Codec/Encryption/OpenPGP/SignatureQualities.hs b/Codec/Encryption/OpenPGP/SignatureQualities.hs --- a/Codec/Encryption/OpenPGP/SignatureQualities.hs +++ b/Codec/Encryption/OpenPGP/SignatureQualities.hs @@ -1,12 +1,18 @@ --- SignatureQualities.hs: OpenPGP (RFC4880) signature qualities --- Copyright © 2012-2019 Clint Adams +-- SignatureQualities.hs: OpenPGP (RFC9580) signature qualities +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + module Codec.Encryption.OpenPGP.SignatureQualities ( sigType , sigPKA , sigHA , sigCT + , signatureSubpacketListsKnown + , signatureHashedSubpacketsKnown ) where import Data.List (find) @@ -14,25 +20,70 @@ import Codec.Encryption.OpenPGP.Ontology (isSigCreationTime) import Codec.Encryption.OpenPGP.Types +data KnownSignaturePayload where + KnownSignaturePayloadV3 :: SignaturePayloadV 'SigPayloadV3 -> KnownSignaturePayload + KnownSignaturePayloadV4 :: SignaturePayloadV 'SigPayloadV4 -> KnownSignaturePayload + KnownSignaturePayloadV6 :: SignaturePayloadV 'SigPayloadV6 -> KnownSignaturePayload + +knownSignaturePayload :: SignaturePayload -> Maybe KnownSignaturePayload +knownSignaturePayload sig = + case toSomeSignaturePayload sig of + SomeSignaturePayload (payload@SigPayloadV3Data {}) -> + Just (KnownSignaturePayloadV3 payload) + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (KnownSignaturePayloadV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (KnownSignaturePayloadV6 payload) + SomeSignaturePayload (SigPayloadOtherData _ _) -> Nothing + sigType :: SignaturePayload -> Maybe SigType -sigType (SigV3 st _ _ _ _ _ _) = Just st -sigType (SigV4 st _ _ _ _ _ _) = Just st -sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild +sigType sig = + case knownSignaturePayload sig of + Just (KnownSignaturePayloadV3 (SigPayloadV3Data st _ _ _ _ _ _)) -> Just st + Just (KnownSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) -> Just st + Just (KnownSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) -> Just st + Nothing -> Nothing sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm -sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka -sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka -sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild +sigPKA sig = + case knownSignaturePayload sig of + Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ pka _ _ _)) -> Just pka + Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ pka _ _ _ _ _)) -> Just pka + Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ pka _ _ _ _ _ _)) -> Just pka + Nothing -> Nothing sigHA :: SignaturePayload -> Maybe HashAlgorithm -sigHA (SigV3 _ _ _ _ ha _ _) = Just ha -sigHA (SigV4 _ _ ha _ _ _ _) = Just ha -sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild +sigHA sig = + case knownSignaturePayload sig of + Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ _ ha _ _)) -> Just ha + Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ ha _ _ _ _)) -> Just ha + Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ ha _ _ _ _ _)) -> Just ha + Nothing -> Nothing sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp -sigCT (SigV3 _ ct _ _ _ _ _) = Just ct -sigCT (SigV4 _ _ _ hsubs _ _ _) = - fmap - (\(SigSubPacket _ (SigCreationTime i)) -> i) - (find isSigCreationTime hsubs) -sigCT _ = Nothing +sigCT sig = + case knownSignaturePayload sig of + Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ ct _ _ _ _ _)) -> Just ct + Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) -> + fmap + (\(SigSubPacket _ (SigCreationTime i)) -> i) + (find isSigCreationTime hsubs) + Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) -> + fmap + (\(SigSubPacket _ (SigCreationTime i)) -> i) + (find isSigCreationTime hsubs) + Nothing -> Nothing + +signatureSubpacketListsKnown :: + SignaturePayload -> Maybe ([SigSubPacket], [SigSubPacket]) +signatureSubpacketListsKnown sigPayload = + case knownSignaturePayload sigPayload of + Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hashed unhashed _ _)) -> + Just (hashed, unhashed) + Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hashed unhashed _ _)) -> + Just (hashed, unhashed) + _ -> Nothing + +signatureHashedSubpacketsKnown :: SignaturePayload -> Maybe [SigSubPacket] +signatureHashedSubpacketsKnown sigPayload = + fst <$> signatureSubpacketListsKnown sigPayload 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 @@ -1,486 +1,1755 @@ --- Signatures.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2020 Clint Adams --- This software is released under the terms of the Expat license. --- (See the LICENSE file). -module Codec.Encryption.OpenPGP.Signatures - ( verifySigWith - , verifyAgainstKeyring - , verifyAgainstKeys - , verifyTKWith - , signUserIDwithRSA - , crossSignSubkeyWithRSA - , signDataWithRSA - ) where - -import Control.Applicative ((<|>)) -import Control.Error.Util (hush) -import Control.Lens ((^.), _1) -import Control.Monad (liftM2) - -import Crypto.Error (eitherCryptoError) -import Crypto.Hash (hashWith) -import qualified Crypto.Hash.Algorithms as CHA -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import qualified Crypto.PubKey.RSA.Types as RSATypes - -import Data.Bifunctor (first) -import Data.Binary.Put (runPut) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import Data.Either (isRight, lefts, rights) -import Data.Function (on) -import Data.IxSet.Typed ((@=)) -import qualified Data.IxSet.Typed as IxSet -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Data.Time.Clock (UTCTime(..), diffUTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) - -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal - ( PktStreamContext(..) - , emptyPSC - , issuer - , issuerFP - ) -import Codec.Encryption.OpenPGP.Ontology - ( isRevocationKeySSP - , isRevokerP - , isSubkeyBindingSig - , isSubkeyRevocation - ) - -import Codec.Encryption.OpenPGP.SerializeForSigs - ( payloadForSig - , putKeyforSigning - , putPartialSigforSigning - , putSigTrailer - , putUforSigning - ) -import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Keyring.Instances () - -verifySigWith :: - (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification) - -> Pkt - -> PktStreamContext - -> Maybe UTCTime - -> Either String Verification -- FIXME: check expiration here? -verifySigWith vf sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do - v <- vf sig mt (payloadForSig st state) - mapM_ (checkI (v ^. verificationSigner) . _sspPayload) hs - return v - where - checkI s i@Issuer {} = checkIssuer (eightOctetKeyID s) i - checkI s i@IssuerFingerprint {} = checkIssuerFP (fingerprint s) i - checkI _ _ = Right True - checkIssuer :: - Either String EightOctetKeyId - -> SigSubPacketPayload - -> Either String Bool - checkIssuer (Right signer) (Issuer i) = - if signer == i - then Right True - else Left "issuer subpacket does not match" - checkIssuer (Left err) (Issuer _) = - Left $ "issuer subpacket cannot be checked (" ++ err ++ ")" - checkIssuer _ _ = Right True - checkIssuerFP :: - TwentyOctetFingerprint -> SigSubPacketPayload -> Either String Bool - checkIssuerFP signer (IssuerFingerprint _ i) = - if signer == i - then Right True - else Left "issuer fingerprint subpacket does not match" - checkIssuerFP _ _ = Right True -verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)." - -verifyTKWith :: - (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification) - -> Maybe UTCTime - -> TK - -> Either String TK -verifyTKWith vsf mt key = do - revokers <- checkRevokers key - revs <- checkKeyRevocations revokers key - let uids = filter (not . null . snd) . checkUidSigs $ key ^. tkUIDs -- FIXME: check revocations here? - let uats = filter (not . null . snd) . checkUAtSigs $ key ^. tkUAts -- FIXME: check revocations here? - let subs = concatMap checkSub $ key ^. tkSubs -- FIXME: check revocations here? - return (TK (key ^. tkKey) revs uids uats subs) - where - checkRevokers = - Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkRevs - checkKeyRevocations :: - [(PubKeyAlgorithm, TwentyOctetFingerprint)] - -> TK - -> Either String [SignaturePayload] - checkKeyRevocations rs k = - Prelude.sequence . concatMap (filterRevs rs) . rights . - map (liftM2 fmap (,) vSig) $ - k ^. - tkRevs - checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] - checkUidSigs = - map - (\(uid, sps) -> - (uid, (rights . map (\sp -> fmap (const sp) (vUid (uid, sp)))) sps)) - checkUAtSigs :: - [([UserAttrSubPacket], [SignaturePayload])] - -> [([UserAttrSubPacket], [SignaturePayload])] - checkUAtSigs = - map - (\(uat, sps) -> - (uat, (rights . map (\sp -> fmap (const sp) (vUAt (uat, sp)))) sps)) - checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])] - checkSub (pkt, sps) = - if revokedSub pkt sps - then [] - else checkSub' pkt sps - revokedSub :: Pkt -> [SignaturePayload] -> Bool - revokedSub _ [] = False - revokedSub p sigs = any (vSubSig p) (filter isSubkeyRevocation sigs) - checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])] - checkSub' p sps = - let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps) - in if null goodsigs - then [] - else [(p, goodsigs)] - getHasheds (SigV4 _ _ _ ha _ _ _) = ha - getHasheds _ = [] - filterRevs :: - [(PubKeyAlgorithm, TwentyOctetFingerprint)] - -> (SignaturePayload, Verification) - -> [Either String SignaturePayload] - filterRevs vokers spv = - case spv of - (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s] - (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> - if (v ^. verificationSigner == key ^. tkKey . _1) || - any - (\(p, f) -> - p == pka && f == fingerprint (v ^. verificationSigner)) - vokers - then [Left "Key revoked"] - else [Right s] - _ -> [] - vUid :: (Text, SignaturePayload) -> Either String Verification - vUid (uid, sp) = - vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1) - , lastUIDorUAt = UserIdPkt uid - } - mt - vUAt :: - ([UserAttrSubPacket], SignaturePayload) -> Either String Verification - vUAt (uat, sp) = - vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1) - , lastUIDorUAt = UserAttributePkt uat - } - mt - vSig :: SignaturePayload -> Either String Verification - vSig sp = - vsf - (SignaturePkt sp) - emptyPSC {lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)} - mt - vSubSig :: Pkt -> SignaturePayload -> Bool - vSubSig sk sp = - isRight - (vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1) - , lastSubkey = sk - } - mt) - verifyRevoker :: - SignaturePayload - -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)] - verifyRevoker sp = do - _ <- vSig sp - return - (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . - filter isRevocationKeySSP $ - getHasheds sp) - -verifyAgainstKeyring :: - Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification -verifyAgainstKeyring kr sig mt payload = do - let ikeys = (kr @=) <$> issuer sig - ifpkeys = (kr @=) <$> issuerFP sig - keyset <- maybe (Left "issuer not found") Right (ifpkeys <|> ikeys) - potentialmatches <- - if IxSet.null keyset - then Left "pubkey not found" - else Right keyset - verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload - -verifyAgainstKeys :: - [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification -verifyAgainstKeys ks sig mt payload = do - let allrelevantpkps = - filter - (\x -> - (((fingerprint x ==) <$> issuerFP sig) == Just True) || - ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == - Just True) - (concatMap (\x -> (x ^. tkKey . _1) : map subPKP (_tkSubs x)) ks) - let results = - map - (\pkp -> - verifyAgainstKey' - pkp - sig - mt - payload) - allrelevantpkps - case rights results of - [] -> Left (concatMap (++ "/") (lefts results)) - [r] -> do - _ <- isSignatureExpired sig mt - return r - _ -> Left "multiple successes; unexpected condition" - where - subPKP (pack, _) = subPKP' pack - subPKP' (PublicSubkeyPkt p) = p - subPKP' (SecretSubkeyPkt p _) = p - subPKP' _ = error "This should never happen (subPKP')" - -verifyAgainstKey' :: - PKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification -verifyAgainstKey' pkp sig mt payload = do --- FIXME: check flags --- FIXME: check expiration time - r <- verify' - sig - pkp - (hashalgo sig) - (BL.toStrict (finalPayload sig payload)) --- FIXME: check signature hash against policy --- FIXME: check pka against policy - return (Verification r ((_signaturePayload . fromPkt) sig)) - where - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA1 pl = - verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) RIPEMD160 pl = - verify'' (pkaAndMPIs s) CHA.RIPEMD160 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA256 pl = - verify'' (pkaAndMPIs s) CHA.SHA256 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA384 pl = - verify'' (pkaAndMPIs s) CHA.SHA384 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA512 pl = - verify'' (pkaAndMPIs s) CHA.SHA512 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA224 pl = - verify'' (pkaAndMPIs s) CHA.SHA224 pub pkey pl - verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) DeprecatedMD5 pl = - verify'' (pkaAndMPIs s) CHA.MD5 pub pkey pl - verify' _ _ _ _ = error "This should never happen (verify')." - verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = - dsaVerify pub mpis hd pkey bs - verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = - ecdsaVerify pub mpis hd pkey bs - verify'' (EdDSA, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs = - ed25519Verify pub mpis hd (i2osp (unEPoint pkey)) bs - verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = - rsaVerify pub mpis hd pkey bs - verify'' _ _ _ _ _ = Left "unimplemented key type" - dsaVerify pub (r :| [s]) hd pkey bs = - if DSA.verify hd pkey (dsaMPIsToSig r s) bs - then Right pub - else Left ("DSA verification failed: " ++ show (hd, pkey, r, s, bs)) - dsaVerify _ _ _ _ _ = Left "cannot verify DSA signature of wrong shape" - ecdsaVerify pub (r :| [s]) hd pkey bs = - if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs - then Right pub - else Left ("ECDSA verification failed: " ++ show (hd, pkey, r, s, bs)) - ecdsaVerify _ _ _ _ _ = Left "cannot verify ECDSA signature of wrong shape" - ed25519Verify pub (r :| [s]) hd pkey bs = - either - (Left . - (("Ed25519 verification failed: " ++ show (hd, pkey, r, s, bs) ++ ": ") ++) . - show) - return $ do - ep <- cf2es (Ed25519.publicKey (B.drop 1 pkey)) -- drop the 0x40 - es <- cf2es (Ed25519.signature ((B.append `on` i2osp . unMPI) r s)) - let prehash = crazyHash hd bs :: B.ByteString - if Ed25519.verify ep prehash es - then Right pub - else Left "does not verify" - ed25519Verify _ _ _ _ _ = - Left "cannot verify Ed25519 signature of wrong shape" - cf2es = either (Left . show) return . eitherCryptoError - rsaVerify pub mpis hd pkey bs = - if P15.verify (Just hd) pkey bs (rsaMPItoSig mpis) - then Right pub - else Left ("DSA verification failed: " ++ show (hd, pkey, mpis, bs)) - dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s) - ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s) - rsaMPItoSig (s :| []) = i2osp (unMPI s) - hashalgo :: Pkt -> HashAlgorithm - hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha - hashalgo _ = error "This should never happen (hashalgo)." - pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka, mpis) - pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)." - crazyHash h = BA.convert . hashWith h - -isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool -isSignatureExpired _ Nothing = return False -isSignatureExpired s (Just t) = - if any - (expiredBefore t) - ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s) - then Left "signature expired" - else return True - where - expiredBefore :: UTCTime -> SigSubPacket -> Bool - expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = - fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < - 0 - expiredBefore _ _ = False - -finalPayload :: Pkt -> ByteString -> ByteString -finalPayload s pl = BL.concat [pl, sigbit, trailer s] - where - sigbit = runPut $ putPartialSigforSigning s - trailer :: Pkt -> ByteString - trailer (SignaturePkt SigV4 {}) = runPut $ putSigTrailer s - trailer _ = BL.empty - -signUserIDwithRSA :: - PKPayload -- ^ public key "payload" of user ID being signed - -> UserId -- ^ user ID being signed - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either String SignaturePayload -signUserIDwithRSA pkp uid hsigsubs usigsubs prv = do - uidsig <- - first - show - (P15.sign - Nothing - (Just CHA.SHA512) - prv - (BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload))) - return (uidsigp' uidsig) - where - uidpayload = - runPut - (sequence_ - [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]) - uidsigp = - SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0]) - uidsigp' us = - SigV4 - PositiveCert - RSA - SHA512 - hsigsubs - usigsubs - (fromIntegral (os2ip (B.take 2 us))) - (NE.fromList [MPI (os2ip us)]) - -crossSignSubkeyWithRSA :: - PKPayload -- ^ public key "payload" of key being signed - -> PKPayload -- ^ public subkey "payload" of key being signed - -> [SigSubPacket] -- ^ hashed signature subpackets for binding sig - -> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig - -> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig - -> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig - -> RSATypes.PrivateKey -- ^ RSA signing key - -> RSATypes.PrivateKey -- ^ RSA signing subkey - -> Either String SignaturePayload -crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do - embsig <- - first - show - (P15.sign - Nothing - (Just CHA.SHA512) - ssb - (BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload))) - subsig <- - first - show - (P15.sign - Nothing - (Just CHA.SHA512) - prv - (BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload))) - return (subsigp' (embsigp' embsig) subsig) - where - subkeypayload = - runPut - (sequence_ - [ putKeyforSigning (PublicKeyPkt pkp) - , putKeyforSigning (PublicSubkeyPkt subpkp) - ]) - embsigp = - SigV4 - PrimaryKeyBindingSig - RSA - SHA512 - embhsigsubs - embusigsubs - 0 - (NE.fromList [MPI 0]) - embsigp' es = - SigV4 - PrimaryKeyBindingSig - RSA - SHA512 - embhsigsubs - embusigsubs - (fromIntegral (os2ip (B.take 2 es))) - (NE.fromList [MPI (os2ip es)]) - subsigp = - SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0]) - sspes es = SigSubPacket False (EmbeddedSignature es) - subsigp' es ss = - SigV4 - SubkeyBindingSig - RSA - SHA512 - subhsigsubs - (sspes es : subusigsubs) - (fromIntegral (os2ip (B.take 2 ss))) - (NE.fromList [MPI (os2ip ss)]) - -signDataWithRSA :: - SigType - -> RSATypes.PrivateKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either String SignaturePayload -signDataWithRSA st prv has uhas payload = - sp st <$> - first - show - (P15.sign - Nothing - (Just CHA.SHA512) - prv - (BL.toStrict (finalPayload (SignaturePkt (sp0 st)) payload))) - where - sp0 st = SigV4 st RSA SHA512 has [] 0 (NE.fromList [MPI 0]) - sp st ss = - SigV4 - st - RSA - SHA512 - has - uhas - (fromIntegral (os2ip (B.take 2 ss))) - (NE.fromList [MPI (os2ip ss)]) +-- Signatures.hs: OpenPGP (RFC9580) signature verification +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Codec.Encryption.OpenPGP.Signatures + ( SignError(..) + , renderSignError + , CertificationState(..) + , certificationStateAt + , VerificationError(..) + , renderVerificationError + , verifySigWith + , verifyAgainstKeyring + , verifyAgainstKeys + , verifyTKWith + , verifyUnknownTKWith + , signCertificationWithRSA + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + , signSubkeyRevocationWithRSA + , signCertRevocationWithRSA + , signUserIDwithRSA + , crossSignSubkeyWithRSA + , signDataWithEd25519 + , signDataWithEd25519V6 + , signDataWithEd448 + , signDataWithEd448V6 + , signDataWithRSA + , signDataWithRSAV6 + -- * Builder-based API (Phase 2) + , signDataWithRSABuilder + , signDataWithRSAV6Builder + , signDataWithEd25519Builder + , signDataWithEd25519V6Builder + , signDataWithEd448Builder + , signDataWithEd448V6Builder + , signDataWithAlgorithmicBuilder + -- * Text normalization mode + , TextNormalizationMode(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Error.Util (hush) +import Control.Lens ((&), (^.), _1) +import Control.Monad (liftM2, when) + +import Crypto.Error (eitherCryptoError) +import Crypto.Hash (hashWith) +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import qualified Crypto.PubKey.RSA.Types as RSATypes + +import Data.Bifunctor (first) +import Data.Binary.Put (runPut) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Either (isRight, lefts, rights) +import Data.Function (on) +import Data.IxSet.Typed ((@=)) +import qualified Data.IxSet.Typed as IxSet +import qualified Data.Set as Set +import Data.List (find, intercalate, nub) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime(..), addUTCTime, diffUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word16, Word8) +import GHC.TypeLits (TypeError, ErrorMessage(..)) + +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Expirations + ( isPKTimeValidWithSelfSignatures + , keyStateAt + , keyStateValid + ) +import Codec.Encryption.OpenPGP.Internal + ( PktStreamContext(..) + , emptyPSC + , issuer + , issuerFP + ) +import Codec.Encryption.OpenPGP.Ontology + ( isCertRevocationSig + , isRevocationKeySSP + , isRevokerP + , isSubkeyBindingSig + , isSubkeyRevocation + ) +import Codec.Encryption.OpenPGP.SignatureQualities + ( sigCT + , sigHA + , sigPKA + , sigType + , signatureHashedSubpacketsKnown + , signatureSubpacketListsKnown + ) + +import Codec.Encryption.OpenPGP.SerializeForSigs + ( payloadForSig + , putKeyforSigning + , putPartialSigforSigning + , putSigTrailer + , putUforSigning + ) +import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) +import Codec.Encryption.OpenPGP.Subpackets + ( SigBuilder + , TextNormalizationMode(..) + , sbSigType + , sbHashAlgo + , sbHashedSubs + , sbUnhashedSubs + , sbSalt + , sbTextNormMode + , PrivateKeyFor + ) +import qualified Codec.Encryption.OpenPGP.Subpackets as SP +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +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] + | InvalidSubkeyBackSignature VerificationError + -- ^ An embedded primary-key back-signature (type 0x19) in a subkey + -- binding signature failed to verify. + 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 "; " (nub (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 ++ + ")" + +verificationError :: VerificationError -> Either VerificationError a +verificationError = Left + +renderVerificationResult :: Either VerificationError a -> Either String a +renderVerificationResult = first renderVerificationError + +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 SignatureDirectlyOnAKey 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 + VerifiableSignatureV6 :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV + +fromSignaturePayloadVerifiableSignatureV :: + SignaturePayload -> Maybe VerifiableSignatureV +fromSignaturePayloadVerifiableSignatureV sigPayload = + case toSomeSignaturePayload sigPayload of + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (VerifiableSignatureV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (VerifiableSignatureV6 payload) + _ -> Nothing + +isVerifiableSignaturePayload :: SignaturePayload -> Bool +isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV + +toSignaturePayloadFromVerifiable :: VerifiableSignatureV -> SignaturePayload +toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) = + toSignaturePayload payload +toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) = + toSignaturePayload payload + +fromPktEitherVerifiableSignatureV :: Pkt -> Either VerificationError VerifiableSignatureV +fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) = + case fromSignaturePayloadVerifiableSignatureV sigPayload of + Just verifiableSig -> Right verifiableSig + Nothing -> + verificationError UnexpectedSignaturePayloadShape +fromPktEitherVerifiableSignatureV _ = + verificationError NonSignaturePacket + +signaturePKAAndMPIsFromClass :: + SomeSignatureV + -> Either VerificationError (PubKeyAlgorithm, NonEmpty MPI) +signaturePKAAndMPIsFromClass = + fmap (\(pka, _, mpis) -> (pka, mpis)) . signatureVerificationMaterialFromClass + +signatureLeft16FromClass :: SomeSignatureV -> Either VerificationError Word16 +signatureLeft16FromClass = + fmap (\(_, l16, _) -> l16) . signatureVerificationMaterialFromClass + +signatureVerificationMaterialFromClass :: + SomeSignatureV + -> Either VerificationError (PubKeyAlgorithm, Word16, NonEmpty MPI) +signatureVerificationMaterialFromClass (SomeSignatureV typedSig) = + case typedSig of + SignatureV3Packet (SigPayloadV3Data _ _ _ pka _ l16 mpis) -> + Right (pka, l16, mpis) + SignatureV4Packet (SigPayloadV4Data _ pka _ _ _ l16 mpis) -> + Right (pka, l16, mpis) + SignatureV6Packet (SigPayloadV6Data _ pka _ _ _ _ l16 mpis) -> + Right (pka, l16, mpis) + _ -> + verificationError UnexpectedSignaturePayloadShape + +verifySigWith :: + (Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification) + -> Pkt + -> PktStreamContext + -> Maybe UTCTime + -> Either VerificationError Verification +verifySigWith vf sig@(SignaturePkt _) state mt = + case fromPktEitherVerifiableSignatureV sig of + Right verifiableSig -> + let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) = + verifiableSignatureVerificationInputs verifiableSig + in checkUnhashedSubpackets us *> + verifyWithSubpacketChecks vf sig state mt st hs checkSubpacket + Left err -> + Left err + where + checkV4Subpacket signer i@Issuer {} = checkIssuerSubpacket (eightOctetKeyID signer) i + checkV4Subpacket signer i@IssuerFingerprint {} = + checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV4 (fingerprint signer) i + checkV4Subpacket _ _ = Right True + -- RFC 9580 §5.2.3.35: v6 signatures MUST NOT include an Issuer Key ID subpacket. + -- Treat any such subpacket as a verification error rather than merely uncheckable. + checkV6Subpacket _ Issuer {} = + verificationError IssuerKeyIdProhibitedInV6Signature + checkV6Subpacket signer i@IssuerFingerprint {} = + checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV6 (fingerprint signer) i + checkV6Subpacket _ _ = Right True + rejectV6UnhashedIssuer (SigSubPacket _ Issuer {}) = + verificationError IssuerKeyIdProhibitedInV6Signature + rejectV6UnhashedIssuer _ = Right () + verifiableSignatureVerificationInputs :: + VerifiableSignatureV + -> + ( SigType + , [SigSubPacket] + , [SigSubPacket] + , SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool + , [SigSubPacket] -> Either VerificationError () + ) + verifiableSignatureVerificationInputs + (VerifiableSignatureV4 (SigPayloadV4Data st _ _ hs us _ _)) = + (st, hs, us, checkV4Subpacket, const (Right ())) + verifiableSignatureVerificationInputs + (VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) = + (st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer) +verifySigWith _ _ _ _ = + verificationError NonSignaturePacket + +verifyWithSubpacketChecks :: + (Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification) + -> Pkt + -> PktStreamContext + -> Maybe UTCTime + -> SigType + -> [SigSubPacket] + -> (SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool) + -> Either VerificationError Verification +verifyWithSubpacketChecks vf sig state mt sigType hashedSubpackets checkSubpacket = do + mapM_ (rejectUnsupportedCriticalSubpacket sigType) hashedSubpackets + v <- vf sig mt (payloadForSig sigType state) + mapM_ (checkSubpacket (v ^. verificationSigner) . _sspPayload) hashedSubpackets + warnings <- + if sigType == SubkeyBindingSig + then verifySubkeyBackSignatures state mt hashedSubpackets + else Right [] + isSignatureExpired sig mt *> + pure + (v + { _verificationWarnings = + _verificationWarnings v ++ warnings + }) + +-- | Verify embedded primary-key back-signatures (PrimaryKeyBindingSig, 0x19) +-- found in the hashed subpackets of a SubkeyBindingSig. +-- +-- Per RFC 9580 §5.2.3.3, a signing-capable subkey MUST include an embedded +-- PrimaryKeyBindingSig (0x19) made by the subkey. This requirement is +-- enforced strictly for v6 subkeys. For v4 subkeys we still verify any +-- embedded back-sigs that are present, but do not reject a missing one — +-- real-world v4 signing subkeys predate the strict cross-certification +-- mandate and widespread interoperability requires accepting them. +verifySubkeyBackSignatures :: + PktStreamContext + -> Maybe UTCTime + -> [SigSubPacket] + -> Either VerificationError [VerificationWarning] +verifySubkeyBackSignatures state mt hashedSubpackets = do + subkeyPKP <- + maybe + (verificationError NonSignaturePacket) + Right + (subkeyPKPFromPkt (lastSubkey state)) + let embeddedSigs = + [ sp + | SigSubPacket _ (EmbeddedSignature sp) <- hashedSubpackets + ] + isSigningCapable = + any + (\(SigSubPacket _ payload) -> + case payload of + KeyFlags flags -> SignDataKey `Set.member` flags + _ -> False) + hashedSubpackets + isV6Subkey = _keyVersion subkeyPKP == V6 + case embeddedSigs of + [] -> + -- Require back-sig only for v6 signing subkeys (RFC 9580 §5.2.3.3). + if isSigningCapable && isV6Subkey + then Right [MissingSubkeyBackSignatureWarning] + else Right [] + _ -> + -- Always verify back-sigs that are present, regardless of key version. + mapM_ (verifyOneBackSig subkeyPKP) embeddedSigs *> Right [] + where + verifyOneBackSig subkeyPKP embSigPayload = do + let embSigPkt = SignaturePkt embSigPayload + backSigContext = + emptyPSC + { lastPrimaryKey = lastPrimaryKey state + , lastSubkey = lastSubkey state + } + case verifyAgainstKey' subkeyPKP embSigPkt mt + (payloadForSig PrimaryKeyBindingSig backSigContext) of + Left err -> verificationError (InvalidSubkeyBackSignature err) + Right _ -> Right () + +rejectUnsupportedCriticalSubpacket :: SigType -> SigSubPacket -> Either VerificationError () +rejectUnsupportedCriticalSubpacket sigType (SigSubPacket isCritical payload) + | not isCritical = Right () + | not (isBindingSignatureType sigType) = Right () + | otherwise = + case payload of + UserDefinedSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType) + OtherSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType) + _ -> Right () + +isBindingSignatureType :: SigType -> Bool +isBindingSignatureType SubkeyBindingSig = True +isBindingSignatureType PrimaryKeyBindingSig = True +isBindingSignatureType _ = False + +checkIssuerSubpacket :: + Either String EightOctetKeyId + -> SigSubPacketPayload + -> Either VerificationError Bool +checkIssuerSubpacket (Right signer) (Issuer i) + | signer == i = Right True + | otherwise = verificationError IssuerSubpacketMismatch +checkIssuerSubpacket (Left err) (Issuer _) = + verificationError (IssuerSubpacketUncheckable err) +checkIssuerSubpacket _ _ = Right True + +checkIssuerFingerprintSubpacket :: + IssuerFingerprintVersion -> Fingerprint -> SigSubPacketPayload -> Either VerificationError Bool +checkIssuerFingerprintSubpacket expectedVersion signer (IssuerFingerprint kv i) + | kv /= expectedVersion = verificationError IssuerFingerprintSubpacketMismatch + | signer == i = Right True + | otherwise = verificationError IssuerFingerprintSubpacketMismatch +checkIssuerFingerprintSubpacket _ _ _ = Right True + +verifyTKWith :: + (Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification) + -> Maybe UTCTime + -> TK k + -> Either VerificationError (TK k) +verifyTKWith vsf mt tk = do + verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk) + let typedSubkeys = Map.fromList [ (keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs ] + verifiedTypedSubkeys = + mapMaybe + (\(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys) + (verifiedUnknown ^. tkuSubs) + pure + TK + { _tkPrimaryKey = tk ^. tkPrimaryKey + , _tkRevs = verifiedUnknown ^. tkuRevs + , _tkUIDs = verifiedUnknown ^. tkuUIDs + , _tkUAts = verifiedUnknown ^. tkuUAts + , _tkSubs = verifiedTypedSubkeys + } + +verifyUnknownTKWith :: + (Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification) + -> Maybe UTCTime + -> TKUnknown + -> Either VerificationError TKUnknown +verifyUnknownTKWith vsf mt tk = do + revokers <- checkRevokers tk + revs <- checkKeyRevocations revokers tk + let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs + let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts + let subs = concatMap checkSub $ tk ^. tkuSubs + return (TKUnknown (tk ^. tkuKey) revs uids uats subs) + where + checkRevokers = + Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkuRevs + checkKeyRevocations :: + [(PubKeyAlgorithm, Fingerprint)] + -> TKUnknown + -> Either VerificationError [SignaturePayload] + checkKeyRevocations rs k = + Prelude.sequence . concatMap (filterRevs rs) . rights . + map (liftM2 fmap (,) vSig) $ + k ^. + tkuRevs + checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] + checkUidSigs = + map + (\(uid, sps) -> + let verified = rights . map (\sp -> fmap ((,) sp) (vUid (uid, sp))) $ sps + in (uid, retainNonRevokedCertifications mt verified)) + checkUAtSigs :: + [([UserAttrSubPacket], [SignaturePayload])] + -> [([UserAttrSubPacket], [SignaturePayload])] + checkUAtSigs = + map + (\(uat, sps) -> + let verified = rights . map (\sp -> fmap ((,) sp) (vUAt (uat, sp))) $ sps + in (uat, retainNonRevokedCertifications mt verified)) + checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])] + checkSub (pkt, sps) = + if revokedSub pkt sps + then [] + else checkSub' pkt sps + revokedSub :: Pkt -> [SignaturePayload] -> Bool + revokedSub _ [] = False + revokedSub p sigs = + any (vSubSig p) (filter subkeyRevocationEffective sigs) + checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])] + checkSub' p sps = + let goodsigs = + filter (vSubSig p) . + filter signatureKnown . + filter isSubkeyBindingSig $ + sps + in if null goodsigs + then [] + else [(p, goodsigs)] + getHasheds = signatureHashedSubpackets + filterRevs :: + [(PubKeyAlgorithm, Fingerprint)] + -> (SignaturePayload, Verification) + -> [Either VerificationError SignaturePayload] + filterRevs vokers spv = + case spv of + (s, _) + | isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey -> + [Right s | signatureKnown s] + (s, v) + | isV4OrV6Sig s + , sigType s == Just KeyRevocationSig + , Just pka <- sigPKA s -> + if (v ^. verificationSigner == tk ^. tkuKey . _1) || + any + (\(p, f) -> + p == pka && f == fingerprint (v ^. verificationSigner)) + vokers + then + if keyRevocationEffective s + then [verificationError KeyRevoked] + else [Right s | signatureKnown s] + else [Right s | signatureKnown s] + _ -> [] + isV4OrV6Sig = isVerifiableSignaturePayload + vUid :: (Text, SignaturePayload) -> Either VerificationError Verification + vUid (uid, sp) = + vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastUIDorUAt = UserIdPkt uid + } + Nothing + vUAt :: + ([UserAttrSubPacket], SignaturePayload) -> Either VerificationError Verification + vUAt (uat, sp) = + vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastUIDorUAt = UserAttributePkt uat + } + Nothing + vSig :: SignaturePayload -> Either VerificationError Verification + vSig sp = + vsf + (SignaturePkt sp) + emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)} + Nothing + vSubSig :: Pkt -> SignaturePayload -> Bool + vSubSig sk sp = + isRight + (vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastSubkey = sk + } + mt) + verifyRevoker :: + SignaturePayload + -> Either VerificationError [(PubKeyAlgorithm, Fingerprint)] + verifyRevoker sp = + vSig sp *> + pure + (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . + filter isRevocationKeySSP $ + getHasheds sp) + retainNonRevokedCertifications :: + Maybe UTCTime -> [(SignaturePayload, Verification)] -> [SignaturePayload] + retainNonRevokedCertifications validationTime verified = + map fst $ + filter + ((== CertificationActive) . certificationStateAt validationTime verified) + certifications + where + certifications = filter (not . isCertRevocationSig . fst) verified + signatureKnown = signatureKnownAt mt + subkeyRevocationEffective sp = isSubkeyRevocation sp && signatureEffectiveAt mt sp + keyRevocationEffective sp + | isHistoricalKeyRevocation sp = signatureEffectiveAt mt sp + | otherwise = signatureUnexpiredAt mt sp + +verifyAgainstKeyring :: + PublicKeyring -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification +verifyAgainstKeyring kr sig mt payload = do + let allKeys = map tkToUnknown (IxSet.toList kr) + signerValidationTime = signatureCreationTimeFromPacket sig + ikeys = (kr @=) <$> issuer sig + ifpkeys = (kr @=) <$> issuerFP sig + hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys) + hintedResult = + if null hintedKeys + then Left MissingIssuer + else verifyFromCandidates allKeys hintedKeys sig signerValidationTime mt payload + in case hintedResult of + Right v -> Right v + Left hintedErr -> + let fallbackResult = + verifyFromCandidates allKeys allKeys sig signerValidationTime mt payload + in if null hintedKeys + then + case fallbackResult of + Right v -> Right v + Left _ -> + verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig)) + else + case fallbackResult of + Right v -> Right v + Left _ -> Left hintedErr + +verifyFromCandidates :: + [TKUnknown] + -> [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyFromCandidates allKeys candidateTks sig signerValidationTime verificationTime payload = + let candidateResults = + map + (resolveCandidateSignerPKPs allKeys sig signerValidationTime (const True)) + candidateTks + candidateErrors = concatMap fst candidateResults + usablePkps = concatMap snd candidateResults + in if null usablePkps + then + if null candidateErrors + then verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig)) + else verificationError (CandidateKeyFailures candidateErrors) + else + case verifyAgainstPKPs usablePkps sig verificationTime payload of + Left (CandidateKeyFailures errs) + | not (null candidateErrors) -> + verificationError (CandidateKeyFailures (candidateErrors ++ errs)) + other -> other + +verifyAgainstKeys :: + [TKUnknown] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification +verifyAgainstKeys ks sig mt payload = do + let allpkps = + filter + (\x -> + (((fingerprint x ==) <$> issuerFP sig) == Just True) || + ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == + Just True) + (concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks) + allCandidatePkps = + concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks + normalizedCandidates + | null allpkps = allCandidatePkps + | otherwise = allpkps + verifyAgainstPKPs normalizedCandidates sig mt payload + +verifyAgainstPKPs :: + [SomePKPayload] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification +verifyAgainstPKPs pkps sig mt payload = + case rights results of + [] -> verificationError (CandidateKeyFailures (lefts results)) + [r] -> isSignatureExpired sig mt *> pure r + rs -> verificationError (MultipleVerificationSuccesses (length rs)) + where + results = map (\pkp -> verifyAgainstKey' pkp sig mt payload) pkps + +resolveCandidateSignerPKPs :: + [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> (SomePKPayload -> Bool) + -> TKUnknown + -> ([VerificationError], [SomePKPayload]) +resolveCandidateSignerPKPs _ _ Nothing matchesP tk = + ([], filter matchesP (candidatePKPs tk)) +resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = + let rawMatches = filter matchesP (candidatePKPs tk) + in case verifyUnknownTKWith (verifySigWith (verifyAgainstKeys allKeys)) (Just validationTime) tk of + Left err -> (replicate (length rawMatches) err, []) + Right verifiedTK -> + let verifiedMatches = + map + (\pkp -> + case historicallyValidSigner validationTime (timelineValidationTK pkp verifiedTK) pkp of + Right () -> Right pkp + Left err -> Left err) + rawMatches + in (lefts verifiedMatches, rights verifiedMatches) + where + timelineValidationTK pkp verifiedTK' + | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk + | otherwise = verifiedTK' + +candidatePKPs :: TKUnknown -> [SomePKPayload] +candidatePKPs tk = (tk ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs) + +historicallyValidSigner :: + UTCTime -> TKUnknown -> SomePKPayload -> Either VerificationError () +historicallyValidSigner validationTime tk pkp + | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = + if keyStateValid (keyStateAt validationTime tk) + then Right () + else verificationError SigningKeyUnavailableAtSignatureTime + | otherwise = + case find (\(pkt, _) -> maybe False ((== fingerprint pkp) . fingerprint) (subkeyPKPFromPkt pkt)) (tk ^. tkuSubs) of + Nothing -> verificationError SigningKeyUnavailableAtSignatureTime + Just (subPkt, sigs) -> + case subkeyPKPFromPkt subPkt of + Nothing -> verificationError SigningKeyUnavailableAtSignatureTime + Just subPKP -> + if isPKTimeValidWithSelfSignatures validationTime subPKP sigs + then Right () + else verificationError SigningKeyUnavailableAtSignatureTime + +signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime +signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload +signatureCreationTimeFromPacket _ = Nothing + +signatureCreationTime :: SignaturePayload -> Maybe UTCTime +signatureCreationTime = + fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT + +signatureKnownAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureKnownAt Nothing _ = True +signatureKnownAt (Just validationTime) sigPayload = + maybe False (<= validationTime) (signatureCreationTime sigPayload) + +signatureEffectiveAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureEffectiveAt Nothing _ = True +signatureEffectiveAt (Just validationTime) sigPayload = + signatureKnownAt (Just validationTime) sigPayload && + maybe True (validationTime <) (signatureExpirationTime sigPayload) + +signatureUnexpiredAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureUnexpiredAt Nothing _ = True +signatureUnexpiredAt (Just validationTime) sigPayload = + maybe True (validationTime <) (signatureExpirationTime sigPayload) + +signatureExpirationTime :: SignaturePayload -> Maybe UTCTime +signatureExpirationTime sigPayload = + addDurationToTime <$> + signatureCreationTime sigPayload <*> + signatureExpirationDuration sigPayload + +signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration +signatureExpirationDuration sigPayload = + signatureHashedSubpacketsKnown sigPayload >>= firstSignatureExpirationDuration + +firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration +firstSignatureExpirationDuration = + foldr + (\subpacket acc -> + case subpacket of + SigSubPacket _ (SigExpirationTime duration) -> Just duration + _ -> acc) + Nothing + +addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime +addDurationToTime baseTime duration = + addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime + +certificationStateAt :: + Maybe UTCTime + -> [(SignaturePayload, Verification)] + -> (SignaturePayload, Verification) + -> CertificationState +certificationStateAt validationTime verified certification@(certificationSig, _) + | not (signatureKnownAt validationTime certificationSig) = CertificationNotYetKnown + | not (signatureEffectiveAt validationTime certificationSig) = CertificationRevoked + | any (`revokesCertification` certification) visibleRevocations = CertificationRevoked + | otherwise = CertificationActive + where + visibleRevocations = + filter + (signatureEffectiveAt validationTime . fst) + (filter (isCertRevocationSig . fst) verified) + +revokesCertification :: + (SignaturePayload, Verification) + -> (SignaturePayload, Verification) + -> Bool +revokesCertification (revocationSig, revocationVerification) (certificationSig, certificationVerification) = + sameSigner && certificationPrecedesRevocation certificationSig revocationSig + where + sameSigner = + fingerprint (revocationVerification ^. verificationSigner) == + fingerprint (certificationVerification ^. verificationSigner) + +certificationPrecedesRevocation :: + SignaturePayload -> SignaturePayload -> Bool +certificationPrecedesRevocation certificationSig revocationSig = + case (signatureCreationTime certificationSig, signatureCreationTime revocationSig) of + (Just certificationTime, Just revocationTime) -> + certificationTime < revocationTime + _ -> False + +isHistoricalKeyRevocation :: SignaturePayload -> Bool +isHistoricalKeyRevocation sigPayload = + case revocationReasonCode sigPayload of + Just KeySuperseded -> True + Just KeyRetiredAndNoLongerUsed -> True + Just UserIdInfoNoLongerValid -> True + _ -> False + +revocationReasonCode :: SignaturePayload -> Maybe RevocationCode +revocationReasonCode sigPayload = + (\(SigSubPacket _ (ReasonForRevocation reasonCode _)) -> reasonCode) <$> + find isReasonForRevocation (signatureSubpackets sigPayload) + where + isReasonForRevocation (SigSubPacket _ ReasonForRevocation {}) = True + isReasonForRevocation _ = False + +signatureSubpackets :: SignaturePayload -> [SigSubPacket] +signatureSubpackets sigPayload = + case signatureSubpacketListsKnown sigPayload of + Just (hashed, unhashed) -> hashed ++ unhashed + Nothing -> [] + +signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] +signatureHashedSubpackets sigPayload = + maybe [] id (signatureHashedSubpacketsKnown sigPayload) + +subkeyPKPFromPkt :: Pkt -> Maybe SomePKPayload +subkeyPKPFromPkt (PublicSubkeyPkt p) = Just p +subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p +subkeyPKPFromPkt _ = Nothing + +verifyAgainstKey' :: SomePKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification +verifyAgainstKey' pkp sig mt payload = do + sigClass <- + either + (verificationError . const NonSignaturePacket) + Right + (fromPktEitherSomeSignatureV sig) + let sigPayload = + case sigClass of + SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig + sigHash <- + maybe + (verificationError MissingHashAlgorithm) + Right + (sigHA sigPayload) + sigDetails <- signaturePKAAndMPIsFromClass sigClass + enforcePKACompatibility sigPayload + enforceSignatureHashPolicy sigHash + _ <- isSignatureExpired sig mt + let signedPayload = BL.toStrict (finalPayload sig payload) + enforceLeft16Prefix sigClass sigHash signedPayload + (\verifiedSigner -> Verification verifiedSigner sigPayload []) <$> + verify' sigDetails pkp sigHash signedPayload + where + enforcePKACompatibility sigPayload = + let sigPka = maybe (OtherPKA 0) id (sigPKA sigPayload) + keyPka = _pkalgo pkp + in if pkaCompatible sigPka keyPka + then Right () + else verificationError (SignaturePolicyPKAMismatch sigPka keyPka) + enforceSignatureHashPolicy sigHash = + case sigHash of + OtherHA {} -> verificationError (SignaturePolicyHashUnsupported sigHash) + _ -> Right () + enforceLeft16Prefix sigClass sigHash signedPayload = do + expectedLeft16 <- + either + (verificationError . HashComputationFailed) + Right + (left16FromSignedPayload sigHash signedPayload) + actualLeft16 <- signatureLeft16FromClass sigClass + if actualLeft16 == expectedLeft16 + then Right () + else + verificationError + (SignatureMismatch (_pkalgo pkp) (fingerprint pkp)) + pkaCompatible RSA keyPka = + keyPka `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] + pkaCompatible DeprecatedRSASignOnly keyPka = + keyPka `elem` [RSA, DeprecatedRSASignOnly] + pkaCompatible PKA.EdDSA keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448] + pkaCompatible PKA.Ed25519 keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed25519] + pkaCompatible PKA.Ed448 keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed448] + pkaCompatible sigPka keyPka = sigPka == keyPka + verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl = + verifyByHash details pub pkey ha pl + verify' details pub@(PKPayload V6 _ _ _ pkey) ha pl = + verifyByHash details pub pkey ha pl + verify' _ _ _ _ = + verificationError UnexpectedKeyVersion + verifyByHash details pub pkey ha pl = + case ha of + SHA1 -> verify'' details CHA.SHA1 pub pkey pl + RIPEMD160 -> verify'' details CHA.RIPEMD160 pub pkey pl + SHA224 -> verify'' details CHA.SHA224 pub pkey pl + SHA256 -> verify'' details CHA.SHA256 pub pkey pl + SHA384 -> verify'' details CHA.SHA384 pub pkey pl + SHA512 -> verify'' details CHA.SHA512 pub pkey pl + SHA3_256 -> verifyNoRSA SHA3_256 details CHA.SHA3_256 pub pkey pl + SHA3_512 -> verifyNoRSA SHA3_512 details CHA.SHA3_512 pub pkey pl + DeprecatedMD5 -> verify'' details CHA.MD5 pub pkey pl + _ -> + verificationError (SignaturePolicyHashUnsupported ha) + verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = + dsaVerify pub mpis hd pkey bs + verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = + ecdsaVerify pub mpis hd pkey bs + verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed25519] = + ed25519Verify sigPka pub mpis hd pkey bs + verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed448] = + ed448Verify sigPka pub mpis hd pkey bs + verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = + rsaVerify pub mpis hd pkey bs + verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) + verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = + dsaVerify pub mpis hd pkey bs + verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = + ecdsaVerify pub mpis hd pkey bs + verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed25519] = + ed25519Verify sigPka pub mpis hd pkey bs + verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed448] = + ed448Verify sigPka pub mpis hd pkey bs + verifyNoRSA ha' (RSA, _) _ _ _ _ = + verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA) + verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) + dsaVerify pub (r :| [s]) hd pkey bs = + if DSA.verify hd pkey (dsaMPIsToSig r s) bs + then Right pub + else verificationError (SignatureMismatch DSA (fingerprint pub)) + dsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch DSA) + ecdsaVerify pub (r :| [s]) hd pkey bs = + if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs + then Right pub + else verificationError (SignatureMismatch ECDSA (fingerprint pub)) + ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA) + ed25519Verify sigPka pub (r :| [s]) hd pkey bs = + case edPointToRawPublic 32 pkey of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right rawPub -> + case cf2es (Ed25519.publicKey rawPub) of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right ep -> + case cf2es (Ed25519.signature (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s)))) of + Left err -> + verificationError (SignatureEncodingInvalid 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)) + ed25519Verify sigPka _ _ _ _ _ = + verificationError (SignatureShapeMismatch sigPka) + ed448Verify sigPka pub (r :| [s]) hd pkey bs = + case edPointToRawPublic 57 pkey of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right rawPub -> + case cf2es (Ed448.publicKey rawPub) of + Left err -> + verificationError (SignatureEncodingInvalid 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) + 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)) + ed448Verify sigPka _ _ _ _ _ = + verificationError (SignatureShapeMismatch sigPka) + edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) = + exactLengthPublic expectedLen "native" (i2osp x) + edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do + 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" + 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)) + pad32 bs = + let l = B.length bs + in if l >= 32 + then bs + else B.replicate (32 - l) 0 <> bs + padN n bs = + let l = B.length bs + in if l >= n + then bs + else B.replicate (n - l) 0 <> bs + cf2es = either (Left . show) return . eitherCryptoError + rsaVerify pub mpis hd pkey bs = + if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis) + then Right pub + else verificationError (SignatureMismatch RSA (fingerprint pub)) + dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s) + ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s) + rsaMPItoSig pkey (s :| []) = + let sz = RSATypes.public_size pkey + raw = i2osp (unMPI s) + pad = sz - B.length raw + in B.replicate pad 0 <> raw + crazyHash h = BA.convert . hashWith h + +isSignatureExpired :: Pkt -> Maybe UTCTime -> Either VerificationError Bool +isSignatureExpired _ Nothing = return False +isSignatureExpired s (Just t) = + do + sigClass <- + either + (verificationError . const NonSignaturePacket) + Right + (fromPktEitherSomeSignatureV s) + if any + (expiredBefore t) + (signatureHashedSubpackets + (case sigClass of + SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig)) + then verificationError SignatureExpired + else return True + where + expiredBefore :: UTCTime -> SigSubPacket -> Bool + expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = + fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < + 0 + expiredBefore _ _ = False + +finalPayload :: Pkt -> ByteString -> ByteString +finalPayload s pl = BL.concat [pl, sigbit, trailer s] + where + sigbit = runPut $ putPartialSigforSigning s + trailer :: Pkt -> ByteString + trailer (SignaturePkt sigPayload) = + maybe + BL.empty + (const (runPut $ putSigTrailer s)) + (fromSignaturePayloadVerifiableSignatureV sigPayload) + trailer _ = BL.empty + +normalizePayloadForSigType :: SigType -> ByteString -> ByteString +normalizePayloadForSigType CanonicalTextSig = + stripTrailingWhitespacePerLine . canonicalizeLineEndings +normalizePayloadForSigType _ = id + +normalizePayloadForSigTypeWith :: TextNormalizationMode -> SigType -> ByteString -> ByteString +normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st +normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings +normalizePayloadForSigTypeWith RFC9580Strict _ = id + +canonicalizeLineEndings :: ByteString -> ByteString +canonicalizeLineEndings = BL.pack . go . BL.unpack + where + go [] = [] + go (0x0d:0x0a:rest) = 0x0d : 0x0a : go rest + go (0x0d:rest) = 0x0d : 0x0a : go rest + go (0x0a:rest) = 0x0d : 0x0a : go rest + go (w:rest) = w : go rest + +stripTrailingWhitespacePerLine :: ByteString -> ByteString +stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack + where + go lineRev [] = reverseTrimmed lineRev + go lineRev (0x0d:0x0a:rest) = + reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest + go lineRev (w:rest) = go (w : lineRev) rest + + reverseTrimmed :: [Word8] -> [Word8] + reverseTrimmed = reverse . dropWhile isTrailingWhitespace + + isTrailingWhitespace :: Word8 -> Bool + isTrailingWhitespace w = w == 0x20 || w == 0x09 + +hashWithSHA512 :: B.ByteString -> B.ByteString +hashWithSHA512 = BA.convert . hashWith CHA.SHA512 + +hashForSignatureAlgorithm :: HashAlgorithm -> B.ByteString -> Either String B.ByteString +hashForSignatureAlgorithm ha bs = + case ha of + SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs)) + RIPEMD160 -> Right (BA.convert (hashWith CHA.RIPEMD160 bs)) + SHA224 -> Right (BA.convert (hashWith CHA.SHA224 bs)) + SHA256 -> Right (BA.convert (hashWith CHA.SHA256 bs)) + SHA384 -> Right (BA.convert (hashWith CHA.SHA384 bs)) + SHA512 -> Right (BA.convert (hashWith CHA.SHA512 bs)) + 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) + +left16FromHashPrefix :: B.ByteString -> Either String Word16 +left16FromHashPrefix bs + | B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs))) + | otherwise = Left "hash output too short to derive left16" + +left16FromSignedPayload :: HashAlgorithm -> B.ByteString -> Either String Word16 +left16FromSignedPayload ha signedPayload = do + digest <- hashForSignatureAlgorithm ha signedPayload + left16FromHashPrefix digest + +left16FromSignedPayloadForSign :: HashAlgorithm -> B.ByteString -> Either SignError Word16 +left16FromSignedPayloadForSign ha = + first SignBackendError . left16FromSignedPayload ha + +ed25519Signer :: Ed25519.SecretKey -> B.ByteString -> B.ByteString +ed25519Signer sk prehash = + BA.convert (Ed25519.sign sk (Ed25519.toPublic sk) prehash) + +ed448Signer :: Ed448.SecretKey -> B.ByteString -> B.ByteString +ed448Signer sk prehash = + BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash) + +rsaPKCS15Sign :: + HashAlgorithm + -> RSATypes.PrivateKey + -> B.ByteString + -> Either SignError B.ByteString +rsaPKCS15Sign ha prv bytes = + case ha of + SHA1 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA1) prv bytes) + SHA224 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA224) prv bytes) + SHA256 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA256) prv bytes) + SHA384 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA384) prv bytes) + SHA512 -> first (SignBackendError . show) (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)) + +validateV6SaltSize :: HashAlgorithm -> SignatureSalt -> Either SignError () +validateV6SaltSize ha salt = + let saltBytes = BL.toStrict (unSignatureSalt salt) + actualSaltLen = B.length saltBytes + in case signatureV6SaltSizeForHashAlgorithm ha of + Nothing -> + Left + (SignBackendError + ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) + Just expectedSaltLen -> + if actualSaltLen == fromIntegral expectedSaltLen + then Right () + else Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen) + +signEdDSAV4 :: + String + -> Int + -> Int + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload = do + let normalizedPayload = normalizePayloadForSigTypeWith mode st payload + sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0]) + prehash = + hashWithSHA512 + (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) + sigBytes = signer prehash + if B.length sigBytes /= sigLen + then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes)) + else + let (r, s) = B.splitAt limbLen sigBytes + in (\left16 -> + SigV4 + st + pka + ha + has + uhas + left16 + (NE.fromList [MPI (os2ip r), MPI (os2ip s)])) + <$> first SignBackendError (left16FromHashPrefix prehash) + +signEdDSAV6 :: + String + -> Int + -> Int + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload = do + validateV6SaltSize ha salt + let normalizedPayload = normalizePayloadForSigTypeWith mode st payload + sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0]) + prehash = + hashWithSHA512 + (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) + sigBytes = signer prehash + if B.length sigBytes /= sigLen + then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes)) + else + let (r, s) = B.splitAt limbLen sigBytes + in (\left16 -> + SigV6 + st + pka + ha + salt + has + uhas + left16 + (NE.fromList [MPI (os2ip r), MPI (os2ip s)])) + <$> first SignBackendError (left16FromHashPrefix prehash) + +signUserIDwithRSA :: SomePKPayload -- ^ public key "payload" of user ID being signed + -> UserId -- ^ user ID being signed + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signUserIDwithRSA = signCertificationWithRSA PositiveCert + +signCertificationWithRSA :: + SigType -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert) + -> SomePKPayload -- ^ public key "payload" of user ID being signed + -> UserId -- ^ user ID being signed + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signCertificationWithRSA st pkp uid hsigsubs usigsubs prv + | st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do + let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload) + uidsigp' + <$> left16FromSignedPayloadForSign SHA512 payloadToSign + <*> first + (SignBackendError . show) + (P15.sign + Nothing + (Just CHA.SHA512) + prv + payloadToSign) + | otherwise = + Left (SignUnsupportedCertificationType st) + where + uidpayload = + runPut + (sequence_ + [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]) + uidsigp = + SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0]) + uidsigp' left16 us = + SigV4 + st + RSA + SHA512 + hsigsubs + usigsubs + left16 + (NE.fromList [MPI (os2ip us)]) + +signDirectKeyWithRSA :: + SigType -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig) + -> SomePKPayload -- ^ primary key "payload" being signed + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signDirectKeyWithRSA st pkp hsigsubs usigsubs prv + | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] = + signDataWithRSA st prv hsigsubs usigsubs keypayload + | otherwise = + Left (SignUnsupportedKeySignatureType st) + where + keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) + +signKeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" being revoked + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig + +signSubkeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" + -> SomePKPayload -- ^ public subkey "payload" being revoked + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv = + signDataWithRSA SubkeyRevocationSig prv hsigsubs usigsubs subkeypayload + where + subkeypayload = + runPut + (sequence_ + [ putKeyforSigning (PublicKeyPkt pkp) + , putKeyforSigning (PublicSubkeyPkt subpkp) + ]) + +signCertRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" + -> UserId -- ^ user ID certification being revoked + -> [SigSubPacket] -- ^ hashed signature subpackets + -> [SigSubPacket] -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey -- ^ RSA signing key + -> Either SignError SignaturePayload +signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv = + signDataWithRSA CertRevocationSig prv hsigsubs usigsubs certpayload + where + certpayload = + runPut + (sequence_ + [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]) + +crossSignSubkeyWithRSA :: SomePKPayload -- ^ public key "payload" of key being signed + -> SomePKPayload -- ^ public subkey "payload" of key being signed + -> [SigSubPacket] -- ^ hashed signature subpackets for binding sig + -> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig + -> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig + -> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig + -> RSATypes.PrivateKey -- ^ RSA signing key + -> RSATypes.PrivateKey -- ^ RSA signing subkey + -> Either SignError SignaturePayload +crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do + let embPayloadToSign = BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload) + subPayloadToSign = BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload) + (\embleft16 subleft16 embsig subsig -> + subsigp' (embsigp' embleft16 embsig) subleft16 subsig) + <$> left16FromSignedPayloadForSign SHA512 embPayloadToSign + <*> left16FromSignedPayloadForSign SHA512 subPayloadToSign + <*> first + (SignBackendError . show) + (P15.sign + Nothing + (Just CHA.SHA512) + ssb + embPayloadToSign) + <*> first + (SignBackendError . show) + (P15.sign + Nothing + (Just CHA.SHA512) + prv + subPayloadToSign) + where + subkeypayload = + runPut + (sequence_ + [ putKeyforSigning (PublicKeyPkt pkp) + , putKeyforSigning (PublicSubkeyPkt subpkp) + ]) + embsigp = + SigV4 + PrimaryKeyBindingSig + RSA + SHA512 + embhsigsubs + embusigsubs + 0 + (NE.fromList [MPI 0]) + embsigp' left16 es = + SigV4 + PrimaryKeyBindingSig + RSA + SHA512 + embhsigsubs + embusigsubs + left16 + (NE.fromList [MPI (os2ip es)]) + subsigp = + SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0]) + sspes es = SigSubPacket False (EmbeddedSignature es) + subsigp' es left16 ss = + SigV4 + SubkeyBindingSig + RSA + SHA512 + subhsigsubs + (sspes es : subusigsubs) + left16 + (NE.fromList [MPI (os2ip ss)]) + +signRSAV4Core :: + TextNormalizationMode + -> SigType + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signRSAV4Core mode st ha has uhas prv payload = + (\left16 ss -> SigV4 st RSA ha has uhas left16 (NE.fromList [MPI (os2ip ss)])) + <$> left16FromSignedPayloadForSign ha payloadToSign + <*> rsaPKCS15Sign ha prv payloadToSign + where + sig0 = SigV4 st RSA ha has [] 0 (NE.fromList [MPI 0]) + payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload)) + +signRSAV6Core :: + TextNormalizationMode + -> SigType + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signRSAV6Core mode st ha salt has uhas prv payload = do + validateV6SaltSize ha salt + (\left16 sigBytes -> SigV6 st RSA ha salt has uhas left16 (NE.fromList [MPI (os2ip sigBytes)])) + <$> left16FromSignedPayloadForSign ha payloadToSign + <*> rsaPKCS15Sign ha prv payloadToSign + where + sig0 = SigV6 st RSA ha salt has [] 0 (NE.fromList [MPI 0]) + payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload)) + +signDataWithRSA :: + SigType + -> RSATypes.PrivateKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSA st prv has uhas payload = + signRSAV4Core CleartextCompat st SHA512 has uhas prv payload + +signDataWithRSAV6 :: + SigType + -> SignatureSalt + -> RSATypes.PrivateKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSAV6 st salt prv has uhas payload = + signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload + +ed25519Params :: (String, Int, Int, PubKeyAlgorithm) +ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519) + +ed448Params :: (String, Int, Int, PubKeyAlgorithm) +ed448Params = ("Ed448", 114, 57, PKA.Ed448) + +signDataWithEdDSAV4Generic :: + (String, Int, Int, PubKeyAlgorithm) + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> HashAlgorithm + -> SigType + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEdDSAV4Generic (algoName, sigLen, limbLen, pka) signer mode ha st has uhas payload = + signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload + +signDataWithEdDSAV6Generic :: + (String, Int, Int, PubKeyAlgorithm) + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> HashAlgorithm + -> SigType + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEdDSAV6Generic (algoName, sigLen, limbLen, pka) signer mode ha st salt has uhas payload = + signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload + +signDataWithEd25519 :: + SigType + -> Ed25519.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519 st sk has uhas payload = + signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st has uhas payload + +signDataWithEd25519V6 :: + SigType + -> SignatureSalt + -> Ed25519.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519V6 st salt sk has uhas payload = + signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st salt has uhas payload + +signDataWithEd448 :: + SigType + -> Ed448.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448 st sk has uhas payload = + signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st has uhas payload + +signDataWithEd448V6 :: + SigType + -> SignatureSalt + -> Ed448.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448V6 st salt sk has uhas payload = + signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st salt has uhas payload + +-- | Builder-based signature creation for RSA +-- +-- Example usage: +-- builder <- sigBuilderInit BinarySig RSA SHA512 +-- builder' <- addHashedSubs hashedSubpackets builder +-- builder'' <- addUnhashedSubs unhashedSubpackets builder' +-- sig <- signDataWithRSABuilder builder'' rsaPrivateKey payload +signDataWithRSABuilder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.RSA + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSABuilder builder prv payload = + signRSAV4Core + (sbTextNormMode builder) + (sbSigType builder) + (sbHashAlgo builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + prv + payload + +-- | Builder-based signature creation for RSA (v6) +signDataWithRSAV6Builder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.RSA + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSAV6Builder builder prv payload = + signRSAV6Core + (sbTextNormMode builder) + (sbSigType builder) + (sbHashAlgo builder) + (sbSalt builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + prv + payload + +-- | Builder-based signature creation for Ed25519 (v4) +-- +-- Example usage: +-- builder <- sigBuilderInit BinarySig Ed25519 SHA512 +-- builder' <- addHashedSubs hashedSubpackets builder +-- builder'' <- addUnhashedSubs unhashedSubpackets builder' +-- sig <- signDataWithEd25519Builder builder'' ed25519PrivateKey payload +signDataWithEd25519Builder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed25519 + -> Ed25519.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519Builder builder sk payload = + signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) + (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) + (sbHashedSubs builder) (sbUnhashedSubs builder) payload + +-- | Builder-based signature creation for Ed25519 (v6) +-- +-- Example usage: +-- builder <- sigBuilderInitV6 BinarySig Ed25519 SHA512 salt +-- builder' <- addHashedSubs hashedSubpackets builder +-- builder'' <- addUnhashedSubs unhashedSubpackets builder' +-- sig <- signDataWithEd25519V6Builder builder'' ed25519PrivateKey payload +signDataWithEd25519V6Builder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed25519 + -> Ed25519.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519V6Builder builder sk payload = + signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) + (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) + (sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload + +-- | Builder-based signature creation for Ed448 (v4) +-- +-- Example usage: +-- builder <- sigBuilderInit BinarySig Ed448 SHA512 +-- builder' <- addHashedSubs hashedSubpackets builder +-- builder'' <- addUnhashedSubs unhashedSubpackets builder' +-- sig <- signDataWithEd448Builder builder'' ed448PrivateKey payload +signDataWithEd448Builder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed448 + -> Ed448.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448Builder builder sk payload = + signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) + (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) + (sbHashedSubs builder) (sbUnhashedSubs builder) payload + +-- | Builder-based signature creation for Ed448 (v6) +signDataWithEd448V6Builder :: + SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed448 + -> Ed448.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448V6Builder builder sk payload = + signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) + (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) + (sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload + +-- | Algorithm-agnostic signature builder dispatcher (Phase 2) +-- +-- Dispatches to the appropriate signing function based on the private key type. +-- The private key type (PrivateKeyFor algo) encodes the algorithm at the type level, +-- allowing compile-time verification that the key and builder algorithm match. +-- +-- Example usage: +class BuilderSigningAlgorithm (algo :: PKA.PubKeyAlgorithm) where + signDataWithAlgorithmicBuilderImpl + :: SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo + -> PrivateKeyFor algo + -> ByteString + -> Either SignError SignaturePayload + +instance BuilderSigningAlgorithm 'PKA.RSA where + signDataWithAlgorithmicBuilderImpl builder (SP.RSAPrivateKey prv) payload = + signDataWithRSABuilder builder prv payload + +instance BuilderSigningAlgorithm 'PKA.Ed25519 where + signDataWithAlgorithmicBuilderImpl builder (SP.Ed25519PrivateKey sk) payload = + signDataWithEd25519Builder builder sk payload + +instance BuilderSigningAlgorithm 'PKA.Ed448 where + signDataWithAlgorithmicBuilderImpl builder (SP.Ed448PrivateKey sk) payload = + signDataWithEd448Builder builder sk payload + +-- | Catch-all instance that produces a compile-time error for any algorithm +-- that is not supported by the algorithmic builder (e.g. DSA, ECDSA). +instance {-# OVERLAPPABLE #-} + TypeError + ( 'Text "signDataWithAlgorithmicBuilder does not support this algorithm." + ':$$: 'Text "Supported algorithms: RSA, Ed25519, Ed448." + ':$$: 'Text "For DSA or ECDSA, use signDataWith{DSA,ECDSA}Builder directly." + ) + => BuilderSigningAlgorithm algo where + signDataWithAlgorithmicBuilderImpl = error "unreachable: TypeError fires at compile time" + +signDataWithAlgorithmicBuilder + :: forall (algo :: PKA.PubKeyAlgorithm) + . BuilderSigningAlgorithm algo + => SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo + -> PrivateKeyFor algo + -> ByteString + -> Either SignError SignaturePayload +signDataWithAlgorithmicBuilder = + signDataWithAlgorithmicBuilderImpl diff --git a/Codec/Encryption/OpenPGP/Subpackets.hs b/Codec/Encryption/OpenPGP/Subpackets.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Subpackets.hs @@ -0,0 +1,503 @@ +-- Subpackets.hs: Type-safe subpacket builders with phantom types +-- 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 #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Codec.Encryption.OpenPGP.Subpackets + ( -- * Safe subpacket construction + SafeSubpacket + , mkSafeSubpacket + , safePayload + , safeSubpacket + + -- * Critical subpacket handling + , CriticalSubpacket + , mkCritical + , canBeCritical + + -- * Text normalization mode + , TextNormalizationMode(..) + + -- * Builder API for signature composition + , SigBuilder + , LegalSubpacket(..) + , legalSubpacket + , singleLegalSub + , consLegalSub + , listToLegalSubs + , sbSigType + , sbPubKeyAlgo + , sbHashAlgo + , sbHashedSubs + , sbUnhashedSubs + , sbSalt + , sbTextNormMode + , buildSigV4 + , buildSigV6 + , sigBuilderInit + , sigBuilderInitTyped + , sigBuilderInitRuntime + , sigBuilderInitV6 + , sigBuilderInitV6Typed + , sigBuilderInitV6Runtime + , addHashedSubs + , addUnhashedSubs + , KnownPubKeyAlgorithm(..) + + -- * Private key wrapper (algorithm-specific) + , PrivateKeyFor(..) + + -- * Subpacket list utilities + , HashedSubpackets + , UnhashedSubpackets + , consHashedSub + , singleHashedSub + , singleUnhashedSub + , listToHashedSubs + , listToUnhashedSubs + ) where + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy(..)) +import Data.Word (Word16) + +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA.Types as RSATypes + +import Codec.Encryption.OpenPGP.Types + ( Hashed + , Unhashed + , V4Sig + , V6Sig + , Fingerprint + , EightOctetKeyId + , ThirtyTwoBitTimeStamp + , MPI + , SigSubPacket(..) + , SigSubPacketPayload(..) + , SignaturePayload(..) + , SignatureSalt + , SigType + , HashAlgorithm + , SubpacketList(..) + ) +import Codec.Encryption.OpenPGP.Types.Internal.Base + ( PubKeyAlgorithm(..) + , IssuerFingerprintVersion(..) + ) +import Codec.Encryption.OpenPGP.Policy + ( HashAlgoAllowedFor + , OpenPGPRFC + , OpenPGPRFCW(..) + , SomeOpenPGPRFCW(..) + , HashAlgorithmW(..) + , SomeHashAlgorithmW(..) + , promoteOpenPGPRFC + , promoteHashAlgorithm + , demoteHashAlgorithmW + , policyForRFC + , policyGenerationDeprecations + , deprecatedHashAlgorithms + ) + +-- | Type alias for readability: hashed subpacket list +type HashedSubpackets v = SubpacketList Hashed v + +-- | Type alias for readability: unhashed subpacket list +type UnhashedSubpackets v = SubpacketList Unhashed v + +-- | A subpacket that has passed basic safety checks +-- (does not guarantee it's critical-safe; use CriticalSubpacket for that) +newtype SafeSubpacket = SafeSubpacket SigSubPacket + deriving (Eq, Ord, Show) + +-- | Create a safe subpacket from a payload and criticality flag +-- Basic validation that the payload is well-formed +mkSafeSubpacket :: Bool -> SigSubPacketPayload -> Either String SafeSubpacket +mkSafeSubpacket crit payload = do + -- Validate criticality constraints: some subpackets should never be critical + if crit && not (canBeCritical payload) + then Left $ "Subpacket type cannot be marked critical: " ++ show payload + else Right (SafeSubpacket (SigSubPacket crit payload)) + +-- | Extract the payload from a safe subpacket +safePayload :: SafeSubpacket -> SigSubPacketPayload +safePayload (SafeSubpacket (SigSubPacket _ payload)) = payload + +-- | Extract the underlying SigSubPacket from a safe subpacket +safeSubpacket :: SafeSubpacket -> SigSubPacket +safeSubpacket (SafeSubpacket ssp) = ssp + +-- | A subpacket that is guaranteed to be both well-formed AND can be safely marked critical +-- Used to prevent accidentally marking non-critical-safe types as critical +newtype CriticalSubpacket = CriticalSubpacket SigSubPacket + deriving (Eq, Ord, Show) + +-- | Create a critical subpacket only if the payload type allows it +-- RFC9580 section 5.2.3.5: only certain subpacket types can be marked critical +mkCritical :: SigSubPacketPayload -> Either String CriticalSubpacket +mkCritical payload + | canBeCritical payload = Right $ CriticalSubpacket (SigSubPacket True payload) + | otherwise = Left $ "Cannot mark as critical: " ++ payloadType payload + where + payloadType (SigCreationTime _) = "SigCreationTime" + payloadType (SigExpirationTime _) = "SigExpirationTime" + payloadType (ExportableCertification _) = "ExportableCertification" + payloadType (TrustSignature {}) = "TrustSignature" + payloadType (RegularExpression _) = "RegularExpression" + payloadType (Revocable _) = "Revocable" + payloadType (KeyExpirationTime _) = "KeyExpirationTime" + payloadType (PreferredSymmetricAlgorithms _) = "PreferredSymmetricAlgorithms" + payloadType (RevocationKey {}) = "RevocationKey" + payloadType (Issuer _) = "Issuer" + payloadType (NotationData {}) = "NotationData" + payloadType (PreferredHashAlgorithms _) = "PreferredHashAlgorithms" + payloadType (PreferredCompressionAlgorithms _) = "PreferredCompressionAlgorithms" + payloadType (KeyServerPreferences _) = "KeyServerPreferences" + payloadType (PreferredKeyServer _) = "PreferredKeyServer" + payloadType (PrimaryUserId _) = "PrimaryUserId" + payloadType (PolicyURL _) = "PolicyURL" + payloadType (KeyFlags _) = "KeyFlags" + payloadType (SignersUserId _) = "SignersUserId" + payloadType (ReasonForRevocation {}) = "ReasonForRevocation" + payloadType (Features _) = "Features" + payloadType (SignatureTarget {}) = "SignatureTarget" + payloadType (EmbeddedSignature _) = "EmbeddedSignature" + payloadType (IssuerFingerprint {}) = "IssuerFingerprint" + payloadType (UserDefinedSigSub _ _) = "UserDefinedSigSub" + payloadType (OtherSigSub _ _) = "OtherSigSub" + +-- | RFC9580 §5.2.3.5 lists which subpacket types can be marked critical +canBeCritical :: SigSubPacketPayload -> Bool +canBeCritical KeyFlags {} = True +canBeCritical IssuerFingerprint {} = True +canBeCritical EmbeddedSignature {} = True +-- Future-proofing: unknown critical types are allowed to be critical +canBeCritical UserDefinedSigSub {} = True +canBeCritical OtherSigSub {} = True +canBeCritical _ = False + +-- | Wrapper GADT for algorithm-specific private keys +-- Encodes the algorithm at the type level to ensure type-safe key/builder matching +data PrivateKeyFor (algo :: PubKeyAlgorithm) where + RSAPrivateKey :: RSATypes.PrivateKey -> PrivateKeyFor 'RSA + Ed25519PrivateKey :: Ed25519.SecretKey -> PrivateKeyFor 'Ed25519 + Ed448PrivateKey :: Ed448.SecretKey -> PrivateKeyFor 'Ed448 + DSAPrivateKey :: DSA.PrivateKey -> PrivateKeyFor 'DSA + ECDSAPrivateKey :: ECDSA.PrivateKey -> PrivateKeyFor 'ECDSA + +class KnownPubKeyAlgorithm (algo :: PubKeyAlgorithm) where + demotePubKeyAlgorithmT :: Proxy algo -> PubKeyAlgorithm + +instance KnownPubKeyAlgorithm 'RSA where + demotePubKeyAlgorithmT _ = RSA + +instance KnownPubKeyAlgorithm 'DSA where + demotePubKeyAlgorithmT _ = DSA + +instance KnownPubKeyAlgorithm 'ECDSA where + demotePubKeyAlgorithmT _ = ECDSA + +instance KnownPubKeyAlgorithm 'EdDSA where + demotePubKeyAlgorithmT _ = EdDSA + +instance KnownPubKeyAlgorithm 'Ed25519 where + demotePubKeyAlgorithmT _ = Ed25519 + +instance KnownPubKeyAlgorithm 'Ed448 where + demotePubKeyAlgorithmT _ = Ed448 + +-- | Legal subpackets encoded by placement and signature-version constraints. +-- This expands compile-time legality beyond bare hashed/unhashed staging. +data LegalSubpacket (h :: Type) (v :: Type) where + -- RFC9580: signature creation time is a hashed subpacket. + LegalSigCreationTime :: ThirtyTwoBitTimeStamp -> LegalSubpacket Hashed v + -- v4 signatures use an issuer fingerprint subpacket with version marker 4 in hashed area. + LegalIssuerFingerprintV4 :: Fingerprint -> LegalSubpacket Hashed V4Sig + -- v6 signatures use an issuer fingerprint subpacket with version marker 6 in hashed area. + LegalIssuerFingerprintV6 :: Fingerprint -> LegalSubpacket Hashed V6Sig + -- Legacy issuer key ID subpacket is accepted only in v4 and only unhashed. + LegalIssuerV4 :: EightOctetKeyId -> LegalSubpacket Unhashed V4Sig + +legalSubpacket :: LegalSubpacket h v -> SigSubPacket +legalSubpacket (LegalSigCreationTime ts) = SigSubPacket False (SigCreationTime ts) +legalSubpacket (LegalIssuerFingerprintV4 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 fp) +legalSubpacket (LegalIssuerFingerprintV6 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 fp) +legalSubpacket (LegalIssuerV4 keyId) = SigSubPacket False (Issuer keyId) + +singleLegalSub :: LegalSubpacket h v -> SubpacketList h v +singleLegalSub = SubpacketList . (: []) . legalSubpacket + +consLegalSub :: LegalSubpacket h v -> SubpacketList h v -> SubpacketList h v +consLegalSub legal (SubpacketList sps) = SubpacketList (legalSubpacket legal : sps) + +listToLegalSubs :: [LegalSubpacket h v] -> SubpacketList h v +listToLegalSubs = SubpacketList . fmap legalSubpacket + +-- | Construct a single hashed subpacket into a hashed subpacket list +singleHashedSub :: SigSubPacket -> HashedSubpackets v +singleHashedSub sp = SubpacketList [sp] + +-- | Construct a single unhashed subpacket into an unhashed subpacket list +singleUnhashedSub :: SigSubPacket -> UnhashedSubpackets v +singleUnhashedSub sp = SubpacketList [sp] + +-- | Prepend a subpacket to a hashed subpacket list +consHashedSub :: SigSubPacket -> HashedSubpackets v -> HashedSubpackets v +consHashedSub sp (SubpacketList sps) = SubpacketList (sp : sps) + +-- | Controls how text payload is normalized for CanonicalTextSig. +-- +-- RFC 9580 §5.2.1.2 requires only CRLF normalization for type 0x01 +-- signatures. Trailing-whitespace stripping is only mandated by +-- §7 (Cleartext Signature Framework). Use 'CleartextCompat' for +-- GnuPG-compatible behaviour when producing cleartext-armored +-- signatures; use 'RFC9580Strict' for inline text signatures. +data TextNormalizationMode + = RFC9580Strict + -- ^ CRLF normalization only; no trailing-whitespace stripping. + -- Correct for inline type 0x01 document signatures. + | CleartextCompat + -- ^ CRLF normalization *plus* per-line trailing-whitespace stripping. + -- Required by the Cleartext Signature Framework (RFC 9580 §7). + deriving (Eq, Show) + +-- | Staged signature builder that enforces completion order +-- +-- Usage pattern: +-- builder <- sigBuilderInit SigTypeBinary RSA SHA256 +-- builder' <- addHashedSubs hashedList builder +-- finalPayload <- buildSigV4 sigMPIs (addUnhashedSubs unhashedList builder') +data SigBuilder (hashedness :: Type) (v :: Type) (algo :: PubKeyAlgorithm) = SigBuilder + { sbSigType :: SigType + , sbHashAlgo :: HashAlgorithm + , sbHashedSubs :: [SigSubPacket] + , sbUnhashedSubs :: [SigSubPacket] + , sbSalt :: BuilderSalt v + , sbTextNormMode :: TextNormalizationMode + -- ^ Normalization mode for CanonicalTextSig payloads. + -- Defaults to 'CleartextCompat' for backward compatibility. + } + +type family BuilderSalt (v :: Type) where + BuilderSalt V4Sig = () + BuilderSalt V6Sig = SignatureSalt + +sbPubKeyAlgo :: forall hashedness v algo. KnownPubKeyAlgorithm algo => SigBuilder hashedness v algo -> PubKeyAlgorithm +sbPubKeyAlgo _ = demotePubKeyAlgorithmT (Proxy @algo) + +-- | Initialize a builder for a v4 signature +-- Starts with no subpackets and must call addHashedSubs and addUnhashedSubs +sigBuilderInit :: + forall algo + . KnownPubKeyAlgorithm algo + => SigType + -> HashAlgorithm + -> SigBuilder Hashed V4Sig algo +sigBuilderInit st ha = SigBuilder + { sbSigType = st + , sbHashAlgo = ha + , sbHashedSubs = [] + , sbUnhashedSubs = [] + , sbSalt = () + , sbTextNormMode = CleartextCompat + } + +-- | Initialize a builder for a v4 signature with compile-time RFC/hash policy enforcement. +sigBuilderInitTyped :: + forall algo rfc h + . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h) + => OpenPGPRFCW rfc + -> SigType + -> HashAlgorithmW h + -> SigBuilder Hashed V4Sig algo +sigBuilderInitTyped _ st hashW = + sigBuilderInit @algo st (demoteHashAlgorithmW hashW) + +-- | Initialize a v4 builder from runtime RFC/hash inputs with policy validation +-- and witness promotion at the API boundary. +sigBuilderInitRuntime :: + forall algo + . KnownPubKeyAlgorithm algo + => OpenPGPRFC + -> SigType + -> HashAlgorithm + -> Either String (SigBuilder Hashed V4Sig algo) +sigBuilderInitRuntime rfc st ha = + withGenerationHashWitness + rfc + ha + (\rfcW hashW -> sigBuilderInitTyped @algo rfcW st hashW) + +-- | Initialize a builder for a v6 signature +sigBuilderInitV6 :: + forall algo + . KnownPubKeyAlgorithm algo + => SigType + -> HashAlgorithm + -> SignatureSalt + -> SigBuilder Hashed V6Sig algo +sigBuilderInitV6 st ha salt = SigBuilder + { sbSigType = st + , sbHashAlgo = ha + , sbHashedSubs = [] + , sbUnhashedSubs = [] + , sbSalt = salt + , sbTextNormMode = CleartextCompat + } + +-- | Initialize a builder for a v6 signature with compile-time RFC/hash policy enforcement. +sigBuilderInitV6Typed :: + forall algo rfc h + . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h) + => OpenPGPRFCW rfc + -> SigType + -> HashAlgorithmW h + -> SignatureSalt + -> SigBuilder Hashed V6Sig algo +sigBuilderInitV6Typed _ st hashW salt = + sigBuilderInitV6 @algo st (demoteHashAlgorithmW hashW) salt + +-- | Initialize a v6 builder from runtime RFC/hash inputs with policy validation +-- and witness promotion at the API boundary. +sigBuilderInitV6Runtime :: + forall algo + . KnownPubKeyAlgorithm algo + => OpenPGPRFC + -> SigType + -> HashAlgorithm + -> SignatureSalt + -> Either String (SigBuilder Hashed V6Sig algo) +sigBuilderInitV6Runtime rfc st ha salt = + withGenerationHashWitness + rfc + ha + (\rfcW hashW -> sigBuilderInitV6Typed @algo rfcW st hashW salt) + +withGenerationHashWitness :: + OpenPGPRFC + -> HashAlgorithm + -> (forall rfc h. HashAlgoAllowedFor rfc h => OpenPGPRFCW rfc -> HashAlgorithmW h -> a) + -> Either String a +withGenerationHashWitness rfc ha mk + | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations (policyForRFC rfc)) = + Left (hashPolicyDisallowedMessage rfc ha) + | otherwise = + case promoteHashAlgorithm ha of + Nothing -> + Left (hashNotTypedBuilderMessage ha) + Just (SomeHashAlgorithmW hashW) -> + case promoteOpenPGPRFC rfc of + SomeOpenPGPRFCW RFC2440W -> + Right $ + case hashW of + DeprecatedMD5W -> mk RFC2440W DeprecatedMD5W + SHA1W -> mk RFC2440W SHA1W + RIPEMD160W -> mk RFC2440W RIPEMD160W + SHA256W -> mk RFC2440W SHA256W + SHA384W -> mk RFC2440W SHA384W + SHA512W -> mk RFC2440W SHA512W + SHA224W -> mk RFC2440W SHA224W + SHA3_256W -> mk RFC2440W SHA3_256W + SHA3_512W -> mk RFC2440W SHA3_512W + SomeOpenPGPRFCW RFC4880W -> + case hashW of + SHA1W -> Right (mk RFC4880W SHA1W) + RIPEMD160W -> Right (mk RFC4880W RIPEMD160W) + SHA256W -> Right (mk RFC4880W SHA256W) + SHA384W -> Right (mk RFC4880W SHA384W) + SHA512W -> Right (mk RFC4880W SHA512W) + SHA224W -> Right (mk RFC4880W SHA224W) + SHA3_256W -> Right (mk RFC4880W SHA3_256W) + SHA3_512W -> Right (mk RFC4880W SHA3_512W) + DeprecatedMD5W -> + Left (hashPolicyDisallowedMessage rfc ha) + SomeOpenPGPRFCW RFC9580W -> + case hashW of + SHA256W -> Right (mk RFC9580W SHA256W) + SHA384W -> Right (mk RFC9580W SHA384W) + SHA512W -> Right (mk RFC9580W SHA512W) + SHA224W -> Right (mk RFC9580W SHA224W) + SHA3_256W -> Right (mk RFC9580W SHA3_256W) + SHA3_512W -> Right (mk RFC9580W SHA3_512W) + DeprecatedMD5W -> + Left (hashPolicyDisallowedMessage rfc ha) + SHA1W -> + Left (hashPolicyDisallowedMessage rfc ha) + RIPEMD160W -> + Left (hashPolicyDisallowedMessage rfc ha) + +hashPolicyDisallowedMessage :: OpenPGPRFC -> HashAlgorithm -> String +hashPolicyDisallowedMessage rfc ha = + "signature hash algorithm disallowed by RFC policy (" ++ show rfc ++ "): " ++ show ha + +hashNotTypedBuilderMessage :: HashAlgorithm -> String +hashNotTypedBuilderMessage ha = + "signature hash algorithm is not supported by typed builder API: " ++ show ha + +-- | Add hashed subpackets to a builder +-- Must be called before addUnhashedSubs +addHashedSubs :: HashedSubpackets v -> SigBuilder Hashed v algo -> SigBuilder Unhashed v algo +addHashedSubs (SubpacketList sps) builder = builder { sbHashedSubs = sps } + +-- | Add unhashed subpackets to a builder +-- Must be called after addHashedSubs +addUnhashedSubs :: UnhashedSubpackets v -> SigBuilder Unhashed v algo -> SigBuilder Unhashed v algo +addUnhashedSubs (SubpacketList sps) builder = builder { sbUnhashedSubs = sps } + +-- | Build a v4 signature from a completed builder and MPI values +buildSigV4 :: + KnownPubKeyAlgorithm algo + => SigBuilder Unhashed V4Sig algo + -> Word16 + -> NonEmpty MPI + -> SignaturePayload +buildSigV4 builder hashLeft mpis = SigV4 + (sbSigType builder) + (sbPubKeyAlgo builder) + (sbHashAlgo builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + hashLeft + mpis + +-- | Build a v6 signature from a completed builder and MPI values +buildSigV6 :: + KnownPubKeyAlgorithm algo + => SigBuilder Unhashed V6Sig algo + -> Word16 + -> NonEmpty MPI + -> SignaturePayload +buildSigV6 builder hashLeft mpis = + SigV6 + (sbSigType builder) + (sbPubKeyAlgo builder) + (sbHashAlgo builder) + (sbSalt builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + hashLeft + mpis + +-- | Convert a list to a hashed subpacket list +-- Used to bridge between list-based and phantom-typed APIs +listToHashedSubs :: [SigSubPacket] -> HashedSubpackets v +listToHashedSubs sps = SubpacketList sps + +-- | Convert a list to an unhashed subpacket list +-- Used to bridge between list-based and phantom-typed APIs +listToUnhashedSubs :: [SigSubPacket] -> UnhashedSubpackets v +listToUnhashedSubs sps = SubpacketList sps diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -1,12 +1,13 @@ --- Types.hs: OpenPGP (RFC4880) data types --- Copyright © 2012-2024 Clint Adams +-- Types.hs: OpenPGP (RFC9580) data types +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + module Codec.Encryption.OpenPGP.Types ( module X ) where -import Codec.Encryption.OpenPGP.Types.Internal.Base as X +import Codec.Encryption.OpenPGP.Types.Internal.Base as X hiding (Ed25519, Ed448) import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes as X import Codec.Encryption.OpenPGP.Types.Internal.PKITypes as X import Codec.Encryption.OpenPGP.Types.Internal.PacketClass as X 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 @@ -1,14 +1,20 @@ --- Base.hs: OpenPGP (RFC4880) data types --- Copyright © 2012-2022 Clint Adams +-- Base.hs: OpenPGP (RFC9580) data types +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.Base where @@ -20,11 +26,10 @@ import Control.Arrow ((***)) import Control.Lens (makeLenses, op, Wrapped) import Control.Monad (mzero) +import Data.Bits ((.&.)) import Data.Aeson ((.=), object) import qualified Data.Aeson as A -#if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as AK -#endif import qualified Data.Aeson.TH as ATH import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteString as B @@ -35,6 +40,8 @@ import Data.Char (toLower, toUpper) import Data.Data (Data) import Data.Hashable (Hashable(..)) +import Data.Int (Int64) +import Data.Kind (Type) import Data.List (unfoldr) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -53,6 +60,8 @@ import Network.URI (URI(..), nullURI, parseURI, uriToString) import Numeric (readHex) import Prettyprinter (Pretty(..), (<+>), hsep, punctuate, space) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import System.IO.Unsafe (unsafePerformIO) type Exportability = Bool @@ -82,6 +91,88 @@ type NestedFlag = Bool +-- | Phantom types for tracking subpacket classification and signature version +-- These types are never instantiated; they exist purely for compile-time type safety. + +-- | Phantom marker for hashed subpackets (included in signature hash computation) +data Hashed + +-- | Phantom marker for unhashed subpackets (not included in signature hash computation) +data Unhashed + +-- | Phantom marker for v4 signatures (8-octet issuer, no salt) +data V4Sig + +-- | Phantom marker for v6 signatures (fingerprint issuer, requires salt) +data V6Sig + +data ByteRange = + ByteRange + { _rangeOffset :: Int64 + , _rangeLength :: Int64 + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +newtype WireRepSourceId = + WireRepSourceId + { _unWireRepSourceId :: Int64 + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data WireRepRef = + WireRepRef + { _wireRepSourceId :: WireRepSourceId + , _wireRepLength :: Int64 + , _wireRepName :: Maybe Text + , _wireRepWasOriginallyArmored :: Bool + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +type WireRepRefs = NonEmpty WireRepRef + +wireRepRef :: ByteString -> WireRepRef +wireRepRef = mkWireRepRefWithLength Nothing False . BL.length + +namedWireRepRef :: Text -> ByteString -> WireRepRef +namedWireRepRef name = mkWireRepRefWithLength (Just name) False . BL.length + +mkWireRepRefWithLength :: + Maybe Text -> Bool -> Int64 -> WireRepRef +mkWireRepRefWithLength mname wasOriginallyArmored payloadLen = + WireRepRef + { _wireRepSourceId = freshWireRepSourceId payloadLen + , _wireRepLength = payloadLen + , _wireRepName = mname + , _wireRepWasOriginallyArmored = wasOriginallyArmored + } + +mkWireRepRef :: Maybe Text -> Bool -> ByteString -> WireRepRef +mkWireRepRef mname wasOriginallyArmored = + mkWireRepRefWithLength mname wasOriginallyArmored . BL.length + +wireRepSourceCounter :: IORef Int64 +wireRepSourceCounter = unsafePerformIO (newIORef 0) +{-# NOINLINE wireRepSourceCounter #-} + +freshWireRepSourceId :: Int64 -> WireRepSourceId +freshWireRepSourceId !_ = + unsafePerformIO $ + atomicModifyIORef' wireRepSourceCounter (\n -> let n' = n + 1 in (n', WireRepSourceId n')) +{-# NOINLINE freshWireRepSourceId #-} + +rangeEnd :: ByteRange -> Int64 +rangeEnd r = _rangeOffset r + _rangeLength r + +spanByteRanges :: [ByteRange] -> Maybe ByteRange +spanByteRanges [] = Nothing +spanByteRanges (r:rs) = + let start = minimum (_rangeOffset <$> (r : rs)) + ending = maximum (rangeEnd <$> (r : rs)) + in Just (ByteRange start (ending - start)) + +$(makeLenses ''ByteRange) +$(makeLenses ''WireRepRef) + class (Eq a, Ord a) => FutureFlag a where @@ -173,9 +264,16 @@ data NotationFlag = HumanReadable - | OtherNF Word8 -- FIXME: this should be constrained to 4 bits? + | OtherNF Word8 deriving (Data, Generic, Show, Typeable) +mkNotationFlag :: Word8 -> NotationFlag +mkNotationFlag o + | o' == 0 = HumanReadable + | otherwise = OtherNF o' + where + o' = o .&. 0x0f + instance Eq NotationFlag where (==) a b = fromFFlag a == fromFFlag b @@ -184,9 +282,9 @@ instance FutureFlag NotationFlag where fromFFlag HumanReadable = 0 - fromFFlag (OtherNF o) = fromIntegral o + fromFFlag (OtherNF o) = fromIntegral (o .&. 0x0f) toFFlag 0 = HumanReadable - toFFlag o = OtherNF (fromIntegral o) + toFFlag o = mkNotationFlag (fromIntegral o) instance Hashable NotationFlag @@ -259,9 +357,16 @@ data RevocationClass = SensitiveRK - | RClOther Word8 -- FIXME: this should be constrained to 3 bits + | RClOther Word8 deriving (Data, Generic, Show, Typeable) +mkRevocationClass :: Word8 -> RevocationClass +mkRevocationClass i + | i' == 1 = SensitiveRK + | otherwise = RClOther i' + where + i' = i .&. 0x07 + instance Eq RevocationClass where (==) a b = fromFFlag a == fromFFlag b @@ -270,9 +375,9 @@ instance FutureFlag RevocationClass where fromFFlag SensitiveRK = 1 - fromFFlag (RClOther i) = fromIntegral i + fromFFlag (RClOther i) = fromIntegral (i .&. 0x07) toFFlag 1 = SensitiveRK - toFFlag i = RClOther (fromIntegral i) + toFFlag i = mkRevocationClass (fromIntegral i) instance Hashable RevocationClass @@ -293,6 +398,10 @@ | ForbiddenElgamal | DH | EdDSA + | X25519 + | X448 + | Ed25519 + | Ed448 | OtherPKA Word8 deriving (Show, Data, Generic, Typeable) @@ -313,6 +422,10 @@ fromFVal ForbiddenElgamal = 20 fromFVal DH = 21 fromFVal EdDSA = 22 + fromFVal X25519 = 25 + fromFVal X448 = 26 + fromFVal Ed25519 = 27 + fromFVal Ed448 = 28 fromFVal (OtherPKA o) = o toFVal 1 = RSA toFVal 2 = DeprecatedRSAEncryptOnly @@ -324,6 +437,10 @@ toFVal 20 = ForbiddenElgamal toFVal 21 = DH toFVal 22 = EdDSA + toFVal 25 = X25519 + toFVal 26 = X448 + toFVal 27 = Ed25519 + toFVal 28 = Ed448 toFVal o = OtherPKA o instance Hashable PubKeyAlgorithm @@ -339,46 +456,49 @@ pretty ForbiddenElgamal = pretty "(forbidden) Elgamal" pretty DH = pretty "DH" pretty EdDSA = pretty "EdDSA" + pretty X25519 = pretty "X25519" + pretty X448 = pretty "X448" + pretty Ed25519 = pretty "Ed25519" + pretty Ed448 = pretty "Ed448" pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka $(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm) -newtype TwentyOctetFingerprint = - TwentyOctetFingerprint - { unTOF :: ByteString +-- | An OpenPGP fingerprint. Length depends on key version: +-- 16 bytes (v3/MD5), 20 bytes (v4/SHA-1), or 32 bytes (v6/SHA-256). +newtype Fingerprint = + Fingerprint + { unFingerprint :: ByteString } deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Wrapped TwentyOctetFingerprint +instance Wrapped Fingerprint --- FIXME: read-show -instance Read TwentyOctetFingerprint where - readsPrec _ = - map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) . - chunksOf 20 . hexToW8s . filter (/= ' ') +instance Read Fingerprint where + readsPrec _ s = + let ws = hexToW8s (filter (/= ' ') s) + in if null ws + then [] + else [(Fingerprint (BL.pack (map fst ws)), snd (last ws))] -instance Hashable TwentyOctetFingerprint +instance Hashable Fingerprint -instance Pretty TwentyOctetFingerprint where - pretty = pretty . take 40 . bsToHexUpper . unTOF +instance Pretty Fingerprint where + pretty = pretty . bsToHexUpper . unFingerprint -#if MIN_VERSION_aeson(2,0,0) key :: String -> AK.Key key = AK.fromText . T.pack -#else -key = T.pack -#endif -instance A.ToJSON TwentyOctetFingerprint where +instance A.ToJSON Fingerprint where toJSON e = object [key "fpr" .= (A.toJSON . show . pretty) e] -instance A.FromJSON TwentyOctetFingerprint where - parseJSON (A.Object v) = TwentyOctetFingerprint . read <$> v A..: key "fpr" +instance A.FromJSON Fingerprint where + parseJSON (A.Object v) = Fingerprint . read <$> v A..: key "fpr" parseJSON _ = mzero newtype SpacedFingerprint = SpacedFingerprint - { unSpacedFingerprint :: TwentyOctetFingerprint + { unSpacedFingerprint :: Fingerprint } deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -390,7 +510,7 @@ punctuate space . map hsep . chunksOf 5 . - map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . op SpacedFingerprint + map pretty . chunksOf 4 . bsToHexUpper . unFingerprint . op SpacedFingerprint bsToHexUpper :: ByteString -> String bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode @@ -402,14 +522,16 @@ EightOctetKeyId { unEOKI :: ByteString } - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Typeable) instance Wrapped EightOctetKeyId instance Pretty EightOctetKeyId where pretty = pretty . bsToHexUpper . op EightOctetKeyId --- FIXME: read-show +instance Show EightOctetKeyId where + show = bsToHexUpper . op EightOctetKeyId + instance Read EightOctetKeyId where readsPrec _ = map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s @@ -423,6 +545,30 @@ parseJSON (A.Object v) = EightOctetKeyId . read <$> v A..: key "eoki" parseJSON _ = mzero +data KeyIdentifier + = KeyIdentifierWildcard + | KeyIdentifierEightOctet EightOctetKeyId + | KeyIdentifierFingerprint Fingerprint + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Pretty KeyIdentifier where + pretty KeyIdentifierWildcard = pretty "wildcard" + pretty (KeyIdentifierEightOctet kid) = pretty "key-id" <+> pretty kid + pretty (KeyIdentifierFingerprint fp) = pretty "fingerprint" <+> pretty fp + +instance A.ToJSON KeyIdentifier where + toJSON KeyIdentifierWildcard = object [key "wildcard" .= A.Bool True] + toJSON (KeyIdentifierEightOctet kid) = object [key "keyId" .= kid] + toJSON (KeyIdentifierFingerprint fp) = object [key "fingerprint" .= fp] + +instance A.FromJSON KeyIdentifier where + parseJSON (A.Object v) = + ((v A..: key "wildcard") >>= \isWildcard -> + if isWildcard then pure KeyIdentifierWildcard else mzero) + <|> (KeyIdentifierEightOctet <$> v A..: key "keyId") + <|> (KeyIdentifierFingerprint <$> v A..: key "fingerprint") + parseJSON _ = mzero + newtype NotationName = NotationName { unNotationName :: ByteString @@ -468,6 +614,8 @@ | SHA384 | SHA512 | SHA224 + | SHA3_256 + | SHA3_512 | OtherHA Word8 deriving (Data, Generic, Show, Typeable) @@ -485,6 +633,8 @@ fromFVal SHA384 = 9 fromFVal SHA512 = 10 fromFVal SHA224 = 11 + fromFVal SHA3_256 = 12 + fromFVal SHA3_512 = 14 fromFVal (OtherHA o) = o toFVal 1 = DeprecatedMD5 toFVal 2 = SHA1 @@ -493,6 +643,8 @@ toFVal 9 = SHA384 toFVal 10 = SHA512 toFVal 11 = SHA224 + toFVal 12 = SHA3_256 + toFVal 14 = SHA3_512 toFVal o = OtherHA o instance Hashable HashAlgorithm @@ -505,6 +657,8 @@ pretty SHA384 = pretty "SHA-384" pretty SHA512 = pretty "SHA-512" pretty SHA224 = pretty "SHA-224" + pretty SHA3_256 = pretty "SHA3-256" + pretty SHA3_512 = pretty "SHA3-512" pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha $(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm) @@ -547,6 +701,39 @@ $(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm) +data AEADAlgorithm + = EAX + | OCB + | GCM + | OtherAEADAlgo Word8 + deriving (Show, Data, Generic, Typeable) + +instance Eq AEADAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord AEADAlgorithm where + compare = comparing fromFVal + +instance FutureVal AEADAlgorithm where + fromFVal EAX = 1 + fromFVal OCB = 2 + fromFVal GCM = 3 + fromFVal (OtherAEADAlgo o) = o + toFVal 1 = EAX + toFVal 2 = OCB + toFVal 3 = GCM + toFVal o = OtherAEADAlgo o + +instance Hashable AEADAlgorithm + +instance Pretty AEADAlgorithm where + pretty EAX = pretty "EAX" + pretty OCB = pretty "OCB" + pretty GCM = pretty "GCM" + pretty (OtherAEADAlgo aa) = pretty "unknown AEAD algorithm type" <+> pretty aa + +$(ATH.deriveJSON ATH.defaultOptions ''AEADAlgorithm) + data KSPFlag = NoModify | KSPOther Int @@ -664,7 +851,8 @@ $(ATH.deriveJSON ATH.defaultOptions ''RevocationCode) data FeatureFlag - = ModificationDetection + = FeatureSEIPDv1 + | FeatureSEIPDv2 | FeatureOther Int deriving (Data, Generic, Show, Typeable) @@ -675,20 +863,18 @@ compare = comparing fromFFlag instance FutureFlag FeatureFlag where - fromFFlag ModificationDetection = 7 + fromFFlag FeatureSEIPDv1 = 7 + fromFFlag FeatureSEIPDv2 = 4 fromFFlag (FeatureOther i) = fromIntegral i - toFFlag 7 = ModificationDetection + toFFlag 7 = FeatureSEIPDv1 + toFFlag 4 = FeatureSEIPDv2 toFFlag i = FeatureOther (fromIntegral i) instance Hashable FeatureFlag -#if !MIN_VERSION_hashable(1,3,4) -instance Hashable a => Hashable (Set a) where - hashWithSalt salt = hashWithSalt salt . Set.toList -#endif - instance Pretty FeatureFlag where - pretty ModificationDetection = pretty "modification-detection" + pretty FeatureSEIPDv1 = pretty "seipd-v1" + pretty FeatureSEIPDv2 = pretty "seipd-v2" pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o $(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag) @@ -807,6 +993,9 @@ instance Wrapped MPI +instance Ord MPI where + compare (MPI a) (MPI b) = compare a b + instance Hashable MPI instance Pretty MPI where @@ -814,6 +1003,122 @@ $(ATH.deriveJSON ATH.defaultOptions ''MPI) +newtype SignatureSalt = + SignatureSalt + { unSignatureSalt :: ByteString + } + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord SignatureSalt where + compare (SignatureSalt a) (SignatureSalt b) = compare a b + +instance Hashable SignatureSalt + +instance Pretty SignatureSalt where + pretty (SignatureSalt bs) = prettyLBS bs + +instance A.ToJSON SignatureSalt where + toJSON (SignatureSalt bs) = A.toJSON (BL.unpack bs) + +data SignaturePayloadVersion + = SigPayloadV3 + | SigPayloadV4 + | SigPayloadV6 + | SigPayloadVOther + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable SignaturePayloadVersion + +data SignaturePayloadV (v :: SignaturePayloadVersion) where + SigPayloadV3Data :: + SigType + -> ThirtyTwoBitTimeStamp + -> EightOctetKeyId + -> PubKeyAlgorithm + -> HashAlgorithm + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV3 + SigPayloadV4Data :: + SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV4 + SigPayloadV6Data :: + SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV6 + SigPayloadOtherData :: + Word8 + -> ByteString + -> SignaturePayloadV 'SigPayloadVOther + +deriving instance Eq (SignaturePayloadV v) +deriving instance Show (SignaturePayloadV v) + +data SomeSignaturePayload where + SomeSignaturePayload :: SignaturePayloadV v -> SomeSignaturePayload + +toSignaturePayload :: SignaturePayloadV v -> SignaturePayload +toSignaturePayload (SigPayloadV3Data st ts eoki pka ha w16 mpis) = + SigV3 st ts eoki pka ha w16 mpis +toSignaturePayload (SigPayloadV4Data st pka ha hsps usps w16 mpis) = + SigV4 st pka ha hsps usps w16 mpis +toSignaturePayload (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) = + SigV6 st pka ha salt hsps usps w16 mpis +toSignaturePayload (SigPayloadOtherData v bs) = + SigVOther v bs + +toSomeSignaturePayload :: SignaturePayload -> SomeSignaturePayload +toSomeSignaturePayload (SigV3 st ts eoki pka ha w16 mpis) = + SomeSignaturePayload (SigPayloadV3Data st ts eoki pka ha w16 mpis) +toSomeSignaturePayload (SigV4 st pka ha hsps usps w16 mpis) = + SomeSignaturePayload (SigPayloadV4Data st pka ha hsps usps w16 mpis) +toSomeSignaturePayload (SigV6 st pka ha salt hsps usps w16 mpis) = + SomeSignaturePayload (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) +toSomeSignaturePayload (SigVOther v bs) = + SomeSignaturePayload (SigPayloadOtherData v bs) + +signaturePayloadVersion :: SignaturePayload -> SignaturePayloadVersion +signaturePayloadVersion (SigV3 _ _ _ _ _ _ _) = SigPayloadV3 +signaturePayloadVersion (SigV4 _ _ _ _ _ _ _) = SigPayloadV4 +signaturePayloadVersion (SigV6 _ _ _ _ _ _ _ _) = SigPayloadV6 +signaturePayloadVersion (SigVOther _ _) = SigPayloadVOther + +asSignaturePayloadV3 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV3) +asSignaturePayloadV3 (SigV3 st ts eoki pka ha w16 mpis) = + Right (SigPayloadV3Data st ts eoki pka ha w16 mpis) +asSignaturePayloadV3 _ = + Left "Cannot coerce non-v3 SignaturePayload to SignaturePayloadV3" + +asSignaturePayloadV4 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV4) +asSignaturePayloadV4 (SigV4 st pka ha hsps usps w16 mpis) = + Right (SigPayloadV4Data st pka ha hsps usps w16 mpis) +asSignaturePayloadV4 _ = + Left "Cannot coerce non-v4 SignaturePayload to SignaturePayloadV4" + +asSignaturePayloadV6 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV6) +asSignaturePayloadV6 (SigV6 st pka ha salt hsps usps w16 mpis) = + Right (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) +asSignaturePayloadV6 _ = + Left "Cannot coerce non-v6 SignaturePayload to SignaturePayloadV6" + +asSignaturePayloadOther :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadVOther) +asSignaturePayloadOther (SigVOther v bs) = + Right (SigPayloadOtherData v bs) +asSignaturePayloadOther _ = + Left "Cannot coerce known-version SignaturePayload to SignaturePayloadVOther" + data SignaturePayload = SigV3 SigType @@ -831,11 +1136,50 @@ [SigSubPacket] Word16 (NonEmpty MPI) + | SigV6 + SigType + PubKeyAlgorithm + HashAlgorithm + SignatureSalt + [SigSubPacket] + [SigSubPacket] + Word16 + (NonEmpty MPI) | SigVOther Word8 ByteString deriving (Data, Eq, Generic, Show, Typeable) instance Hashable SignaturePayload +instance Ord SignaturePayload where + compare (SigV3 st1 ts1 eoki1 pka1 ha1 w161 mpis1) + (SigV3 st2 ts2 eoki2 pka2 ha2 w162 mpis2) = + compare st1 st2 <> compare ts1 ts2 <> compare eoki1 eoki2 <> + compare pka1 pka2 <> compare ha1 ha2 <> compare w161 w162 <> + compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigV4 st1 pka1 ha1 hsp1 usp1 w161 mpis1) + (SigV4 st2 pka2 ha2 hsp2 usp2 w162 mpis2) = + compare st1 st2 <> compare pka1 pka2 <> compare ha1 ha2 <> + compare hsp1 hsp2 <> compare usp1 usp2 <> compare w161 w162 <> + compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigV6 st1 pka1 ha1 salt1 hsp1 usp1 w161 mpis1) + (SigV6 st2 pka2 ha2 salt2 hsp2 usp2 w162 mpis2) = + compare st1 st2 <> compare pka1 pka2 <> compare ha1 ha2 <> + compare salt1 salt2 <> compare hsp1 hsp2 <> compare usp1 usp2 <> + compare w161 w162 <> compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigVOther t1 bs1) (SigVOther t2 bs2) = compare t1 t2 <> compare bs1 bs2 + compare SigV3 {} SigV4 {} = LT + compare SigV3 {} SigV6 {} = LT + compare SigV3 {} SigVOther {} = LT + compare SigV4 {} SigV3 {} = GT + compare SigV4 {} SigV6 {} = LT + compare SigV4 {} SigVOther {} = LT + compare SigV6 {} SigV3 {} = GT + compare SigV6 {} SigV4 {} = GT + compare SigV6 {} SigVOther {} = LT + compare SigVOther {} SigV3 {} = GT + compare SigVOther {} SigV4 {} = GT + compare SigVOther {} SigV6 {} = GT + instance Pretty SignaturePayload where pretty (SigV3 st ts eoki pka ha w16 mpis) = pretty "signature v3" <> pretty ':' <+> @@ -849,6 +1193,13 @@ pretty pka <+> pretty ha <+> pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis + pretty (SigV6 st pka ha salt hsps usps w16 mpis) = + pretty "signature v6" <> pretty ':' <+> + pretty st <+> + pretty pka <+> + pretty ha <+> + pretty salt <+> + pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis pretty (SigVOther t bs) = pretty "unknown signature v" <> pretty t <> pretty ':' <+> pretty (BL.unpack bs) @@ -858,8 +1209,47 @@ A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis) toJSON (SigV4 st pka ha hsps usps w16 mpis) = A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis) + toJSON (SigV6 st pka ha salt hsps usps w16 mpis) = + A.toJSON (st, pka, ha, salt, hsps, usps, w16, NE.toList mpis) toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs) +data IssuerFingerprintVersion + = IssuerFingerprintV4 + | IssuerFingerprintV6 + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord IssuerFingerprintVersion where + IssuerFingerprintV4 `compare` IssuerFingerprintV4 = EQ + IssuerFingerprintV4 `compare` IssuerFingerprintV6 = LT + IssuerFingerprintV6 `compare` IssuerFingerprintV4 = GT + IssuerFingerprintV6 `compare` IssuerFingerprintV6 = EQ + +instance Hashable IssuerFingerprintVersion + +instance Pretty IssuerFingerprintVersion where + pretty IssuerFingerprintV4 = pretty "4" + pretty IssuerFingerprintV6 = pretty "6" + +instance A.ToJSON IssuerFingerprintVersion where + toJSON IssuerFingerprintV4 = A.toJSON (4 :: Word8) + toJSON IssuerFingerprintV6 = A.toJSON (6 :: Word8) + +instance A.FromJSON IssuerFingerprintVersion where + parseJSON (A.Number n) = case round n of + 4 -> pure IssuerFingerprintV4 + 6 -> pure IssuerFingerprintV6 + _ -> mzero + parseJSON _ = mzero + +issuerFingerprintVersionToPacketVersion :: IssuerFingerprintVersion -> PacketVersion +issuerFingerprintVersionToPacketVersion IssuerFingerprintV4 = 4 +issuerFingerprintVersionToPacketVersion IssuerFingerprintV6 = 6 + +packetVersionToIssuerFingerprintVersion :: PacketVersion -> Maybe IssuerFingerprintVersion +packetVersionToIssuerFingerprintVersion 4 = Just IssuerFingerprintV4 +packetVersionToIssuerFingerprintVersion 6 = Just IssuerFingerprintV6 +packetVersionToIssuerFingerprintVersion _ = Nothing + data SigSubPacketPayload = SigCreationTime ThirtyTwoBitTimeStamp | SigExpirationTime ThirtyTwoBitDuration @@ -869,7 +1259,7 @@ | Revocable Revocability | KeyExpirationTime ThirtyTwoBitDuration | PreferredSymmetricAlgorithms [SymmetricAlgorithm] - | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint + | RevocationKey (Set RevocationClass) PubKeyAlgorithm Fingerprint | Issuer EightOctetKeyId | NotationData (Set NotationFlag) NotationName NotationValue | PreferredHashAlgorithms [HashAlgorithm] @@ -884,10 +1274,10 @@ | Features (Set FeatureFlag) | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash | EmbeddedSignature SignaturePayload - | IssuerFingerprint Word8 TwentyOctetFingerprint + | IssuerFingerprint IssuerFingerprintVersion Fingerprint | UserDefinedSigSub Word8 ByteString | OtherSigSub Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable SigSubPacketPayload @@ -1007,6 +1397,10 @@ } deriving (Data, Eq, Generic, Show, Typeable) +instance Ord SigSubPacket where + compare (SigSubPacket crit1 payload1) (SigSubPacket crit2 payload2) = + compare crit1 crit2 <> compare payload1 payload2 + instance Pretty SigSubPacket where pretty x = (if _sspCriticality x @@ -1021,9 +1415,45 @@ $(makeLenses ''SigSubPacket) +-- | Type-safe subpacket list with phantom types to distinguish hashed vs unhashed +-- and signature version constraints (v4 vs v6). +-- The type parameters erase at runtime; they exist purely for compile-time safety. +newtype SubpacketList (hashedness :: Type) (version :: Type) = SubpacketList [SigSubPacket] + deriving (Show, Eq, Ord, Generic, Data, Typeable) + +instance Functor (SubpacketList h) where + fmap _ (SubpacketList sps) = SubpacketList sps + +-- | Extract the underlying list from a phantom-typed SubpacketList +-- This is typically used internally during serialization/deserialization +fromSubpacketList :: SubpacketList h v -> [SigSubPacket] +fromSubpacketList (SubpacketList sps) = sps + +-- | Wrap a plain list into a phantom-typed SubpacketList +-- Warning: This circumvents type safety; use only for trusted sources (e.g., parsing) +toSubpacketList :: [SigSubPacket] -> SubpacketList h v +toSubpacketList = SubpacketList + +-- | Create an empty hashed subpacket list for a given signature version +emptyHashedSubpackets :: SubpacketList Hashed v +emptyHashedSubpackets = SubpacketList [] + +-- | Create an empty unhashed subpacket list for a given signature version +emptyUnhashedSubpackets :: SubpacketList Unhashed v +emptyUnhashedSubpackets = SubpacketList [] + +-- | Append a subpacket to a hashed list, preserving phantom type +consHashedSubpacket :: SigSubPacket -> SubpacketList Hashed v -> SubpacketList Hashed v +consHashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) + +-- | Append a subpacket to an unhashed list, preserving phantom type +consUnhashedSubpacket :: SigSubPacket -> SubpacketList Unhashed v -> SubpacketList Unhashed v +consUnhashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) + data KeyVersion = DeprecatedV3 | V4 + | V6 deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable KeyVersion @@ -1031,6 +1461,7 @@ instance Pretty KeyVersion where pretty DeprecatedV3 = pretty "(deprecated) v3" pretty V4 = pretty "v4" + pretty V6 = pretty "v6" $(ATH.deriveJSON ATH.defaultOptions ''KeyVersion) @@ -1051,6 +1482,9 @@ instance Wrapped IV +instance Ord IV where + compare (IV b1) (IV b2) = compare b1 b2 + instance Pretty IV where pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV @@ -1090,6 +1524,17 @@ $(ATH.deriveJSON ATH.defaultOptions ''DataType) +newtype SessionKey = + SessionKey + { unSessionKey :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped SessionKey + +instance Ord SessionKey where + compare (SessionKey b1) (SessionKey b2) = compare b1 b2 + newtype Salt = Salt { unSalt :: B.ByteString @@ -1098,12 +1543,65 @@ instance Wrapped Salt +instance Ord Salt where + compare (Salt b1) (Salt b2) = compare b1 b2 + instance Pretty Salt where pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt instance A.ToJSON Salt where toJSON = A.toJSON . show . op Salt +newtype Salt8 = + Salt8 + { unSalt8 :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped Salt8 + +instance Ord Salt8 where + compare (Salt8 b1) (Salt8 b2) = compare b1 b2 + +instance Pretty Salt8 where + pretty = pretty . ("salt8:" ++) . bsToHexUpper . BL.fromStrict . op Salt8 + +instance A.ToJSON Salt8 where + toJSON = A.toJSON . show . op Salt8 + +newtype Salt16 = + Salt16 + { unSalt16 :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped Salt16 + +instance Ord Salt16 where + compare (Salt16 b1) (Salt16 b2) = compare b1 b2 + +instance Pretty Salt16 where + pretty = pretty . ("salt16:" ++) . bsToHexUpper . BL.fromStrict . op Salt16 + +instance A.ToJSON Salt16 where + toJSON = A.toJSON . show . op Salt16 + +salt8FromSalt :: Salt -> Maybe Salt8 +salt8FromSalt (Salt bs) + | B.length bs == 8 = Just (Salt8 bs) + | otherwise = Nothing + +salt16FromSalt :: Salt -> Maybe Salt16 +salt16FromSalt (Salt bs) + | B.length bs == 16 = Just (Salt16 bs) + | otherwise = Nothing + +saltFromSalt8 :: Salt8 -> Salt +saltFromSalt8 (Salt8 bs) = Salt bs + +saltFromSalt16 :: Salt16 -> Salt +saltFromSalt16 (Salt16 bs) = Salt bs + newtype IterationCount = IterationCount { unIterationCount :: Int @@ -1131,19 +1629,49 @@ data S2K = Simple HashAlgorithm - | Salted HashAlgorithm Salt - | IteratedSalted HashAlgorithm Salt IterationCount + | Salted HashAlgorithm Salt8 + | IteratedSalted HashAlgorithm Salt8 IterationCount + | Argon2 Salt16 Word8 Word8 Word8 | OtherS2K Word8 ByteString deriving (Data, Eq, Generic, Show, Typeable) instance Hashable S2K +instance Ord S2K where + compare (Simple ha1) (Simple ha2) = compare ha1 ha2 + compare (Salted ha1 s1) (Salted ha2 s2) = compare ha1 ha2 <> compare s1 s2 + compare (IteratedSalted ha1 s1 ic1) (IteratedSalted ha2 s2 ic2) = + compare ha1 ha2 <> compare s1 s2 <> compare ic1 ic2 + compare (Argon2 salt1 t1 p1 em1) (Argon2 salt2 t2 p2 em2) = + compare salt1 salt2 <> compare t1 t2 <> compare p1 p2 <> compare em1 em2 + compare (OtherS2K t1 bs1) (OtherS2K t2 bs2) = compare t1 t2 <> compare bs1 bs2 + compare Simple {} Salted {} = LT + compare Simple {} IteratedSalted {} = LT + compare Simple {} Argon2 {} = LT + compare Simple {} OtherS2K {} = LT + compare Salted {} Simple {} = GT + compare Salted {} IteratedSalted {} = LT + compare Salted {} Argon2 {} = LT + compare Salted {} OtherS2K {} = LT + compare IteratedSalted {} Simple {} = GT + compare IteratedSalted {} Salted {} = GT + compare IteratedSalted {} Argon2 {} = LT + compare IteratedSalted {} OtherS2K {} = LT + compare Argon2 {} Simple {} = GT + compare Argon2 {} Salted {} = GT + compare Argon2 {} IteratedSalted {} = GT + compare Argon2 {} OtherS2K {} = LT + compare OtherS2K {} _ = GT + instance Pretty S2K where pretty (Simple ha) = pretty "simple S2K," <+> pretty ha pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt pretty (IteratedSalted ha salt icount) = pretty "iterated-salted S2K," <+> pretty ha <+> pretty salt <+> pretty icount + pretty (Argon2 salt t p em) = + pretty "Argon2 S2K," <+> + pretty salt <+> pretty t <+> pretty p <+> pretty em pretty (OtherS2K t bs) = pretty "unknown S2K type" <+> pretty t <+> pretty (bsToHexUpper bs) @@ -1151,6 +1679,7 @@ toJSON (Simple ha) = A.toJSON ha toJSON (Salted ha salt) = A.toJSON (ha, salt) toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount) + toJSON (Argon2 salt t p em) = A.toJSON (salt, t, p, em) toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs) data ImageFormat @@ -1221,6 +1750,7 @@ | NISTP384 | NISTP521 | Curve25519 + | Curve448 deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Pretty ECCCurve where @@ -1228,11 +1758,13 @@ pretty NISTP384 = pretty "NIST P-384" pretty NISTP521 = pretty "NIST P-521" pretty Curve25519 = pretty "Curve25519" + pretty Curve448 = pretty "Curve448" instance Hashable ECCCurve +-- Packet stream wrapper used to provide an EOF-delimited Binary instance. newtype Block a = Block { unBlock :: [a] - } -- so we can override cereal instance + } -- intentionally not encoded as a list length prefix deriving (Show, Eq) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs b/Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs @@ -1,7 +1,8 @@ -- CryptonNewtypes.hs: OpenPGP (RFC4880) newtype wrappers for some crypton types --- Copyright © 2012-2024 Clint Adams +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -26,7 +27,9 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord DSA_PublicKey +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 instance A.ToJSON DSA_PublicKey where toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y) @@ -41,7 +44,9 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PublicKey +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 instance A.ToJSON RSA_PublicKey where toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e) @@ -56,7 +61,9 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PublicKey +instance Ord ECDSA_PublicKey where + 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)) = @@ -72,7 +79,9 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord DSA_PrivateKey +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 instance A.ToJSON DSA_PrivateKey where toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x) @@ -86,7 +95,12 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PrivateKey +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 instance A.ToJSON RSA_PrivateKey where toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = @@ -102,7 +116,9 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PrivateKey +instance Ord ECDSA_PrivateKey where + 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)) = @@ -118,6 +134,10 @@ } 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 + instance A.ToJSON DSA_Params where toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q) @@ -150,12 +170,54 @@ instance Hashable ECDSA_PublicKey where hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = - s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show + hashWithCurve s curve `hashWithECPoint` q instance Hashable ECDSA_PrivateKey where hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = - s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show + 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 + +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 + +hashWithCurve :: Int -> ECCT.Curve -> Int +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 + +compareECPoint :: ECCT.Point -> ECCT.Point -> Ordering +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 + +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) + +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.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 + newtype ECurvePoint = ECurvePoint { unECurvepoint :: ECCT.Point @@ -167,5 +229,10 @@ toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity" instance A.FromJSON ECurvePoint where - parseJSON (A.Object v) = error "FIXME: whatsit" - parseJSON _ = 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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs @@ -1,10 +1,17 @@ --- PKITypes.hs: OpenPGP (RFC4880) data types for public/secret keys --- Copyright © 2012-2024 Clint Adams +-- PKITypes.hs: OpenPGP (RFC9580) data types for public/secret keys +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,15 +19,15 @@ import GHC.Generics (Generic) -import Codec.Encryption.OpenPGP.Types.Internal.Base +import Codec.Encryption.OpenPGP.Types.Internal.Base hiding (Ed25519, Ed448) import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes import qualified Data.Aeson as A -import qualified Data.Aeson.TH as ATH import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL -import Data.Data (Data) +import Data.Data (Data(..)) +import qualified Data.Data as DData import Data.Hashable (Hashable(..)) import Data.Ord (comparing) import Data.Typeable (Typeable) @@ -29,12 +36,14 @@ data EdSigningCurve = Ed25519 + | Ed448 deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable EdSigningCurve instance Pretty EdSigningCurve where pretty Ed25519 = pretty "Ed25519" + pretty Ed448 = pretty "Ed448" instance A.FromJSON EdSigningCurve @@ -52,13 +61,28 @@ instance A.ToJSON EPoint +data EdPoint + = PrefixedNativeEPoint EPoint + | NativeEPoint EPoint + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable EdPoint + +instance Pretty EdPoint where + pretty (PrefixedNativeEPoint ep) = pretty "prefixed-native" <+> pretty ep + pretty (NativeEPoint ep) = pretty "native" <+> pretty ep + +instance A.FromJSON EdPoint + +instance A.ToJSON EdPoint + data PKey = RSAPubKey RSA_PublicKey | DSAPubKey DSA_PublicKey | ElGamalPubKey Integer Integer Integer | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm | ECDSAPubKey ECDSA_PublicKey - | EdDSAPubKey EdSigningCurve EPoint + | EdDSAPubKey EdSigningCurve EdPoint | UnknownPKey ByteString deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -91,11 +115,90 @@ | ECDHPrivateKey ECDSA_PrivateKey | ECDSAPrivateKey ECDSA_PrivateKey | EdDSAPrivateKey EdSigningCurve B.ByteString + | X25519PrivateKey B.ByteString + | X448PrivateKey B.ByteString | UnknownSKey ByteString deriving (Data, Eq, Generic, Show, Typeable) instance Hashable SKey +instance Ord SKey where + compare (RSAPrivateKey rsa1) (RSAPrivateKey rsa2) = compare rsa1 rsa2 + compare (DSAPrivateKey dsa1) (DSAPrivateKey dsa2) = compare dsa1 dsa2 + compare (ElGamalPrivateKey x1) (ElGamalPrivateKey x2) = compare x1 x2 + compare (ECDHPrivateKey ecdsa1) (ECDHPrivateKey ecdsa2) = compare ecdsa1 ecdsa2 + compare (ECDSAPrivateKey ecdsa1) (ECDSAPrivateKey ecdsa2) = compare ecdsa1 ecdsa2 + compare (EdDSAPrivateKey curve1 bs1) (EdDSAPrivateKey curve2 bs2) = + compare curve1 curve2 <> compare bs1 bs2 + compare (X25519PrivateKey bs1) (X25519PrivateKey bs2) = compare bs1 bs2 + compare (X448PrivateKey bs1) (X448PrivateKey bs2) = compare bs1 bs2 + compare (UnknownSKey bs1) (UnknownSKey bs2) = compare bs1 bs2 + compare RSAPrivateKey {} DSAPrivateKey {} = LT + compare RSAPrivateKey {} ElGamalPrivateKey {} = LT + compare RSAPrivateKey {} ECDHPrivateKey {} = LT + compare RSAPrivateKey {} ECDSAPrivateKey {} = LT + compare RSAPrivateKey {} EdDSAPrivateKey {} = LT + compare RSAPrivateKey {} X25519PrivateKey {} = LT + compare RSAPrivateKey {} X448PrivateKey {} = LT + compare RSAPrivateKey {} UnknownSKey {} = LT + compare DSAPrivateKey {} RSAPrivateKey {} = GT + compare DSAPrivateKey {} ElGamalPrivateKey {} = LT + compare DSAPrivateKey {} ECDHPrivateKey {} = LT + compare DSAPrivateKey {} ECDSAPrivateKey {} = LT + compare DSAPrivateKey {} EdDSAPrivateKey {} = LT + compare DSAPrivateKey {} X25519PrivateKey {} = LT + compare DSAPrivateKey {} X448PrivateKey {} = LT + compare DSAPrivateKey {} UnknownSKey {} = LT + compare ElGamalPrivateKey {} RSAPrivateKey {} = GT + compare ElGamalPrivateKey {} DSAPrivateKey {} = GT + compare ElGamalPrivateKey {} ECDHPrivateKey {} = LT + compare ElGamalPrivateKey {} ECDSAPrivateKey {} = LT + compare ElGamalPrivateKey {} EdDSAPrivateKey {} = LT + compare ElGamalPrivateKey {} X25519PrivateKey {} = LT + compare ElGamalPrivateKey {} X448PrivateKey {} = LT + compare ElGamalPrivateKey {} UnknownSKey {} = LT + compare ECDHPrivateKey {} RSAPrivateKey {} = GT + compare ECDHPrivateKey {} DSAPrivateKey {} = GT + compare ECDHPrivateKey {} ElGamalPrivateKey {} = GT + compare ECDHPrivateKey {} ECDSAPrivateKey {} = LT + compare ECDHPrivateKey {} EdDSAPrivateKey {} = LT + compare ECDHPrivateKey {} X25519PrivateKey {} = LT + compare ECDHPrivateKey {} X448PrivateKey {} = LT + compare ECDHPrivateKey {} UnknownSKey {} = LT + compare ECDSAPrivateKey {} RSAPrivateKey {} = GT + compare ECDSAPrivateKey {} DSAPrivateKey {} = GT + compare ECDSAPrivateKey {} ElGamalPrivateKey {} = GT + compare ECDSAPrivateKey {} ECDHPrivateKey {} = GT + compare ECDSAPrivateKey {} EdDSAPrivateKey {} = LT + compare ECDSAPrivateKey {} X25519PrivateKey {} = LT + compare ECDSAPrivateKey {} X448PrivateKey {} = LT + compare ECDSAPrivateKey {} UnknownSKey {} = LT + compare EdDSAPrivateKey {} RSAPrivateKey {} = GT + compare EdDSAPrivateKey {} DSAPrivateKey {} = GT + compare EdDSAPrivateKey {} ElGamalPrivateKey {} = GT + compare EdDSAPrivateKey {} ECDHPrivateKey {} = GT + compare EdDSAPrivateKey {} ECDSAPrivateKey {} = GT + compare EdDSAPrivateKey {} X25519PrivateKey {} = LT + compare EdDSAPrivateKey {} X448PrivateKey {} = LT + compare EdDSAPrivateKey {} UnknownSKey {} = LT + compare X25519PrivateKey {} RSAPrivateKey {} = GT + compare X25519PrivateKey {} DSAPrivateKey {} = GT + compare X25519PrivateKey {} ElGamalPrivateKey {} = GT + compare X25519PrivateKey {} ECDHPrivateKey {} = GT + compare X25519PrivateKey {} ECDSAPrivateKey {} = GT + compare X25519PrivateKey {} EdDSAPrivateKey {} = GT + compare X25519PrivateKey {} X448PrivateKey {} = LT + compare X25519PrivateKey {} UnknownSKey {} = LT + compare X448PrivateKey {} RSAPrivateKey {} = GT + compare X448PrivateKey {} DSAPrivateKey {} = GT + compare X448PrivateKey {} ElGamalPrivateKey {} = GT + compare X448PrivateKey {} ECDHPrivateKey {} = GT + compare X448PrivateKey {} ECDSAPrivateKey {} = GT + compare X448PrivateKey {} EdDSAPrivateKey {} = GT + compare X448PrivateKey {} X25519PrivateKey {} = GT + compare X448PrivateKey {} UnknownSKey {} = LT + compare UnknownSKey {} _ = GT + instance Pretty SKey where pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p @@ -104,6 +207,8 @@ pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p pretty (EdDSAPrivateKey c bs) = pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (X25519PrivateKey bs) = pretty "X25519" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (X448PrivateKey bs) = pretty "X448" <+> pretty (bsToHexUpper (BL.fromStrict bs)) pretty (UnknownSKey bs) = pretty "" <+> pretty (bsToHexUpper bs) instance A.ToJSON SKey where @@ -113,41 +218,162 @@ toJSON (ECDHPrivateKey k) = A.toJSON k toJSON (ECDSAPrivateKey k) = A.toJSON k toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs) + toJSON (X25519PrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (X448PrivateKey bs) = A.toJSON (B.unpack bs) toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) -data PKPayload = - PKPayload - { _keyVersion :: KeyVersion - , _timestamp :: ThirtyTwoBitTimeStamp - , _v3exp :: V3Expiration - , _pkalgo :: PubKeyAlgorithm - , _pubkey :: PKey - } - deriving (Data, Eq, Generic, Show, Typeable) +data PKPayload (v :: KeyVersion) where + PKPayloadV3 :: + ThirtyTwoBitTimeStamp + -> V3Expiration + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'DeprecatedV3 + PKPayloadV4 :: + ThirtyTwoBitTimeStamp + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'V4 + PKPayloadV6 :: + ThirtyTwoBitTimeStamp + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'V6 -instance Ord PKPayload where - compare = - comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> - comparing _pkalgo <> - comparing _pubkey +deriving instance Eq (PKPayload v) +deriving instance Ord (PKPayload v) +deriving instance Show (PKPayload v) -instance Hashable PKPayload +instance Hashable (PKPayload v) where + hashWithSalt s = hashWithSalt s . pkPayloadFields -instance Pretty PKPayload where +instance Pretty (PKPayload v) where + pretty pkp = + let (kv, ts, v3e, pka, p) = pkPayloadFields pkp + in pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p + +instance A.ToJSON (PKPayload v) where + toJSON = A.toJSON . pkPayloadFields + +data SomePKPayload where + SomePKPayload :: PKPayload v -> SomePKPayload + +deriving instance Show SomePKPayload +deriving instance Typeable SomePKPayload + +pkPayloadDataType :: DData.DataType +pkPayloadDataType = + DData.mkDataType + "Codec.Encryption.OpenPGP.Types.Internal.PKITypes.SomePKPayload" + [pkPayloadConstr] + +pkPayloadConstr :: DData.Constr +pkPayloadConstr = DData.mkConstr pkPayloadDataType "PKPayload" [] DData.Prefix + +instance Data SomePKPayload where + gfoldl f z (PKPayload kv ts v3e pka p) = + z PKPayload `f` kv `f` ts `f` v3e `f` pka `f` p + gunfold k z c + | c == pkPayloadConstr = k (k (k (k (k (z PKPayload))))) + | otherwise = error "gunfold: invalid constructor for SomePKPayload" + toConstr _ = pkPayloadConstr + dataTypeOf _ = pkPayloadDataType + +instance Eq SomePKPayload where + a == b = somePKPayloadFields a == somePKPayloadFields b + +instance Ord SomePKPayload where + compare = comparing somePKPayloadFields + +instance Hashable SomePKPayload where + hashWithSalt s = hashWithSalt s . somePKPayloadFields + +instance Pretty SomePKPayload where pretty (PKPayload kv ts v3e pka p) = pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p -$(ATH.deriveToJSON ATH.defaultOptions ''PKPayload) +instance A.ToJSON SomePKPayload where + toJSON = A.toJSON . somePKPayloadFields +pkPayloadFields :: + PKPayload v + -> (KeyVersion, ThirtyTwoBitTimeStamp, V3Expiration, PubKeyAlgorithm, PKey) +pkPayloadFields (PKPayloadV3 ts v3e pka p) = (DeprecatedV3, ts, v3e, pka, p) +pkPayloadFields (PKPayloadV4 ts pka p) = (V4, ts, 0, pka, p) +pkPayloadFields (PKPayloadV6 ts pka p) = (V6, ts, 0, pka, p) + +somePKPayloadFields :: + SomePKPayload + -> (KeyVersion, ThirtyTwoBitTimeStamp, V3Expiration, PubKeyAlgorithm, PKey) +somePKPayloadFields (SomePKPayload pkp) = pkPayloadFields pkp + +pattern PKPayload :: + KeyVersion + -> ThirtyTwoBitTimeStamp + -> V3Expiration + -> PubKeyAlgorithm + -> PKey + -> SomePKPayload +pattern PKPayload kv ts v3e pka p <- (somePKPayloadFields -> (kv, ts, v3e, pka, p)) + where + PKPayload DeprecatedV3 ts v3e pka p = SomePKPayload (PKPayloadV3 ts v3e pka p) + PKPayload V4 ts _ pka p = SomePKPayload (PKPayloadV4 ts pka p) + PKPayload V6 ts _ pka p = SomePKPayload (PKPayloadV6 ts pka p) + +{-# COMPLETE PKPayload #-} + +_keyVersion :: SomePKPayload -> KeyVersion +_keyVersion (PKPayload kv _ _ _ _) = kv + +_timestamp :: SomePKPayload -> ThirtyTwoBitTimeStamp +_timestamp (PKPayload _ ts _ _ _) = ts + +_v3exp :: SomePKPayload -> V3Expiration +_v3exp (PKPayload _ _ v3e _ _) = v3e + +_pkalgo :: SomePKPayload -> PubKeyAlgorithm +_pkalgo (PKPayload _ _ _ pka _) = pka + +_pubkey :: SomePKPayload -> PKey +_pubkey (PKPayload _ _ _ _ p) = p + data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString | SUSSHA1 SymmetricAlgorithm S2K IV ByteString + | SUSAEAD SymmetricAlgorithm AEADAlgorithm S2K IV ByteString | SUSym SymmetricAlgorithm IV ByteString | SUUnencrypted SKey Word16 deriving (Data, Eq, Generic, Show, Typeable) instance Ord SKAddendum where - compare a b = show a `compare` show b -- FIXME: this is ridiculous + compare (SUS16bit sa1 s2k1 iv1 bs1) (SUS16bit sa2 s2k2 iv2 bs2) = + compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2 + compare (SUSSHA1 sa1 s2k1 iv1 bs1) (SUSSHA1 sa2 s2k2 iv2 bs2) = + compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2 + compare (SUSAEAD sa1 aa1 s2k1 iv1 bs1) (SUSAEAD sa2 aa2 s2k2 iv2 bs2) = + compare sa1 sa2 <> compare aa1 aa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> + compare bs1 bs2 + compare (SUSym sa1 iv1 bs1) (SUSym sa2 iv2 bs2) = + compare sa1 sa2 <> compare iv1 iv2 <> compare bs1 bs2 + compare (SUUnencrypted sk1 ck1) (SUUnencrypted sk2 ck2) = + compare sk1 sk2 <> compare ck1 ck2 + compare SUS16bit {} SUSSHA1 {} = LT + compare SUS16bit {} SUSAEAD {} = LT + compare SUS16bit {} SUSym {} = LT + compare SUS16bit {} SUUnencrypted {} = LT + compare SUSSHA1 {} SUS16bit {} = GT + compare SUSSHA1 {} SUSAEAD {} = LT + compare SUSSHA1 {} SUSym {} = LT + compare SUSSHA1 {} SUUnencrypted {} = LT + compare SUSAEAD {} SUS16bit {} = GT + compare SUSAEAD {} SUSSHA1 {} = GT + compare SUSAEAD {} SUSym {} = LT + compare SUSAEAD {} SUUnencrypted {} = LT + compare SUSym {} SUS16bit {} = GT + compare SUSym {} SUSSHA1 {} = GT + compare SUSym {} SUSAEAD {} = GT + compare SUSym {} SUUnencrypted {} = LT + compare SUUnencrypted {} _ = GT instance Hashable SKAddendum @@ -158,6 +384,10 @@ pretty (SUSSHA1 sa s2k iv bs) = pretty "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs) + pretty (SUSAEAD sa aa s2k iv bs) = + pretty "SUSAEAD" <+> + pretty sa <+> pretty aa <+> pretty s2k <+> pretty iv <+> + pretty (bsToHexUpper bs) pretty (SUSym sa iv bs) = pretty "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs) pretty (SUUnencrypted s ck) = @@ -166,5 +396,128 @@ instance A.ToJSON SKAddendum where toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) + toJSON (SUSAEAD sa aa s2k iv bs) = A.toJSON (sa, aa, s2k, iv, BL.unpack bs) toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs) toJSON (SUUnencrypted s ck) = A.toJSON (s, ck) + +class LegacyKeyVersion (v :: KeyVersion) + +instance LegacyKeyVersion 'DeprecatedV3 + +instance LegacyKeyVersion 'V4 + +data SKAddendumV (v :: KeyVersion) where + SKA16bit :: + LegacyKeyVersion v + => SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASHA1Legacy :: + LegacyKeyVersion v + => SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASHA1V6 :: + SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAAEADV6 :: + SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAAEADLegacy :: + LegacyKeyVersion v + => SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASymLegacy :: + LegacyKeyVersion v + => SymmetricAlgorithm + -> IV + -> ByteString + -> SKAddendumV v + SKASymV6 :: + SymmetricAlgorithm + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAUnencryptedLegacy :: + LegacyKeyVersion v + => SKey + -> Word16 + -> SKAddendumV v + SKAUnencryptedV6 :: + SKey + -> SKAddendumV 'V6 + +deriving instance Show (SKAddendumV v) + +data SomeSKAddendumV where + SomeSKAddendumV :: SKAddendumV v -> SomeSKAddendumV + +deriving instance Show SomeSKAddendumV + +toSKAddendum :: SKAddendumV v -> SKAddendum +toSKAddendum (SKA16bit sa s2k iv bs) = SUS16bit sa s2k iv bs +toSKAddendum (SKASHA1Legacy sa s2k iv bs) = SUSSHA1 sa s2k iv bs +toSKAddendum (SKASHA1V6 sa s2k iv bs) = SUSSHA1 sa s2k iv bs +toSKAddendum (SKAAEADV6 sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs +toSKAddendum (SKAAEADLegacy sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs +toSKAddendum (SKASymLegacy sa iv bs) = SUSym sa iv bs +toSKAddendum (SKASymV6 sa iv bs) = SUSym sa iv bs +toSKAddendum (SKAUnencryptedLegacy sk checksum) = SUUnencrypted sk checksum +toSKAddendum (SKAUnencryptedV6 sk) = SUUnencrypted sk 0 + +fromSKAddendumForKeyVersion :: + KeyVersion + -> SKAddendum + -> Either String SomeSKAddendumV +fromSKAddendumForKeyVersion DeprecatedV3 (SUS16bit sa s2k iv bs) = + Right (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'DeprecatedV3)) +fromSKAddendumForKeyVersion DeprecatedV3 (SUSSHA1 sa s2k iv bs) = + Right (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'DeprecatedV3)) +fromSKAddendumForKeyVersion DeprecatedV3 (SUSym sa iv bs) = + Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'DeprecatedV3)) +fromSKAddendumForKeyVersion DeprecatedV3 (SUUnencrypted sk checksum) = + Right (SomeSKAddendumV (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'DeprecatedV3)) +fromSKAddendumForKeyVersion DeprecatedV3 (SUSAEAD sa aa s2k iv bs) = + Right (SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'DeprecatedV3)) +fromSKAddendumForKeyVersion V4 (SUS16bit sa s2k iv bs) = + Right (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'V4)) +fromSKAddendumForKeyVersion V4 (SUSSHA1 sa s2k iv bs) = + Right (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'V4)) +fromSKAddendumForKeyVersion V4 (SUSym sa iv bs) = + Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'V4)) +fromSKAddendumForKeyVersion V4 (SUUnencrypted sk checksum) = + Right (SomeSKAddendumV (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'V4)) +fromSKAddendumForKeyVersion V4 (SUSAEAD sa aa s2k iv bs) = + Right (SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'V4)) +fromSKAddendumForKeyVersion V6 (SUS16bit _ _ _ _) = + Left "v6 secret keys must not use 16-bit checksum protected secret key addendums" +fromSKAddendumForKeyVersion V6 (SUSSHA1 sa s2k iv bs) = + Right (SomeSKAddendumV (SKASHA1V6 sa s2k iv bs)) +fromSKAddendumForKeyVersion V6 (SUSAEAD sa aa s2k iv bs) = + Right (SomeSKAddendumV (SKAAEADV6 sa aa s2k iv bs)) +fromSKAddendumForKeyVersion V6 (SUSym sa iv bs) = + Right (SomeSKAddendumV (SKASymV6 sa iv bs)) +fromSKAddendumForKeyVersion V6 (SUUnencrypted sk _) = + Right (SomeSKAddendumV (SKAUnencryptedV6 sk)) + +fromSKAddendumForPKPayload :: + SomePKPayload + -> SKAddendum + -> Either String SomeSKAddendumV +fromSKAddendumForPKPayload pkp = + fromSKAddendumForKeyVersion (_keyVersion pkp) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs @@ -1,12 +1,16 @@ --- PacketClass.hs: OpenPGP (RFC4880) data types --- Copyright © 2012-2022 Clint Adams +-- PacketClass.hs: OpenPGP (RFC9580) data types +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -31,32 +35,70 @@ data PacketType a :: Data.Kind.Type packetType :: a -> PacketType a packetCode :: PacketType a -> Word8 + dynamicPacketCode :: a -> Word8 toPkt :: a -> Pkt - fromPkt :: Pkt -> a + fromPktMaybe :: Pkt -> Maybe a + fromPktEither :: Pkt -> Either String a + + fromPktMaybe = either (const Nothing) Just . fromPktEither + dynamicPacketCode = packetCode . packetType -data PKESK = - PKESK - { _pkeskPacketVersion :: PacketVersion - , _pkeskEightOctetKeyId :: EightOctetKeyId - , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm - , _pkeskMPIs :: NonEmpty MPI - } - deriving (Data, Eq, Show, Typeable) +coercionError :: String -> Pkt -> Either String a +coercionError expected pkt = + Left + ("Cannot coerce non-" ++ + expected ++ " packet (tag " ++ show (pktTag pkt) ++ ")") -instance Packet PKESK where - data PacketType PKESK = PKESKType - deriving (Show, Eq) +data PKESK (v :: PKESKPayloadVersion) where + PKESK3Packet :: + PacketVersion + -> EightOctetKeyId + -> PubKeyAlgorithm + -> NonEmpty MPI + -> PKESK 'PKESKV3 + PKESK6Packet :: + BL.ByteString + -> PubKeyAlgorithm + -> BL.ByteString + -> PKESK 'PKESKV6 + +deriving instance Eq (PKESK v) +deriving instance Show (PKESK v) + +instance Packet (PKESK 'PKESKV3) where + data PacketType (PKESK 'PKESKV3) = PKESKType + deriving (Show, Eq) packetType _ = PKESKType packetCode _ = 1 - toPkt (PKESK a b c d) = PKESKPkt a b c d - fromPkt (PKESKPkt a b c d) = PKESK a b c d - fromPkt _ = error "Cannot coerce non-PKESK packet" + toPkt (PKESK3Packet version keyid pka mpis) = + PKESKPkt (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 = coercionError "PKESK" pkt -instance Pretty PKESK where +instance Pretty (PKESK 'PKESKV3) where pretty = pretty . toPkt +instance Packet (PKESK 'PKESKV6) where + data PacketType (PKESK 'PKESKV6) = PKESK6Type + deriving (Show, Eq) + packetType _ = PKESK6Type + packetCode _ = 1 + toPkt (PKESK6Packet recipientKeyIdentifier pka esk) = + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk)) + fromPktEither (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = + Right (PKESK6Packet recipientKeyIdentifier pka esk) + fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ _ _))) = + Left "Cannot coerce PKESKv3 packet to PKESKv6" + fromPktEither pkt = coercionError "PKESKv6" pkt + +instance Pretty (PKESK 'PKESKV6) where + pretty = pretty . toPkt + newtype Signature = - Signature -- FIXME? + Signature { _signaturePayload :: SignaturePayload } deriving (Data, Eq, Show, Typeable) @@ -67,59 +109,204 @@ packetType _ = SignatureType packetCode _ = 2 toPkt (Signature a) = SignaturePkt a - fromPkt (SignaturePkt a) = Signature a - fromPkt _ = error "Cannot coerce non-Signature packet" + fromPktMaybe (SignaturePkt a) = Just (Signature a) + fromPktMaybe _ = Nothing + fromPktEither (SignaturePkt a) = Right (Signature a) + fromPktEither pkt = coercionError "Signature" pkt instance Pretty Signature where pretty = pretty . toPkt -data SKESK = - SKESK - { _skeskPacketVersion :: PacketVersion - , _skeskSymmetricAlgorithm :: SymmetricAlgorithm - , _skeskS2K :: S2K - , _skeskESK :: Maybe BL.ByteString - } - deriving (Data, Eq, Show, Typeable) +data SignatureV (v :: SignaturePayloadVersion) where + SignatureV3Packet :: SignaturePayloadV 'SigPayloadV3 -> SignatureV 'SigPayloadV3 + SignatureV4Packet :: SignaturePayloadV 'SigPayloadV4 -> SignatureV 'SigPayloadV4 + SignatureV6Packet :: SignaturePayloadV 'SigPayloadV6 -> SignatureV 'SigPayloadV6 + SignatureVOtherPacket :: SignaturePayloadV 'SigPayloadVOther -> SignatureV 'SigPayloadVOther -instance Packet SKESK where - data PacketType SKESK = SKESKType - deriving (Show, Eq) +deriving instance Eq (SignatureV v) +deriving instance Show (SignatureV v) + +data SomeSignatureV where + SomeSignatureV :: SignatureV v -> SomeSignatureV + +signaturePayloadFromSignatureV :: SignatureV v -> SignaturePayload +signaturePayloadFromSignatureV (SignatureV3Packet payload) = toSignaturePayload payload +signaturePayloadFromSignatureV (SignatureV4Packet payload) = toSignaturePayload payload +signaturePayloadFromSignatureV (SignatureV6Packet payload) = toSignaturePayload payload +signaturePayloadFromSignatureV (SignatureVOtherPacket payload) = toSignaturePayload payload + +fromPktEitherSomeSignatureV :: Pkt -> Either String SomeSignatureV +fromPktEitherSomeSignatureV (SignaturePkt payload) = + Right (someSignatureVFromPayload payload) +fromPktEitherSomeSignatureV pkt = + coercionError "Signature" pkt + +someSignatureVFromPayload :: SignaturePayload -> SomeSignatureV +someSignatureVFromPayload payload = + case toSomeSignaturePayload payload of + SomeSignaturePayload (typedPayload@SigPayloadV3Data {}) -> + SomeSignatureV (SignatureV3Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadV4Data {}) -> + SomeSignatureV (SignatureV4Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadV6Data {}) -> + SomeSignatureV (SignatureV6Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadOtherData {}) -> + SomeSignatureV (SignatureVOtherPacket typedPayload) + +instance Packet (SignatureV 'SigPayloadV3) where + data PacketType (SignatureV 'SigPayloadV3) = SignatureV3Type + deriving (Show, Eq) + packetType _ = SignatureV3Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV3Packet <$> asSignaturePayloadV3 payload + fromPktEither pkt = coercionError "SignatureV3" pkt + +instance Pretty (SignatureV 'SigPayloadV3) where + pretty = pretty . toPkt + +instance Packet (SignatureV 'SigPayloadV4) where + data PacketType (SignatureV 'SigPayloadV4) = SignatureV4Type + deriving (Show, Eq) + packetType _ = SignatureV4Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV4Packet <$> asSignaturePayloadV4 payload + fromPktEither pkt = coercionError "SignatureV4" pkt + +instance Pretty (SignatureV 'SigPayloadV4) where + pretty = pretty . toPkt + +instance Packet (SignatureV 'SigPayloadV6) where + data PacketType (SignatureV 'SigPayloadV6) = SignatureV6Type + deriving (Show, Eq) + packetType _ = SignatureV6Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV6Packet <$> asSignaturePayloadV6 payload + fromPktEither pkt = coercionError "SignatureV6" pkt + +instance Pretty (SignatureV 'SigPayloadV6) where + pretty = pretty . toPkt + +instance Packet (SignatureV 'SigPayloadVOther) where + data PacketType (SignatureV 'SigPayloadVOther) = SignatureVOtherType + deriving (Show, Eq) + packetType _ = SignatureVOtherType + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureVOtherPacket <$> asSignaturePayloadOther payload + fromPktEither pkt = coercionError "SignatureVOther" pkt + +instance Pretty (SignatureV 'SigPayloadVOther) where + pretty = pretty . toPkt + +data SKESK (v :: SKESKPayloadVersion) where + SKESK4Packet :: + SymmetricAlgorithm + -> S2K + -> Maybe BL.ByteString + -> SKESK 'SKESKV4 + SKESK6Packet :: + SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> BL.ByteString + -> BL.ByteString + -> BL.ByteString + -> SKESK 'SKESKV6 + +deriving instance Eq (SKESK v) +deriving instance Show (SKESK v) + +instance Packet (SKESK 'SKESKV4) where + data PacketType (SKESK 'SKESKV4) = SKESKType + deriving (Show, Eq) packetType _ = SKESKType packetCode _ = 3 - toPkt (SKESK a b c d) = SKESKPkt a b c d - fromPkt (SKESKPkt a b c d) = SKESK a b c d - fromPkt _ = error "Cannot coerce non-SKESK packet" + toPkt (SKESK4Packet symalgo s2k esk) = + 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 = coercionError "SKESK" pkt -instance Pretty SKESK where +instance Pretty (SKESK 'SKESKV4) where pretty = pretty . toPkt -data OnePassSignature = - OnePassSignature - { _onePassSignaturePacketVersion :: PacketVersion - , _onePassSignatureSigType :: SigType - , _onePassSignatureHashAlgorithm :: HashAlgorithm - , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm - , _onePassSignatureEightOctetKeyId :: EightOctetKeyId - , _onePassSignatureNestedFlag :: NestedFlag - } - deriving (Data, Eq, Show, Typeable) +instance Packet (SKESK 'SKESKV6) where + data PacketType (SKESK 'SKESKV6) = SKESK6Type + deriving (Show, Eq) + packetType _ = SKESK6Type + packetCode _ = 3 + toPkt (SKESK6Packet symalgo aead s2k iv esk tag) = + SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) + fromPktEither (SKESKPkt (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 = coercionError "SKESKv6" pkt -instance Packet OnePassSignature where - data PacketType OnePassSignature = OnePassSignatureType - deriving (Show, Eq) +instance Pretty (SKESK 'SKESKV6) where + pretty = pretty . toPkt + +data OnePassSignature (v :: OnePassSignatureVersion) where + OnePassSignatureV3Packet :: + PacketVersion + -> SigType + -> HashAlgorithm + -> PubKeyAlgorithm + -> EightOctetKeyId + -> NestedFlag + -> OnePassSignature 'OPSV3 + OnePassSignatureV6Packet :: + SigType + -> HashAlgorithm + -> PubKeyAlgorithm + -> SignatureSalt + -> ByteString + -> NestedFlag + -> OnePassSignature 'OPSV6 + +deriving instance Eq (OnePassSignature v) +deriving instance Show (OnePassSignature v) + +instance Packet (OnePassSignature 'OPSV3) where + data PacketType (OnePassSignature 'OPSV3) = OnePassSignatureType + deriving (Show, Eq) packetType _ = OnePassSignatureType packetCode _ = 4 - toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f - fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f - fromPkt _ = error "Cannot coerce non-OnePassSignature packet" + toPkt (OnePassSignatureV3Packet a b c d e f) = + OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f)) + fromPktEither (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f))) = + Right (OnePassSignatureV3Packet a b c d e f) + fromPktEither pkt = coercionError "OnePassSignature" pkt -instance Pretty OnePassSignature where +instance Pretty (OnePassSignature 'OPSV3) where pretty = pretty . toPkt +instance Packet (OnePassSignature 'OPSV6) where + data PacketType (OnePassSignature 'OPSV6) = OnePassSignatureV6Type + deriving (Show, Eq) + packetType _ = OnePassSignatureV6Type + packetCode _ = 4 + toPkt (OnePassSignatureV6Packet a b c d e f) = + OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f)) + fromPktEither (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f))) = + Right (OnePassSignatureV6Packet a b c d e f) + fromPktEither pkt = coercionError "OnePassSignatureV6" pkt + +instance Pretty (OnePassSignature 'OPSV6) where + pretty = pretty . toPkt + data SecretKey = SecretKey - { _secretKeyPKPayload :: PKPayload + { _secretKeyPKPayload :: SomePKPayload , _secretKeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) @@ -130,15 +317,15 @@ packetType _ = SecretKeyType packetCode _ = 5 toPkt (SecretKey a b) = SecretKeyPkt a b - fromPkt (SecretKeyPkt a b) = SecretKey a b - fromPkt _ = error "Cannot coerce non-SecretKey packet" + fromPktEither (SecretKeyPkt a b) = Right (SecretKey a b) + fromPktEither pkt = coercionError "SecretKey" pkt instance Pretty SecretKey where pretty = pretty . toPkt newtype PublicKey = PublicKey - { _publicKeyPKPayload :: PKPayload + { _publicKeyPKPayload :: SomePKPayload } deriving (Data, Eq, Show, Typeable) @@ -148,15 +335,15 @@ packetType _ = PublicKeyType packetCode _ = 6 toPkt (PublicKey a) = PublicKeyPkt a - fromPkt (PublicKeyPkt a) = PublicKey a - fromPkt _ = error "Cannot coerce non-PublicKey packet" + fromPktEither (PublicKeyPkt a) = Right (PublicKey a) + fromPktEither pkt = coercionError "PublicKey" pkt instance Pretty PublicKey where pretty = pretty . toPkt data SecretSubkey = SecretSubkey - { _secretSubkeyPKPayload :: PKPayload + { _secretSubkeyPKPayload :: SomePKPayload , _secretSubkeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) @@ -167,8 +354,8 @@ packetType _ = SecretSubkeyType packetCode _ = 7 toPkt (SecretSubkey a b) = SecretSubkeyPkt a b - fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b - fromPkt _ = error "Cannot coerce non-SecretSubkey packet" + fromPktEither (SecretSubkeyPkt a b) = Right (SecretSubkey a b) + fromPktEither pkt = coercionError "SecretSubkey" pkt instance Pretty SecretSubkey where pretty = pretty . toPkt @@ -186,8 +373,8 @@ packetType _ = CompressedDataType packetCode _ = 8 toPkt (CompressedData a b) = CompressedDataPkt a b - fromPkt (CompressedDataPkt a b) = CompressedData a b - fromPkt _ = error "Cannot coerce non-CompressedData packet" + fromPktEither (CompressedDataPkt a b) = Right (CompressedData a b) + fromPktEither pkt = coercionError "CompressedData" pkt instance Pretty CompressedData where pretty = pretty . toPkt @@ -204,8 +391,8 @@ packetType _ = SymEncDataType packetCode _ = 9 toPkt (SymEncData a) = SymEncDataPkt a - fromPkt (SymEncDataPkt a) = SymEncData a - fromPkt _ = error "Cannot coerce non-SymEncData packet" + fromPktEither (SymEncDataPkt a) = Right (SymEncData a) + fromPktEither pkt = coercionError "SymEncData" pkt instance Pretty SymEncData where pretty = pretty . toPkt @@ -222,8 +409,8 @@ packetType _ = MarkerType packetCode _ = 10 toPkt (Marker a) = MarkerPkt a - fromPkt (MarkerPkt a) = Marker a - fromPkt _ = error "Cannot coerce non-Marker packet" + fromPktEither (MarkerPkt a) = Right (Marker a) + fromPktEither pkt = coercionError "Marker" pkt instance Pretty Marker where pretty = pretty . toPkt @@ -243,8 +430,8 @@ packetType _ = LiteralDataType packetCode _ = 11 toPkt (LiteralData a b c d) = LiteralDataPkt a b c d - fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d - fromPkt _ = error "Cannot coerce non-LiteralData packet" + fromPktEither (LiteralDataPkt a b c d) = Right (LiteralData a b c d) + fromPktEither pkt = coercionError "LiteralData" pkt instance Pretty LiteralData where pretty = pretty . toPkt @@ -261,8 +448,8 @@ packetType _ = TrustType packetCode _ = 12 toPkt (Trust a) = TrustPkt a - fromPkt (TrustPkt a) = Trust a - fromPkt _ = error "Cannot coerce non-Trust packet" + fromPktEither (TrustPkt a) = Right (Trust a) + fromPktEither pkt = coercionError "Trust" pkt instance Pretty Trust where pretty = pretty . toPkt @@ -279,15 +466,15 @@ packetType _ = UserIdType packetCode _ = 13 toPkt (UserId a) = UserIdPkt a - fromPkt (UserIdPkt a) = UserId a - fromPkt _ = error "Cannot coerce non-UserId packet" + fromPktEither (UserIdPkt a) = Right (UserId a) + fromPktEither pkt = coercionError "UserId" pkt instance Pretty UserId where pretty = pretty . toPkt newtype PublicSubkey = PublicSubkey - { _publicSubkeyPKPayload :: PKPayload + { _publicSubkeyPKPayload :: SomePKPayload } deriving (Data, Eq, Show, Typeable) @@ -297,8 +484,8 @@ packetType _ = PublicSubkeyType packetCode _ = 14 toPkt (PublicSubkey a) = PublicSubkeyPkt a - fromPkt (PublicSubkeyPkt a) = PublicSubkey a - fromPkt _ = error "Cannot coerce non-PublicSubkey packet" + fromPktEither (PublicSubkeyPkt a) = Right (PublicSubkey a) + fromPktEither pkt = coercionError "PublicSubkey" pkt instance Pretty PublicSubkey where pretty = pretty . toPkt @@ -315,8 +502,8 @@ packetType _ = UserAttributeType packetCode _ = 17 toPkt (UserAttribute a) = UserAttributePkt a - fromPkt (UserAttributePkt a) = UserAttribute a - fromPkt _ = error "Cannot coerce non-UserAttribute packet" + fromPktEither (UserAttributePkt a) = Right (UserAttribute a) + fromPktEither pkt = coercionError "UserAttribute" pkt instance Pretty UserAttribute where pretty = pretty . toPkt @@ -326,6 +513,12 @@ { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion , _symEncIntegrityProtectedDataPayload :: ByteString } + | SymEncIntegrityProtectedDataV2 + SymmetricAlgorithm + AEADAlgorithm + Word8 + Salt + ByteString deriving (Data, Eq, Show, Typeable) instance Packet SymEncIntegrityProtectedData where @@ -334,10 +527,14 @@ deriving (Show, Eq) packetType _ = SymEncIntegrityProtectedDataType packetCode _ = 18 - toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b - fromPkt (SymEncIntegrityProtectedDataPkt a b) = - SymEncIntegrityProtectedData a b - fromPkt _ = error "Cannot coerce non-SymEncIntegrityProtectedData packet" + toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt (SEIPD1 a b) + toPkt (SymEncIntegrityProtectedDataV2 a b c d e) = + SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e) + fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD1 a b)) = + Right (SymEncIntegrityProtectedData a b) + fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e)) = + Right (SymEncIntegrityProtectedDataV2 a b c d e) + fromPktEither pkt = coercionError "SymEncIntegrityProtectedData" pkt instance Pretty SymEncIntegrityProtectedData where pretty = pretty . toPkt @@ -355,8 +552,8 @@ packetType _ = ModificationDetectionCodeType packetCode _ = 19 toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a - fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a - fromPkt _ = error "Cannot coerce non-ModificationDetectionCode packet" + fromPktEither (ModificationDetectionCodePkt a) = Right (ModificationDetectionCode a) + fromPktEither pkt = coercionError "ModificationDetectionCode" pkt instance Pretty ModificationDetectionCode where pretty = pretty . toPkt @@ -372,10 +569,11 @@ data PacketType OtherPacket = OtherPacketType deriving (Show, Eq) packetType _ = OtherPacketType - packetCode _ = undefined -- FIXME + packetCode _ = error "OtherPacket has no static packet type code" + dynamicPacketCode = _otherPacketType toPkt (OtherPacket a b) = OtherPacketPkt a b - fromPkt (OtherPacketPkt a b) = OtherPacket a b - fromPkt _ = error "Cannot coerce non-OtherPacket packet" + fromPktEither (OtherPacketPkt a b) = Right (OtherPacket a b) + fromPktEither pkt = coercionError "OtherPacket" pkt instance Pretty OtherPacket where pretty = pretty . toPkt @@ -392,25 +590,18 @@ data PacketType BrokenPacket = BrokenPacketType deriving (Show, Eq) packetType _ = BrokenPacketType - packetCode _ = undefined + packetCode _ = error "BrokenPacket has no static packet type code" + dynamicPacketCode = _brokenPacketType toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c - fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c - fromPkt _ = error "Cannot coerce non-BrokenPacket packet" + fromPktEither (BrokenPacketPkt a b c) = Right (BrokenPacket a b c) + fromPktEither pkt = coercionError "BrokenPacket" pkt instance Pretty BrokenPacket where pretty = pretty . toPkt -$(makeLenses ''PKESK) - $(makeLenses ''Signature) -$(makeLenses ''SKESK) - -$(makeLenses ''OnePassSignature) - $(makeLenses ''SecretKey) - -$(makeLenses ''PKPayload) $(makeLenses ''PublicKey) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -1,13 +1,18 @@ --- Pkt.hs: OpenPGP (RFC4880) Pkt data types --- Copyright © 2012-2022 Clint Adams +-- Pkt.hs: OpenPGP (RFC9580) Pkt data types +-- 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 #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.Pkt where @@ -23,7 +28,8 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL -import Data.Data (Data) +import Data.Data (Data(..), Constr, mkDataType, mkConstr, Fixity(Prefix)) +import qualified Data.Data as DD import Data.Hashable (Hashable(..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -35,51 +41,264 @@ import Data.Word (Word8) import Prettyprinter (Pretty(..), (<+>)) +data PKESKPayloadVersion = PKESKV3 | PKESKV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data PKESKPayloadV3 = + PKESKPayloadV3 + PacketVersion + EightOctetKeyId + PubKeyAlgorithm + (NonEmpty MPI) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data PKESKPayloadV6 = + PKESKPayloadV6 + BL.ByteString + PubKeyAlgorithm + BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data PKESKPayload + = PKESKPayloadV3Packet PKESKPayloadV3 + | PKESKPayloadV6Packet PKESKPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data SKESKPayloadVersion = SKESKV4 | SKESKV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data SKESKPayloadV4 = + SKESKPayloadV4 + SymmetricAlgorithm + S2K + (Maybe BL.ByteString) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data SKESKPayloadV6 = + SKESKPayloadV6 + SymmetricAlgorithm + AEADAlgorithm + S2K + BL.ByteString + BL.ByteString + BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data SKESKPayload + = SKESKPayloadV4Packet SKESKPayloadV4 + | SKESKPayloadV6Packet SKESKPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data OnePassSignatureVersion = OPSV3 | OPSV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data OPSPayloadV3 = + OPSPayloadV3 + PacketVersion + SigType + HashAlgorithm + PubKeyAlgorithm + EightOctetKeyId + NestedFlag + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data OPSPayloadV6 = + OPSPayloadV6 + SigType + HashAlgorithm + PubKeyAlgorithm + SignatureSalt + BL.ByteString + NestedFlag + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data OnePassSignaturePayload + = OPSPayloadV3Packet OPSPayloadV3 + | OPSPayloadV6Packet OPSPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data SEIPDPayload + = SEIPD1 PacketVersion BL.ByteString + | SEIPD2 SymmetricAlgorithm AEADAlgorithm Word8 Salt BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data KeyPktKind + = PublicPkt + | SecretPkt + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data KeyPktRole + = KeyPktPrimary + | KeyPktSubkey + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +data KeyPkt (k :: KeyPktKind) where + KeyPktPublicPrimary :: SomePKPayload -> KeyPkt 'PublicPkt + KeyPktPublicSubkey :: SomePKPayload -> KeyPkt 'PublicPkt + KeyPktSecretPrimary :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt + KeyPktSecretSubkey :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt + +deriving instance Eq (KeyPkt k) +deriving instance Show (KeyPkt k) + +instance Ord (KeyPkt k) where + compare = comparing keyPktToPkt + +instance Hashable (KeyPkt k) where + hashWithSalt s kp = hashWithSalt s (keyPktToPkt kp) + +instance Typeable k => Data (KeyPkt k) where + gfoldl f z (KeyPktPublicPrimary pkp) = z KeyPktPublicPrimary `f` pkp + gfoldl f z (KeyPktPublicSubkey pkp) = z KeyPktPublicSubkey `f` pkp + gfoldl f z (KeyPktSecretPrimary pkp ska) = z KeyPktSecretPrimary `f` pkp `f` ska + gfoldl f z (KeyPktSecretSubkey pkp ska) = z KeyPktSecretSubkey `f` pkp `f` ska + + toConstr (KeyPktPublicPrimary _) = conKeyPktPublicPrimary + toConstr (KeyPktPublicSubkey _) = conKeyPktPublicSubkey + toConstr (KeyPktSecretPrimary _ _) = conKeyPktSecretPrimary + toConstr (KeyPktSecretSubkey _ _) = conKeyPktSecretSubkey + + dataTypeOf _ = tyKeyPkt + + gunfold _ _ _ = error "KeyPkt: gunfold not supported for GADT" + +tyKeyPkt :: DD.DataType +tyKeyPkt = mkDataType "Codec.Encryption.OpenPGP.Types.Internal.Pkt.KeyPkt" + [ conKeyPktPublicPrimary + , conKeyPktPublicSubkey + , conKeyPktSecretPrimary + , conKeyPktSecretSubkey + ] + +conKeyPktPublicPrimary, conKeyPktPublicSubkey, + conKeyPktSecretPrimary, conKeyPktSecretSubkey :: Constr +conKeyPktPublicPrimary = mkConstr tyKeyPkt "KeyPktPublicPrimary" [] Prefix +conKeyPktPublicSubkey = mkConstr tyKeyPkt "KeyPktPublicSubkey" [] Prefix +conKeyPktSecretPrimary = mkConstr tyKeyPkt "KeyPktSecretPrimary" [] Prefix +conKeyPktSecretSubkey = mkConstr tyKeyPkt "KeyPktSecretSubkey" [] Prefix + +data SomeKeyPkt where + SomeKeyPkt :: KeyPkt k -> SomeKeyPkt + +deriving instance Show SomeKeyPkt + +instance Eq SomeKeyPkt where + SomeKeyPkt left == SomeKeyPkt right = 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 PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI) + = PKESKPkt PKESKPayload | SignaturePkt SignaturePayload - | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString) - | OnePassSignaturePkt - PacketVersion - SigType - HashAlgorithm - PubKeyAlgorithm - EightOctetKeyId - NestedFlag - | SecretKeyPkt PKPayload SKAddendum - | PublicKeyPkt PKPayload - | SecretSubkeyPkt PKPayload SKAddendum + | SKESKPkt SKESKPayload + | OnePassSignaturePkt OnePassSignaturePayload + | SecretKeyPkt SomePKPayload SKAddendum + | PublicKeyPkt SomePKPayload + | SecretSubkeyPkt SomePKPayload SKAddendum | CompressedDataPkt CompressionAlgorithm CompressedDataPayload | SymEncDataPkt ByteString | MarkerPkt ByteString | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString | TrustPkt ByteString | UserIdPkt Text - | PublicSubkeyPkt PKPayload + | PublicSubkeyPkt SomePKPayload | UserAttributePkt [UserAttrSubPacket] - | SymEncIntegrityProtectedDataPkt PacketVersion ByteString + | SymEncIntegrityProtectedDataPkt SEIPDPayload | ModificationDetectionCodePkt ByteString | OtherPacketPkt Word8 ByteString | BrokenPacketPkt String Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) +data PktWithWireRep = + PktWithWireRep + { _pktWireRepRef :: WireRepRef + , _pktRange :: ByteRange + , _pktRaw :: ByteString + , _pktIndex :: Int + , _pktValue :: Pkt + } + deriving (Data, Eq, Generic, Show, Typeable) + instance Hashable Pkt instance Ord Pkt where - compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? + compare p1 p2 = comparing pktTag p1 p2 <> compareFields p1 p2 + where + compareFields (PKESKPkt pkesk1) (PKESKPkt pkesk2) = compare pkesk1 pkesk2 + compareFields (SignaturePkt sp1) (SignaturePkt sp2) = compare sp1 sp2 + compareFields (SKESKPkt skesk1) (SKESKPkt skesk2) = compare skesk1 skesk2 + compareFields (OnePassSignaturePkt ops1) (OnePassSignaturePkt ops2) = compare ops1 ops2 + compareFields (SecretKeyPkt pkp1 ska1) (SecretKeyPkt pkp2 ska2) = + compare pkp1 pkp2 <> compare ska1 ska2 + compareFields (PublicKeyPkt pkp1) (PublicKeyPkt pkp2) = compare pkp1 pkp2 + compareFields (SecretSubkeyPkt pkp1 ska1) (SecretSubkeyPkt pkp2 ska2) = + compare pkp1 pkp2 <> compare ska1 ska2 + compareFields (CompressedDataPkt ca1 cdp1) (CompressedDataPkt ca2 cdp2) = + compare ca1 ca2 <> compare cdp1 cdp2 + compareFields (SymEncDataPkt bs1) (SymEncDataPkt bs2) = compare bs1 bs2 + compareFields (MarkerPkt bs1) (MarkerPkt bs2) = compare bs1 bs2 + compareFields (LiteralDataPkt dt1 fn1 ts1 bs1) (LiteralDataPkt dt2 fn2 ts2 bs2) = + compare dt1 dt2 <> compare fn1 fn2 <> compare ts1 ts2 <> compare bs1 bs2 + compareFields (TrustPkt bs1) (TrustPkt bs2) = compare bs1 bs2 + compareFields (UserIdPkt u1) (UserIdPkt u2) = compare u1 u2 + compareFields (PublicSubkeyPkt pkp1) (PublicSubkeyPkt pkp2) = compare pkp1 pkp2 + compareFields (UserAttributePkt us1) (UserAttributePkt us2) = compare us1 us2 + compareFields (SymEncIntegrityProtectedDataPkt seipd1) (SymEncIntegrityProtectedDataPkt seipd2) = compare seipd1 seipd2 + compareFields (ModificationDetectionCodePkt bs1) (ModificationDetectionCodePkt bs2) = compare bs1 bs2 + compareFields (OtherPacketPkt t1 bs1) (OtherPacketPkt t2 bs2) = compare t1 t2 <> compare bs1 bs2 + compareFields (BrokenPacketPkt s1 t1 bs1) (BrokenPacketPkt s2 t2 bs2) = + compare s1 s2 <> compare t1 t2 <> compare bs1 bs2 + compareFields _ _ = EQ +instance Ord PktWithWireRep where + compare p1 p2 = + comparing _pktValue p1 p2 <> + comparing _pktRaw p1 p2 <> + comparing _pktWireRepRef p1 p2 <> + comparing _pktRange p1 p2 <> + comparing _pktIndex p1 p2 + +wireRepOfPkt :: PktWithWireRep -> WireRepRef +wireRepOfPkt = _pktWireRepRef + +packetsFromWireRep :: WireRepRef -> [PktWithWireRep] -> [PktWithWireRep] +packetsFromWireRep src = filter ((== src) . wireRepOfPkt) + instance Pretty Pkt where - pretty (PKESKPkt pv eoki pka mpis) = + pretty (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = pretty "PKESK v" <> pretty pv <> pretty ':' <+> pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis + pretty (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = + pretty "PKESK v6:" <+> + pretty "recipient key identifier" <+> + pretty (bsToHexUpper recipientKeyIdentifier) <+> + pretty pka <+> pretty (bsToHexUpper esk) pretty (SignaturePkt sp) = pretty sp - pretty (SKESKPkt pv sa s2k mbs) = - pretty "SKESK v" <> pretty pv <> pretty ':' <+> + pretty (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = + pretty "SKESK v4:" <+> pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs) - pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = + pretty (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))) = + pretty "SKESK v6:" <+> + pretty sa <+> + pretty aa <+> + pretty s2k <+> + pretty (bsToHexUpper iv) <+> + pretty (bsToHexUpper esk) <+> + pretty (bsToHexUpper tag) + pretty (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag))) = pretty "one-pass signature v" <> pretty pv <> pretty ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag + pretty (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag))) = + pretty "one-pass signature v6:" <+> + pretty st <+> + pretty ha <+> + pretty pka <+> pretty salt <+> pretty (bsToHexUpper signerFingerprint) <+> + pretty nestedflag pretty (SecretKeyPkt pkp ska) = pretty "secret key:" <+> pretty pkp <+> pretty ska pretty (PublicKeyPkt pkp) = pretty "public key:" <+> pretty pkp @@ -97,10 +316,14 @@ pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp pretty (UserAttributePkt us) = pretty "user-attribute:" <+> pretty us - pretty (SymEncIntegrityProtectedDataPkt pv bs) = + pretty (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = pretty "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> pretty ':' <+> pretty (bsToHexUpper bs) + pretty (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = + pretty "symmetrically-encrypted-integrity-protected-data v2:" <+> + pretty sa <+> pretty aa <+> pretty chunkSize <+> pretty salt <+> + pretty (bsToHexUpper bs) pretty (ModificationDetectionCodePkt bs) = pretty "MDC:" <+> pretty (bsToHexUpper bs) pretty (OtherPacketPkt t bs) = @@ -111,7 +334,7 @@ pretty t <> pretty ':' <+> pretty (bsToHexUpper bs) instance A.ToJSON Pkt where - toJSON (PKESKPkt pv eoki pka mpis) = + toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = object [ key "pkesk" .= object @@ -121,19 +344,41 @@ , key "mpis" .= NE.toList mpis ] ] + toJSON (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = + object + [ key "pkesk_v6" .= + object + [ key "recipient_key_identifier" .= BL.unpack recipientKeyIdentifier + , key "pkalgo" .= pka + , key "esk" .= BL.unpack esk + ] + ] toJSON (SignaturePkt sp) = object [key "signature" .= sp] - toJSON (SKESKPkt pv sa s2k mbs) = + toJSON (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = object [ key "skesk" .= object - [ key "version" .= pv + [ key "version" .= (4 :: PacketVersion) , key "symalgo" .= sa , key "s2k" .= s2k , key "data" .= maybe mempty BL.unpack mbs ] ] - toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) = + toJSON (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))) = object + [ key "skesk-v6" .= + object + [ key "version" .= (6 :: PacketVersion) + , key "symalgo" .= sa + , key "aead" .= aa + , key "s2k" .= s2k + , key "iv" .= BL.unpack iv + , key "esk" .= BL.unpack esk + , key "tag" .= BL.unpack tag + ] + ] + toJSON (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag))) = + object [ key "onepasssignature" .= object [ key "version" .= pv @@ -144,6 +389,19 @@ , key "nested" .= nestedflag ] ] + toJSON (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag))) = + object + [ key "onepasssignature_v6" .= + object + [ key "version" .= (6 :: Word8) + , key "sigtype" .= st + , key "hashalgo" .= ha + , key "pkalgo" .= pka + , key "salt" .= salt + , key "fingerprint" .= BL.unpack signerFingerprint + , key "nested" .= nestedflag + ] + ] toJSON (SecretKeyPkt pkp ska) = object [ key "secretkey" .= @@ -176,11 +434,22 @@ toJSON (UserIdPkt u) = object [key "userid" .= u] toJSON (PublicSubkeyPkt pkp) = object [key "publicsubkkey" .= pkp] toJSON (UserAttributePkt us) = object [key "userattribute" .= us] - toJSON (SymEncIntegrityProtectedDataPkt pv bs) = + toJSON (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = object [ key "symencipd" .= object [key "version" .= pv, key "data" .= BL.unpack bs] ] + toJSON (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = + object + [ key "symencipd_v2" .= + object + [ key "symalgo" .= sa + , key "aeadalgo" .= aa + , key "chunksize" .= chunkSize + , key "salt" .= salt + , key "data" .= BL.unpack bs + ] + ] toJSON (ModificationDetectionCodePkt bs) = object [key "mdc" .= BL.unpack bs] toJSON (OtherPacketPkt t bs) = @@ -219,20 +488,112 @@ 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 +keyPktRole KeyPktSecretPrimary {} = KeyPktPrimary +keyPktRole KeyPktSecretSubkey {} = KeyPktSubkey + +keyPktPKPayload :: KeyPkt k -> SomePKPayload +keyPktPKPayload (KeyPktPublicPrimary pkp) = pkp +keyPktPKPayload (KeyPktPublicSubkey pkp) = pkp +keyPktPKPayload (KeyPktSecretPrimary pkp _) = pkp +keyPktPKPayload (KeyPktSecretSubkey pkp _) = pkp + +keyPktMaybeSKAddendum :: KeyPkt k -> Maybe SKAddendum +keyPktMaybeSKAddendum KeyPktPublicPrimary {} = Nothing +keyPktMaybeSKAddendum KeyPktPublicSubkey {} = Nothing +keyPktMaybeSKAddendum (KeyPktSecretPrimary _ ska) = Just ska +keyPktMaybeSKAddendum (KeyPktSecretSubkey _ ska) = Just ska + +keyPktTKKey :: KeyPkt k -> (SomePKPayload, Maybe SKAddendum) +keyPktTKKey keyPkt = (keyPktPKPayload keyPkt, keyPktMaybeSKAddendum keyPkt) + +secretKeyPktSKAddendum :: KeyPkt 'SecretPkt -> SKAddendum +secretKeyPktSKAddendum (KeyPktSecretPrimary _ ska) = ska +secretKeyPktSKAddendum (KeyPktSecretSubkey _ ska) = ska + +mkPrimaryKeyPkt :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt +mkPrimaryKeyPkt pkp Nothing = SomeKeyPkt (KeyPktPublicPrimary pkp) +mkPrimaryKeyPkt pkp (Just ska) = SomeKeyPkt (KeyPktSecretPrimary pkp ska) + +mkSubkeyKeyPkt :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt +mkSubkeyKeyPkt pkp Nothing = SomeKeyPkt (KeyPktPublicSubkey pkp) +mkSubkeyKeyPkt pkp (Just ska) = SomeKeyPkt (KeyPktSecretSubkey pkp ska) + +keyPktToPublicView :: KeyPkt 'SecretPkt -> KeyPkt 'PublicPkt +keyPktToPublicView (KeyPktSecretPrimary pkp _) = KeyPktPublicPrimary pkp +keyPktToPublicView (KeyPktSecretSubkey pkp _) = KeyPktPublicSubkey pkp + +keyPktToPkt :: KeyPkt k -> Pkt +keyPktToPkt (KeyPktPublicPrimary pkp) = PublicKeyPkt pkp +keyPktToPkt (KeyPktPublicSubkey pkp) = PublicSubkeyPkt pkp +keyPktToPkt (KeyPktSecretPrimary pkp ska) = SecretKeyPkt pkp ska +keyPktToPkt (KeyPktSecretSubkey pkp ska) = SecretSubkeyPkt pkp ska + +someKeyPktToPkt :: SomeKeyPkt -> Pkt +someKeyPktToPkt (SomeKeyPkt keyPkt) = keyPktToPkt keyPkt + +pktToSomeKeyPktEither :: Pkt -> Either KeyPktCoercionError SomeKeyPkt +pktToSomeKeyPktEither (PublicKeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicPrimary pkp)) +pktToSomeKeyPktEither (PublicSubkeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicSubkey pkp)) +pktToSomeKeyPktEither (SecretKeyPkt pkp ska) = Right (SomeKeyPkt (KeyPktSecretPrimary pkp ska)) +pktToSomeKeyPktEither (SecretSubkeyPkt pkp ska) = Right (SomeKeyPkt (KeyPktSecretSubkey pkp ska)) +pktToSomeKeyPktEither pkt = Left (NotAKeyPacket pkt) + +pktToSomeKeyPkt :: Pkt -> Maybe SomeKeyPkt +pktToSomeKeyPkt = either (const Nothing) Just . pktToSomeKeyPktEither + +pktToPublicKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt) +pktToPublicKeyPktEither (PublicKeyPkt pkp) = Right (KeyPktPublicPrimary pkp) +pktToPublicKeyPktEither (PublicSubkeyPkt pkp) = Right (KeyPktPublicSubkey pkp) +pktToPublicKeyPktEither pkt = Left (ExpectedPublicKeyPacket pkt) + +pktToPublicKeyPkt :: Pkt -> Maybe (KeyPkt 'PublicPkt) +pktToPublicKeyPkt = either (const Nothing) Just . pktToPublicKeyPktEither + +pktToSecretKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'SecretPkt) +pktToSecretKeyPktEither (SecretKeyPkt pkp ska) = Right (KeyPktSecretPrimary pkp ska) +pktToSecretKeyPktEither (SecretSubkeyPkt pkp ska) = Right (KeyPktSecretSubkey pkp ska) +pktToSecretKeyPktEither pkt = Left (ExpectedSecretKeyPacket pkt) + +pktToSecretKeyPkt :: Pkt -> Maybe (KeyPkt 'SecretPkt) +pktToSecretKeyPkt = either (const Nothing) Just . pktToSecretKeyPktEither + +-- | Convert secret key/subkey packets to their public-key packet forms. +-- Non-secret packets are returned unchanged. +publicKeyPacketOf :: Pkt -> Pkt +publicKeyPacketOf pkt = + maybe pkt (keyPktToPkt . keyPktToPublicView) (pktToSecretKeyPkt pkt) + data Verification = Verification - { _verificationSigner :: PKPayload + { _verificationSigner :: SomePKPayload , _verificationSignature :: SignaturePayload + , _verificationWarnings :: [VerificationWarning] } +data VerificationWarning + = MissingSubkeyBackSignatureWarning + deriving (Eq, Show) + data SOPVVerification = SOPVVerification { _sopvvDateStamp :: UTCTime - , _sopvvFingerprint :: TwentyOctetFingerprint - , _sopvvPrimaryFingerprint :: TwentyOctetFingerprint + , _sopvvFingerprint :: Fingerprint + , _sopvvPrimaryFingerprint :: Fingerprint , _sopvvMode :: String , _sopvvDescription :: String } $(makeLenses ''Verification) $(makeLenses ''SOPVVerification) +$(makeLenses ''PktWithWireRep) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs @@ -1,11 +1,18 @@ --- TK.hs: OpenPGP (RFC4880) transferable key data type --- Copyright © 2012-2016 Clint Adams +-- TK.hs: OpenPGP (RFC9580) transferable key data type +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Types.Internal.TK where @@ -15,31 +22,575 @@ import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt +import Control.Arrow ((&&&)) import Control.Lens (makeLenses) import qualified Data.Aeson.TH as ATH +import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.IxSet.Typed (IxSet) +import qualified Data.IxSet.Typed as IxSet +import Data.Kind (Type) +import Data.List (sortOn) +import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) import Data.Text (Text) import Data.Typeable (Typeable) -data TK = +-- | Zipper for navigating a list of packets with position context +data PacketZipper = + PacketZipper + { _zpBefore :: [PktWithWireRep] -- packets consumed before focus + , _zpCurrent :: PktWithWireRep -- current packet under focus + , _zpAfter :: [PktWithWireRep] -- packets remaining after focus + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +-- | Create a zipper from a list, starting at the first element +zFromList :: [PktWithWireRep] -> Maybe PacketZipper +zFromList [] = Nothing +zFromList (x:xs) = Just (PacketZipper [] x xs) + +-- | Extract position in packet sequence +zPosition :: PacketZipper -> Int +zPosition (PacketZipper before _ _) = length before + +-- | Move to the next packet in the sequence +zMoveNext :: PacketZipper -> Maybe PacketZipper +zMoveNext (PacketZipper before current []) = Nothing +zMoveNext (PacketZipper before current (x:xs)) = + Just (PacketZipper (before ++ [current]) x xs) + +-- | Get the remaining packets (current + after) +zRemaining :: PacketZipper -> [PktWithWireRep] +zRemaining (PacketZipper _ current after) = current : after + +-- | Reconstruct the full list from a zipper +zToList :: PacketZipper -> [PktWithWireRep] +zToList (PacketZipper before current after) = before ++ [current] ++ after + +data TKUnknown = + TKUnknown + { _tkuKey :: (SomePKPayload, Maybe SKAddendum) + , _tkuRevs :: [SignaturePayload] + , _tkuUIDs :: [(Text, [SignaturePayload])] + , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])] + , _tkuSubs :: [(Pkt, [SignaturePayload])] + } + deriving (Data, Eq, Generic, Show, Typeable) + +data TKKind + = PublicTK + | SecretTK + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +type family TKKindToKeyPktKind (k :: TKKind) :: KeyPktKind where + TKKindToKeyPktKind 'PublicTK = 'PublicPkt + TKKindToKeyPktKind 'SecretTK = 'SecretPkt + +data TK (k :: TKKind) = TK - { _tkKey :: (PKPayload, Maybe SKAddendum) + { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k) , _tkRevs :: [SignaturePayload] , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] - , _tkSubs :: [(Pkt, [SignaturePayload])] + , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])] } - deriving (Data, Eq, Generic, Show, Typeable) + deriving (Eq, Show) -instance Ord TK where - compare = comparing _tkKey -- FIXME: is this ridiculous? +deriving instance (Typeable k, Data (KeyPkt (TKKindToKeyPktKind k))) => Data (TK k) -$(ATH.deriveToJSON ATH.defaultOptions ''TK) +instance Ord (TK k) where + compare = comparing _tkPrimaryKey -type KeyringIxs = '[ EightOctetKeyId, TwentyOctetFingerprint, Text] +data SomeTK where + SomePublicTK :: TK 'PublicTK -> SomeTK + SomeSecretTK :: TK 'SecretTK -> SomeTK -type Keyring = IxSet KeyringIxs TK +deriving instance Show SomeTK +instance Eq SomeTK where + left == right = someTKToUnknown left == someTKToUnknown right + +tkToUnknown :: TK k -> TKUnknown +tkToUnknown tk = + TKUnknown + { _tkuKey = keyPktTKKey (_tkPrimaryKey tk) + , _tkuRevs = _tkRevs tk + , _tkuUIDs = _tkUIDs tk + , _tkuUAts = _tkUAts tk + , _tkuSubs = map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs tk) + } + +someTKToUnknown :: SomeTK -> TKUnknown +someTKToUnknown (SomePublicTK tk) = tkToUnknown tk +someTKToUnknown (SomeSecretTK tk) = tkToUnknown tk + +publicViewTK :: TK 'SecretTK -> TK 'PublicTK +publicViewTK tk = + TK + { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk) + , _tkRevs = _tkRevs tk + , _tkUIDs = _tkUIDs tk + , _tkUAts = _tkUAts tk + , _tkSubs = map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk) + } + +fromUnknownToTK :: TKUnknown -> Either String SomeTK +fromUnknownToTK tk = + case _tkuKey tk of + (pkp, Nothing) -> do + subs <- traverse liftPublicSubkey (_tkuSubs tk) + let typed :: TK 'PublicTK + typed = + TK + { _tkPrimaryKey = KeyPktPublicPrimary pkp + , _tkRevs = _tkuRevs tk + , _tkUIDs = _tkuUIDs tk + , _tkUAts = _tkuUAts tk + , _tkSubs = subs + } + Right + (SomePublicTK typed) + (pkp, Just ska) -> do + subs <- traverse liftSecretSubkey (_tkuSubs tk) + let typed :: TK 'SecretTK + typed = + TK + { _tkPrimaryKey = KeyPktSecretPrimary pkp ska + , _tkRevs = _tkuRevs tk + , _tkUIDs = _tkuUIDs tk + , _tkUAts = _tkuUAts tk + , _tkSubs = subs + } + Right + (SomeSecretTK typed) + where + liftPublicSubkey :: + (Pkt, [SignaturePayload]) + -> Either String (KeyPkt 'PublicPkt, [SignaturePayload]) + liftPublicSubkey (pkt, sigs) = + case pktToPublicKeyPkt pkt of + Just keyPkt + | keyPktRole keyPkt == KeyPktSubkey -> + Right (keyPkt, sigs) + | otherwise -> + Left "public subkey has primary-key role" + Nothing -> + Left ("expected public subkey, got packet tag " ++ show (pktTag pkt)) + + liftSecretSubkey :: + (Pkt, [SignaturePayload]) + -> Either String (KeyPkt 'SecretPkt, [SignaturePayload]) + liftSecretSubkey (pkt, sigs) = + case pktToSecretKeyPkt pkt of + Just keyPkt + | keyPktRole keyPkt == KeyPktSubkey -> + Right (keyPkt, sigs) + | otherwise -> + Left "secret subkey has primary-key role" + Nothing -> + Left ("expected secret subkey, got packet tag " ++ show (pktTag pkt)) + +data TKWithWireRep = + TKWithWireRep + { _tkWireRepRefs :: WireRepRefs + , _tkWireRepRange :: Maybe ByteRange + , _tkPackets :: [PktWithWireRep] + , _tkValue :: TKUnknown + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data PacketRefId = + PacketRefId + { _packetRefWireRepRef :: WireRepRef + , _packetRefIndex :: Int + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data SignatureWithWireRef = + SignatureWithWireRef + { _signatureWithWireRefValue :: SignaturePayload + , _signatureWithWireRefRef :: PacketRefId + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data UIDWithWireRefs = + UIDWithWireRefs + { _uidWithWireRefsValue :: Text + , _uidWithWireRefsRef :: PacketRefId + , _uidWithWireRefsSignatures :: [SignatureWithWireRef] + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data UATWithWireRefs = + UATWithWireRefs + { _uatWithWireRefsValue :: [UserAttrSubPacket] + , _uatWithWireRefsRef :: PacketRefId + , _uatWithWireRefsSignatures :: [SignatureWithWireRef] + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data SubkeyWithWireRefs = + SubkeyWithWireRefs + { _subkeyWithWireRefsValue :: Pkt + , _subkeyWithWireRefsRef :: PacketRefId + , _subkeyWithWireRefsSignatures :: [SignatureWithWireRef] + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data TKStructuredWithWireRep = + TKStructuredWithWireRep + { _tkStructuredWireRepRefs :: WireRepRefs + , _tkStructuredWireRepRange :: Maybe ByteRange + , _tkStructuredPrimaryKey :: (SomePKPayload, Maybe SKAddendum) + , _tkStructuredPrimaryKeyRef :: PacketRefId + , _tkStructuredDirectSignatures :: [SignatureWithWireRef] + , _tkStructuredUIDs :: [UIDWithWireRefs] + , _tkStructuredUAts :: [UATWithWireRefs] + , _tkStructuredSubkeys :: [SubkeyWithWireRefs] + , _tkStructuredPacketRefs :: [PktWithWireRep] + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data CanonicalizeTKWithWireRepError + = CanonicalizeStructuringError String + | CanonicalizeMissingPacketRef PacketRefId + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Ord TKUnknown where + -- TKUnknown ordering is identity-oriented: the primary key packet defines key identity, + -- while revocations, UIDs, and subkeys are mergeable metadata. + compare = comparing _tkuKey + +wireRepOfTK :: TKWithWireRep -> WireRepRef +wireRepOfTK = NE.head . _tkWireRepRefs + +wireRepsOfTK :: TKWithWireRep -> WireRepRefs +wireRepsOfTK = _tkWireRepRefs + +packetRefsOfTK :: TKWithWireRep -> [PktWithWireRep] +packetRefsOfTK = _tkPackets + +packetRefIdOf :: PktWithWireRep -> PacketRefId +packetRefIdOf pkt = PacketRefId (_pktWireRepRef pkt) (_pktIndex pkt) + +lookupPacketRef :: TKStructuredWithWireRep -> PacketRefId -> Maybe PktWithWireRep +lookupPacketRef structured target = + go (_tkStructuredPacketRefs structured) + where + go [] = Nothing + go (pkt:rest) + | packetRefIdOf pkt == target = Just pkt + | otherwise = go rest + +packetWireBytesForRef :: + TKStructuredWithWireRep + -> PacketRefId + -> Either CanonicalizeTKWithWireRepError BL.ByteString +packetWireBytesForRef structured refId = + case lookupPacketRef structured refId of + Just pkt -> Right (_pktRaw pkt) + Nothing -> Left (CanonicalizeMissingPacketRef refId) + +signatureWireSortKey :: + TKStructuredWithWireRep + -> SignatureWithWireRef + -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) +signatureWireSortKey structured sig = + (\raw -> (raw, _signatureWithWireRefRef sig)) <$> + packetWireBytesForRef structured (_signatureWithWireRefRef sig) + +uidWireSortKey :: + TKStructuredWithWireRep + -> UIDWithWireRefs + -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) +uidWireSortKey structured uid = + (\raw -> (raw, _uidWithWireRefsRef uid)) <$> + packetWireBytesForRef structured (_uidWithWireRefsRef uid) + +uatWireSortKey :: + TKStructuredWithWireRep + -> UATWithWireRefs + -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) +uatWireSortKey structured uat = + (\raw -> (raw, _uatWithWireRefsRef uat)) <$> + packetWireBytesForRef structured (_uatWithWireRefsRef uat) + +subkeyWireSortKey :: + TKStructuredWithWireRep + -> SubkeyWithWireRefs + -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) +subkeyWireSortKey structured sub = + (\raw -> (raw, _subkeyWithWireRefsRef sub)) <$> + packetWireBytesForRef structured (_subkeyWithWireRefsRef sub) + +compareSignatureWithWireRefCanonical :: + TKStructuredWithWireRep + -> SignatureWithWireRef + -> SignatureWithWireRef + -> Either CanonicalizeTKWithWireRepError Ordering +compareSignatureWithWireRefCanonical structured a b = + compare <$> signatureWireSortKey structured a <*> signatureWireSortKey structured b + +compareUIDWithWireRefsCanonical :: + TKStructuredWithWireRep + -> UIDWithWireRefs + -> UIDWithWireRefs + -> Either CanonicalizeTKWithWireRepError Ordering +compareUIDWithWireRefsCanonical structured a b = + compare <$> uidWireSortKey structured a <*> uidWireSortKey structured b + +compareUATWithWireRefsCanonical :: + TKStructuredWithWireRep + -> UATWithWireRefs + -> UATWithWireRefs + -> Either CanonicalizeTKWithWireRepError Ordering +compareUATWithWireRefsCanonical structured a b = + compare <$> uatWireSortKey structured a <*> uatWireSortKey structured b + +compareSubkeyWithWireRefsCanonical :: + TKStructuredWithWireRep + -> SubkeyWithWireRefs + -> SubkeyWithWireRefs + -> Either CanonicalizeTKWithWireRepError Ordering +compareSubkeyWithWireRefsCanonical structured a b = + compare <$> subkeyWireSortKey structured a <*> subkeyWireSortKey structured b + +sortCanonicalByKey :: + Ord key + => (a -> Either CanonicalizeTKWithWireRepError key) + -> [a] + -> Either CanonicalizeTKWithWireRepError [a] +sortCanonicalByKey keyFn xs = + map snd . sortOn fst <$> traverse (\x -> (\k -> (k, x)) <$> keyFn x) xs + +sortSignatureWithWireRefsCanonical :: + TKStructuredWithWireRep + -> [SignatureWithWireRef] + -> Either CanonicalizeTKWithWireRepError [SignatureWithWireRef] +sortSignatureWithWireRefsCanonical structured = + sortCanonicalByKey (signatureWireSortKey structured) + +sortUIDWithWireRefsCanonical :: + TKStructuredWithWireRep + -> [UIDWithWireRefs] + -> Either CanonicalizeTKWithWireRepError [UIDWithWireRefs] +sortUIDWithWireRefsCanonical structured uids = do + normalized <- + traverse + (\uid -> + (\sigs -> uid {_uidWithWireRefsSignatures = sigs}) <$> + sortSignatureWithWireRefsCanonical structured (_uidWithWireRefsSignatures uid)) + uids + sortCanonicalByKey (uidWireSortKey structured) normalized + +sortUATWithWireRefsCanonical :: + TKStructuredWithWireRep + -> [UATWithWireRefs] + -> Either CanonicalizeTKWithWireRepError [UATWithWireRefs] +sortUATWithWireRefsCanonical structured uats = do + normalized <- + traverse + (\uat -> + (\sigs -> uat {_uatWithWireRefsSignatures = sigs}) <$> + sortSignatureWithWireRefsCanonical structured (_uatWithWireRefsSignatures uat)) + uats + sortCanonicalByKey (uatWireSortKey structured) normalized + +sortSubkeyWithWireRefsCanonical :: + TKStructuredWithWireRep + -> [SubkeyWithWireRefs] + -> Either CanonicalizeTKWithWireRepError [SubkeyWithWireRefs] +sortSubkeyWithWireRefsCanonical structured subs = do + normalized <- + traverse + (\sub -> + (\sigs -> sub {_subkeyWithWireRefsSignatures = sigs}) <$> + sortSignatureWithWireRefsCanonical structured (_subkeyWithWireRefsSignatures sub)) + subs + sortCanonicalByKey (subkeyWireSortKey structured) normalized + +canonicalizeTKStructuredWithWireRep :: + TKStructuredWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown +canonicalizeTKStructuredWithWireRep structured = + buildTK <$> + sortSignatureWithWireRefsCanonical structured (_tkStructuredDirectSignatures structured) <*> + sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured) <*> + sortUATWithWireRefsCanonical structured (_tkStructuredUAts structured) <*> + sortSubkeyWithWireRefsCanonical structured (_tkStructuredSubkeys structured) + where + buildTK directSigs uids uats subs = + TKUnknown + { _tkuKey = _tkStructuredPrimaryKey structured + , _tkuRevs = map _signatureWithWireRefValue directSigs + , _tkuUIDs = + map + (_uidWithWireRefsValue &&& + (map _signatureWithWireRefValue . _uidWithWireRefsSignatures)) + uids + , _tkuUAts = + map + (_uatWithWireRefsValue &&& + (map _signatureWithWireRefValue . _uatWithWireRefsSignatures)) + uats + , _tkuSubs = + map + (_subkeyWithWireRefsValue &&& + (map _signatureWithWireRefValue . _subkeyWithWireRefsSignatures)) + subs + } + +canonicalizeTKWithWireRep :: + TKWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown +canonicalizeTKWithWireRep tk = do + structured <- + case toStructuredTKWithWireRep tk of + Left err -> Left (CanonicalizeStructuringError err) + Right s -> Right s + canonicalizeTKStructuredWithWireRep structured + +toStructuredTKWithWireRep :: TKWithWireRep -> Either String TKStructuredWithWireRep +toStructuredTKWithWireRep tkWithRefs = do + let tk = _tkValue tkWithRefs + refs = _tkPackets tkWithRefs + (pkp, mska) = _tkuKey tk + primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska) + zipper <- case zFromList refs of + Just z -> Right z + Nothing -> Left "no packet references available for TKUnknown structuring" + (primaryRef, z1') <- consumePktZ "primary key packet" primaryPkt zipper + -- Move past the primary key to process its signatures and following packets + z1 <- case zMoveNext z1' of + Just z -> Right z + Nothing -> + -- Primary key is the only packet; only valid if no revisions, UIDs, UATs, or subkeys + if null (_tkuRevs tk) && null (_tkuUIDs tk) && null (_tkuUAts tk) && null (_tkuSubs tk) + then Right z1' + else Left "missing signatures/UIDs/subkeys after primary key packet" + (directSigs, z2) <- consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1 + (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2 + (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3 + (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4 + -- Check if there are trailing packets AFTER the current focus (not including it) + case _zpAfter z5 of + [] -> + Right + (TKStructuredWithWireRep + (_tkWireRepRefs tkWithRefs) + (_tkWireRepRange tkWithRefs) + (_tkuKey tk) + (packetRefIdOf primaryRef) + directSigs + uids + uats + subs + (_tkPackets tkWithRefs)) + (unexpected:_) -> + Left + ("unexpected trailing packet reference at position " ++ + show (zPosition z5 + 1) ++ " while structuring TKUnknown provenance (tag " ++ + show (pktTag (_pktValue unexpected)) ++ ")") + where + consumePktZ :: String -> Pkt -> PacketZipper -> Either String (PktWithWireRep, PacketZipper) + consumePktZ context expected z + | _pktValue (_zpCurrent z) == expected = Right (_zpCurrent z, z) + | otherwise = + Left + ("packet/reference mismatch for " ++ context ++ + " at position " ++ show (zPosition z) ++ + ": expected tag " ++ show (pktTag expected) ++ + ", got tag " ++ show (pktTag (_pktValue (_zpCurrent z)))) + + consumeSigsZ :: + String + -> [SignaturePayload] + -> PacketZipper + -> Either String ([SignatureWithWireRef], PacketZipper) + consumeSigsZ context sigs z = go [] sigs z + where + go acc [] zipper = Right (reverse acc, zipper) + go acc (sig:sigRest) zipper = do + (sigPkt, z') <- consumePktZ context (SignaturePkt sig) zipper + z'' <- case zMoveNext z' of + Just z -> Right z + Nothing -> if null sigRest then Right z' else Left ("missing signature packet at position " ++ show (zPosition z')) + go + (SignatureWithWireRef sig (packetRefIdOf sigPkt) : acc) + sigRest + z'' + + consumeUIDsZ :: + [(Text, [SignaturePayload])] + -> PacketZipper + -> Either String ([UIDWithWireRefs], PacketZipper) + consumeUIDsZ [] z = Right ([], z) + consumeUIDsZ ((uid, sigs):rest) z = do + (uidPkt, z1) <- consumePktZ "UID packet" (UserIdPkt uid) z + z2 <- case zMoveNext z1 of + Just z -> Right z + Nothing -> if null rest && null sigs then Right z1 else Left ("missing UID at position " ++ show (zPosition z1)) + (uidSigs, z3) <- consumeSigsZ "UID signature" sigs z2 + (tailUIDs, z4) <- consumeUIDsZ rest z3 + Right + (UIDWithWireRefs uid (packetRefIdOf uidPkt) uidSigs : tailUIDs, z4) + + consumeUATsZ :: + [([UserAttrSubPacket], [SignaturePayload])] + -> PacketZipper + -> Either String ([UATWithWireRefs], PacketZipper) + consumeUATsZ [] z = Right ([], z) + consumeUATsZ ((uat, sigs):rest) z = do + (uatPkt, z1) <- consumePktZ "UAT packet" (UserAttributePkt uat) z + z2 <- case zMoveNext z1 of + Just z -> Right z + Nothing -> if null rest && null sigs then Right z1 else Left ("missing UAT at position " ++ show (zPosition z1)) + (uatSigs, z3) <- consumeSigsZ "UAT signature" sigs z2 + (tailUats, z4) <- consumeUATsZ rest z3 + Right + (UATWithWireRefs uat (packetRefIdOf uatPkt) uatSigs : tailUats, z4) + + consumeSubsZ :: + [(Pkt, [SignaturePayload])] + -> PacketZipper + -> Either String ([SubkeyWithWireRefs], PacketZipper) + consumeSubsZ [] z = Right ([], z) + consumeSubsZ ((subPkt, sigs):rest) z = do + (subRef, z1) <- consumePktZ "subkey packet" subPkt z + z2 <- case zMoveNext z1 of + Just z -> Right z + Nothing -> if null rest && null sigs then Right z1 else Left ("missing subkey at position " ++ show (zPosition z1)) + (subSigs, z3) <- consumeSigsZ "subkey signature" sigs z2 + (tailSubs, z4) <- consumeSubsZ rest z3 + Right + (SubkeyWithWireRefs subPkt (packetRefIdOf subRef) subSigs : tailSubs, z4) + +tksFromWireRep :: WireRepRef -> [TKWithWireRep] -> [TKWithWireRep] +tksFromWireRep src = filter (elem src . NE.toList . wireRepsOfTK) + +tksContainingPacket :: PktWithWireRep -> [TKWithWireRep] -> [TKWithWireRep] +tksContainingPacket pkt = filter (elem pkt . packetRefsOfTK) + +$(ATH.deriveToJSON ATH.defaultOptions ''TKUnknown) + +type KeyringIxs = '[ EightOctetKeyId, Fingerprint, Text] + +-- | Kinded keyrings: homogeneous collections of public or secret TKs +type PublicKeyring = IxSet KeyringIxs (TK 'PublicTK) +type SecretKeyring = IxSet KeyringIxs (TK 'SecretTK) + +-- | Parameterized kinded keyring for generic operations +type family KeyringOf (k :: TKKind) :: Type where + KeyringOf 'PublicTK = PublicKeyring + KeyringOf 'SecretTK = SecretKeyring + +$(makeLenses ''TKUnknown) $(makeLenses ''TK) +$(makeLenses ''TKWithWireRep) +$(makeLenses ''PacketRefId) +$(makeLenses ''PacketZipper) +$(makeLenses ''SignatureWithWireRef) +$(makeLenses ''UIDWithWireRefs) +$(makeLenses ''UATWithWireRefs) +$(makeLenses ''SubkeyWithWireRefs) +$(makeLenses ''TKStructuredWithWireRep) + diff --git a/Data/Conduit/OpenPGP/Compression.hs b/Data/Conduit/OpenPGP/Compression.hs --- a/Data/Conduit/OpenPGP/Compression.hs +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -1,7 +1,8 @@ --- Compression.hs: OpenPGP (RFC4880) compression conduits --- Copyright © 2012-2018 Clint Adams +-- Compression.hs: OpenPGP (RFC9580) compression conduits +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + module Data.Conduit.OpenPGP.Compression ( conduitCompress , conduitDecompress @@ -9,12 +10,18 @@ import Codec.Encryption.OpenPGP.Compression import Codec.Encryption.OpenPGP.Types -import Control.Monad.Trans.Resource (MonadThrow) +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 () 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. conduitDecompress :: MonadThrow m => ConduitT Pkt Pkt m () -conduitDecompress = CL.concatMap decompressPkt +conduitDecompress = awaitForever $ \pkt -> + case decompressPkt pkt of + Left err -> throwM (userError (renderCompressionError err)) + Right pkts -> mapM_ yield pkts 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 @@ -1,152 +1,2484 @@ --- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption --- Copyright © 2013-2020 Clint Adams --- This software is released under the terms of the Expat license. --- (See the LICENSE file). -{-# LANGUAGE FlexibleContexts #-} - -module Data.Conduit.OpenPGP.Decrypt - ( conduitDecrypt - ) where - -import Control.Monad (when) -import Control.Monad.Fail (MonadFail) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans.Resource (MonadResource, MonadThrow) -import qualified Crypto.Hash as CH -import qualified Crypto.Hash.Algorithms as CHA -import Data.Binary (get) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16.Lazy as B16L -import qualified Data.ByteString.Lazy as BL -import Data.Conduit -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.Combinators as CC -import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Compression (conduitDecompress) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.Maybe (fromJust, isNothing) - -import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce) -import Codec.Encryption.OpenPGP.S2K (skesk2Key) -import Codec.Encryption.OpenPGP.Types - -data RecursorState = - RecursorState - { _depth :: Int - , _lastPKESK :: Maybe PKESK - , _lastSKESK :: Maybe SKESK - , _lastNonce :: Maybe B.ByteString - , _lastClearText :: Maybe B.ByteString - } - deriving (Eq, Show) - -def :: RecursorState -def = RecursorState 0 Nothing Nothing Nothing Nothing - -type InputCallback m = String -> m BL.ByteString - -conduitDecrypt :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => InputCallback IO - -> ConduitT Pkt Pkt m () -conduitDecrypt = conduitDecrypt' def - -conduitDecrypt' :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => RecursorState - -> InputCallback IO - -> ConduitT Pkt Pkt m () -conduitDecrypt' rs cb = CC.concatMapAccumM push rs - where - push :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => Pkt - -> RecursorState - -> m (RecursorState, [Pkt]) - push i s - | _depth s > 42 = fail "I think we've been quine-attacked" - | otherwise = - case i of - SKESKPkt {} -> return (s {_lastSKESK = Just (fromPkt i)}, []) - (SymEncDataPkt bs) -> do - d <- decryptSEDP s cb (fromJust . _lastSKESK $ s) bs - return (s, d) - (SymEncIntegrityProtectedDataPkt _ bs) -> do - d <- decryptSEIPDP s cb (fromJust . _lastSKESK $ s) bs - return (s, d) - m@(ModificationDetectionCodePkt mdc) -> do - when (isNothing (_lastClearText s)) $ fail "MDC with no referent" - let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s - when (mcalculated /= Just mdc) $ - fail $ - "MDC indicates tampering: " ++ - show (B16L.encode mdc) ++ - " versus " ++ - maybe "" (show . B16L.encode) mcalculated ++ - " ... " ++ - show (_lastNonce s) ++ " / " ++ show (_lastClearText s) - return (s, [m]) - p -> return (s, [p]) - -decryptSEDP :: - (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) - => RecursorState - -> InputCallback IO - -> SKESK - -> BL.ByteString - -> m [Pkt] -decryptSEDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK - = do - passphrase <- liftIO $ cb "Input the passphrase I want" - let key = skesk2Key skesk passphrase - decrypted = - case decryptOpenPGPCfb - (_skeskSymmetricAlgorithm skesk) - (BL.toStrict bs) - key of - Left e -> error e - Right x -> x - runConduitRes $ - CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .| - conduitDecompress .| - conduitDecrypt' rs {_depth = _depth rs + 1} cb .| - CL.consume - -decryptSEIPDP :: - (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) - => RecursorState - -> InputCallback IO - -> SKESK - -> BL.ByteString - -> m [Pkt] -decryptSEIPDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK - = do - passphrase <- liftIO $ cb "Input the passphrase I want" - let key = skesk2Key skesk passphrase - (nonce, decrypted) = - case decryptPreservingNonce - (_skeskSymmetricAlgorithm skesk) - (BL.toStrict bs) - key of - Left e -> error e - Right x -> x - runConduitRes $ - CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .| - conduitDecompress .| - conduitDecrypt' - rs - { _depth = _depth rs + 1 - , _lastNonce = Just nonce - , _lastClearText = Just decrypted - } - cb .| - CL.consume - -calculateMDC :: B.ByteString -> B.ByteString -> BL.ByteString -calculateMDC nonce garbage - | B.length garbage < 23 = mempty -- FIXME: this is horrible - | otherwise = - BL.fromStrict . BA.convert . (CH.hash :: B.ByteString -> CH.Digest CHA.SHA1) $ - nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20] +-- Decrypt.hs: OpenPGP (RFC9580) recursive packet decryption +-- Copyright © 2013-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Conduit.OpenPGP.Decrypt + ( conduitDecrypt + , conduitDecryptWithReport + , DecryptOptions(..) + , DecryptKeyResolution(..) + , PKESKRecipientKey(..) + , PKESKAttemptFailureKind(..) + , PKESKAttemptFailure(..) + , DecryptOutcome(..) + , DecryptReport(..) + , DecryptSessionKeyResolutionReport(..) + , DecryptSessionKeyResolutionPath(..) + , PKESKResolverAttempt(..) + , PKESKResolverAttemptAction(..) + , decryptSEIPDv2Payload + ) where + +import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize) +import Control.Exception (SomeException, displayException, try) +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow) +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import qualified Crypto.PubKey.RSA.Types as RSATypes +import Data.Binary (get) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bits (countLeadingZeros, shiftL, shiftR, xor) +import Data.Bifunctor (first) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.List (intercalate, nub) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (catMaybes, isNothing, mapMaybe) +import Data.Word (Word16, Word8, Word64) + +import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce, validateSEIPD1MDC, calculateMDC) +import Codec.Encryption.OpenPGP.Internal (leftPadTo) +import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) +import Codec.Encryption.OpenPGP.Internal.CryptoECDH + ( normalizeMontgomeryPublic + , buildECDHKDFParam + , deriveECDHKek + ) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , decryptSKESK6SessionKey + , deriveSKESK6KEK + , seipdv2SymmetricKeySize + ) +import Codec.Encryption.OpenPGP.Policy + ( DecryptPolicy(..) + , defaultDecryptPolicy + , validateTable30PolicyForRecipient + ) +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (decryptWithOCBRFC7253With) +import Codec.Encryption.OpenPGP.S2K + ( decodeOpenPGPEncodedSessionKey + , renderEncodedSessionKeyError + , renderS2KError + , S2KError(..) + , skesk2Key + , skesk2SessionKey + , string2Key + ) +import Codec.Encryption.OpenPGP.Types +import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey) +import Control.Lens ((.~), ix) +import Data.Conduit.OpenPGP.Keyring.Instances () +import qualified Data.IxSet.Typed as IxSet + +data RecursorState = + RecursorState + { _depth :: Int + , _pendingESKs :: [PendingESK] + , _lastNonce :: Maybe B.ByteString + , _lastClearText :: Maybe B.ByteString + , _decryptPolicy :: DecryptPolicy + } + deriving (Eq, Show) + +def :: RecursorState +def = RecursorState 0 [] Nothing Nothing defaultDecryptPolicy + +data DecryptStreamPhase + = ActiveDecryptPhase + | FinishedDecryptPhase + | MalformedDecryptPhase + +data DecryptStreamState (phase :: DecryptStreamPhase) where + ActiveDecryptState :: + RecursorState + -> DecryptStreamState 'ActiveDecryptPhase + FinishedDecryptState :: + RecursorState + -> Bool + -> DecryptStreamState 'FinishedDecryptPhase + MalformedDecryptState :: + RecursorState + -> String + -> DecryptStreamState 'MalformedDecryptPhase + +data SomeDecryptStreamState where + SomeDecryptStreamState :: + DecryptStreamState phase + -> SomeDecryptStreamState + +data PendingESK + = PendingPKESK PKESKPayload + | PendingSKESK SKESKPayload + deriving (Eq, Show) + +data EncryptedPayloadVersion + = LegacyEncryptedPayloadVersion + | SEIPDv2EncryptedPayloadVersion + +data EncryptedPayloadFlavor (v :: EncryptedPayloadVersion) where + LegacyEncryptedPayload :: EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion + SEIPDv2EncryptedPayload :: + SymmetricAlgorithm + -> AEADAlgorithm + -> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion + +type InputCallback m = String -> m BL.ByteString + +data PKESKRecipientKey = + PKESKRecipientKey + { pkeskRecipientPKPayload :: Maybe SomePKPayload + -- ^ Public key payload for the recipient. Required for X25519, X448, + -- and ECDH unwrap paths; may be 'Nothing' for RSA. + , pkeskRecipientSKey :: SKey + -- ^ 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 PKESKResolveRequest = + PKESKResolveRequest + { reqPKESK :: PKESKPayload + , reqProbePacket :: Pkt + , reqIsWildcardRecipient :: Bool + , reqAttemptIndex :: Int + , reqPreviousFailures :: [PKESKAttemptFailure] + } + deriving (Eq, Show) + +data PKESKResolveAction + = ResolveWith PKESKRecipientKey + | ResolveSkip + | ResolveExhausted + | ResolveFail PKESKResolverError + +type PKESKResolver m = PKESKResolveRequest -> m PKESKResolveAction + +-- | Build a stateful 'PKESKResolver' that iterates over a pre-populated +-- candidate list. The returned resolver yields candidates in order and +-- returns 'ResolveExhausted' once the list is depleted. +-- | How to resolve secret keys for PKESK-encrypted messages. +data DecryptKeyResolution + = DecryptWithoutPKESK + -- ^ Do not attempt PKESK decryption; fall through to manual session-key + -- input via the passphrase callback instead. + | DecryptWithKeyring SecretKeyring + -- ^ Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret + -- keys (not passphrase-protected) are used. For passphrase-protected keys, + -- use 'DecryptWithKeyringAndPassphrase'. + | DecryptWithKeyringAndPassphrase SecretKeyring (SomePKPayload -> IO (Maybe BL.ByteString)) + -- ^ Resolve secret keys from a 'SecretKeyring', unlocking passphrase- + -- protected keys using the provided callback. The callback receives the + -- public key payload and returns the passphrase, or 'Nothing' to skip. + | DecryptWithUnwrapCandidatesCallback (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + -- ^ Preferred callback form for non-keyring key material. The callback + -- receives a typed key identifier (8-octet key ID, fingerprint, or + -- wildcard) plus the packet public-key algorithm, then returns all + -- matching candidates in priority order. hOpenPGP iterates candidates + -- deterministically without re-calling the callback for each retry. + +-- | Canonical decrypt configuration. +-- +-- Most callers should prefer 'conduitDecrypt' and set: +-- +-- * 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase' +-- * 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient +-- * 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup +data DecryptOptions = + DecryptOptions + { decryptOptionsKeyResolution :: DecryptKeyResolution + , decryptOptionsPolicy :: DecryptPolicy + , decryptOptionsPassphraseCallback :: InputCallback IO + } + +-- | Outcome of a checked decrypt conduit run. +-- +-- Use 'conduitDecrypt' to obtain this value. Because +-- 'Data.Conduit..|' preserves the +-- /rightmost/ conduit's return value, callers who also need the decrypted +-- packet stream should use 'Data.Conduit.fuseBoth': +-- +-- @ +-- (outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume +-- @ +data DecryptOutcome + = DecryptClean + -- ^ 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. + | DecryptTruncated + -- ^ The input stream ended before any integrity-terminating marker was + -- seen. The ciphertext was incomplete. + | DecryptTrailingData + -- ^ 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. + | DecryptMalformedStructure String + -- ^ A structural packet-sequencing violation was detected. The + -- 'String' describes the specific violation: + -- + -- * PKESK version does not match the SEIPD version (e.g. a v6 PKESK + -- preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2 + -- payload). + -- + -- * ESK packets arrived in the wrong order relative to the encrypted + -- data packet (e.g. a literal-data packet appeared between a PKESK + -- and the SEIPD it was intended to protect). + -- + -- * A packet arrived after the message integrity boundary (trailing + -- data). Under 'defaultDecryptPolicy' this is reported here; under + -- 'lenientDecryptPolicy' it is reported as 'DecryptTrailingData' + -- instead. + 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 :: [String] + , decryptSessionResolutionPKESKErrors :: [String] + , 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 + { aeadMode :: CCT.AEADMode + , aeadInfo :: B.ByteString + , aeadChunkSize :: Word8 + , aeadNoncePrefix :: B.ByteString + , aeadCipher :: cipher + } + +-- | ReaderT wrapper for AEAD decryption computations +type AEADDecrypt cipher = ReaderT (AEADDecryptContext cipher) (Either String) + +conduitDecrypt :: + (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) + => DecryptOptions + -> ConduitT Pkt Pkt m DecryptOutcome +conduitDecrypt opts = + decryptReportOutcome <$> conduitDecryptWithReport opts + +conduitDecryptWithReport :: + (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) + => DecryptOptions + -> ConduitT Pkt Pkt m DecryptReport +conduitDecryptWithReport opts = do + reportRef <- liftIO (newIORef []) + resolver <- liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts)) + let allowManualPKESKPrompt = + case decryptOptionsKeyResolution opts of + DecryptWithoutPKESK -> True + _ -> False + outcome <- + conduitDecryptChecked' + (def {_decryptPolicy = decryptOptionsPolicy opts}) + allowManualPKESKPrompt + resolver + (decryptOptionsPassphraseCallback opts) + (Just reportRef) + resolutions <- reverse <$> liftIO (readIORef reportRef) + pure + DecryptReport + { decryptReportOutcome = outcome + , decryptReportSessionKeyResolutions = resolutions + } + +-- | Build an internal 'PKESKResolver' from the public 'DecryptKeyResolution'. +buildDecryptResolver :: DecryptKeyResolution -> IO (PKESKResolver IO) +buildDecryptResolver DecryptWithoutPKESK = + pure (\_ -> pure ResolveExhausted) +buildDecryptResolver (DecryptWithKeyring kr) = + buildKeyringResolver kr Nothing +buildDecryptResolver (DecryptWithKeyringAndPassphrase kr cb) = + buildKeyringResolver kr (Just cb) +buildDecryptResolver (DecryptWithUnwrapCandidatesCallback cb) = + buildUnwrapCandidatesResolver cb + +-- | Build a stateful resolver that looks up keys from a 'SecretKeyring'. +buildKeyringResolver :: + SecretKeyring + -> Maybe (SomePKPayload -> IO (Maybe BL.ByteString)) + -> IO (PKESKResolver IO) +buildKeyringResolver kr maybePassphraseCb = do + -- Tracks (last PKESK, remaining wildcard candidates once initialized). + stateRef <- newIORef (Nothing :: Maybe PKESKPayload, Nothing :: Maybe [PKESKRecipientKey]) + pure $ \req -> do + let pkesk = reqPKESK req + probe = reqProbePacket req + (lastPKESK, wildcardState) <- readIORef stateRef + let freshPKESK = Just pkesk /= lastPKESK + when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing) + let wc = if freshPKESK then Nothing else wildcardState + case extractProbeKeyIdentifier probe of + KeyIdentifierWildcard -> do + -- Wildcard probe: iterate all keys + candidates <- case wc of + Nothing -> keyringCandidates (IxSet.toList kr) + Just cs -> pure cs + case candidates of + [] -> do + writeIORef stateRef (Just pkesk, Just []) + pure ResolveExhausted + (rk:rest) -> do + writeIORef stateRef (Just pkesk, Just rest) + pure (ResolveWith rk) + keyIdentifier -> do + -- Exact probe: direct lookup by key ID or fingerprint + let matchingTKs = matchingTKsForRecipient keyIdentifier + priorFailures = length (reqPreviousFailures req) + candidates <- keyringCandidates matchingTKs + case drop priorFailures candidates of + [] -> pure ResolveSkip + (rk:_) -> pure (ResolveWith rk) + where + matchingTKsForRecipient :: KeyIdentifier -> [TK 'SecretTK] + matchingTKsForRecipient keyIdentifier = + case keyIdentifier of + KeyIdentifierWildcard -> IxSet.toList kr + KeyIdentifierEightOctet rid -> IxSet.toList (kr IxSet.@= rid) + KeyIdentifierFingerprint rid -> + let indexedMatches = IxSet.toList (kr IxSet.@= rid) + in if null indexedMatches + then filter (tkMatchesRecipientFingerprint rid) (IxSet.toList kr) + else indexedMatches + + tkMatchesRecipientFingerprint :: Fingerprint -> TK 'SecretTK -> Bool + tkMatchesRecipientFingerprint rid tk = + any + (keyPktMatchesRecipientFingerprint rid) + (_tkPrimaryKey tk : map fst (_tkSubs tk)) + + keyPktMatchesRecipientFingerprint :: + Fingerprint -> KeyPkt 'SecretPkt -> Bool + keyPktMatchesRecipientFingerprint rid (KeyPktSecretPrimary pkp _) = + pkPayloadMatchesRecipientFingerprint rid pkp + keyPktMatchesRecipientFingerprint rid (KeyPktSecretSubkey pkp _) = + pkPayloadMatchesRecipientFingerprint rid pkp + + pkPayloadMatchesRecipientFingerprint :: Fingerprint -> SomePKPayload -> Bool + pkPayloadMatchesRecipientFingerprint rid pkp = + fingerprint pkp `elem` recipientFingerprintMatchVariants rid + + recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint] + recipientFingerprintMatchVariants (Fingerprint rid) + | BL.length rid == 20 = [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)] + | BL.length rid == 21 && BL.head rid == 0x04 = [Fingerprint rid, Fingerprint (BL.tail rid)] + | BL.length rid == 32 = [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)] + | BL.length rid == 33 && BL.head rid == 0x06 = [Fingerprint rid, Fingerprint (BL.tail rid)] + | otherwise = [Fingerprint rid] + + keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey] + keyringCandidates tks = concat <$> mapM tkCandidates tks + + tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey] + tkCandidates tk = + fmap catMaybes . mapM resolveKeyPair $ + _tkPrimaryKey tk : map fst (_tkSubs tk) + + resolveKeyPair :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey) + resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) = + pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} + resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) = + pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} + resolveKeyPair (KeyPktSecretPrimary pkp ska) = unlockProtected pkp ska + resolveKeyPair (KeyPktSecretSubkey pkp ska) = unlockProtected pkp ska + + unlockProtected :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey) + unlockProtected pkp ska = + case maybePassphraseCb of + Nothing -> pure Nothing + Just passphraseCb -> do + mPassphrase <- passphraseCb pkp + case mPassphrase of + Nothing -> pure Nothing + Just passphrase -> + case decryptPrivateKey (pkp, ska) passphrase of + Left _ -> pure Nothing + Right (SUUnencrypted sk _) -> + pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} + Right _ -> pure Nothing + +buildUnwrapCandidatesResolver :: + (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + -> IO (PKESKResolver IO) +buildUnwrapCandidatesResolver cb = do + stateRef <- newIORef (Nothing :: Maybe PKESKPayload, [] :: [(Pkt, [PKESKRecipientKey])], [] :: [SKey]) + pure $ \req -> do + let pkesk = reqPKESK req + probePkt = reqProbePacket req + (lastPKESK, probeState, seenSKeys) <- readIORef stateRef + let freshPKESK = Just pkesk /= lastPKESK + when freshPKESK $ writeIORef stateRef (Just pkesk, [], []) + let state0 = if freshPKESK then [] else probeState + seen0 = if freshPKESK then [] else seenSKeys + case lookup probePkt state0 of + Just (next:rest) -> do + writeIORef + stateRef + ( Just pkesk + , updateProbeState probePkt rest state0 + , pkeskRecipientSKey next : seen0 + ) + pure (ResolveWith next) + Just [] -> + pure ResolveSkip + Nothing -> do + candidates <- filterFreshCandidates seen0 <$> callbackCandidates probePkt + case candidates of + [] -> do + writeIORef stateRef (Just pkesk, updateProbeState probePkt [] state0, seen0) + pure ResolveSkip + (next:rest) -> do + writeIORef + stateRef + ( Just pkesk + , updateProbeState probePkt rest state0 + , pkeskRecipientSKey next : seen0 + ) + pure (ResolveWith next) + where + callbackCandidates probePkt = + cb (extractProbeKeyIdentifier probePkt) (extractProbePKA probePkt) + + updateProbeState probePkt remaining state0 = + (probePkt, remaining) : filter ((/= probePkt) . fst) state0 + + filterFreshCandidates seenSKeys = + filter (\candidate -> pkeskRecipientSKey candidate `notElem` seenSKeys) + +-- | Extract the recipient identifier from a PKESK probe packet. +extractProbeKeyIdentifier :: Pkt -> KeyIdentifier +extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _))) + | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard + | otherwise = KeyIdentifierEightOctet rid +extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _))) + | BL.null rid = KeyIdentifierWildcard + | otherwise = KeyIdentifierFingerprint (Fingerprint rid) +extractProbeKeyIdentifier _ = KeyIdentifierWildcard + +isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool +isWildcardV3RecipientKeyId (EightOctetKeyId rid) = + BL.length rid == 8 && BL.all (== 0) rid + +-- | Extract the public-key algorithm from a PKESK probe packet. +extractProbePKA :: Pkt -> PubKeyAlgorithm +extractProbePKA (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) = pka +extractProbePKA (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ pka _))) = pka +extractProbePKA _ = RSA -- fallback; should not be reached + +-- | Core implementation: manual await loop so we can return a 'DecryptOutcome'. +conduitDecryptChecked' :: + (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> ConduitT Pkt Pkt m DecryptOutcome +conduitDecryptChecked' rs0 allowManualPKESKPrompt pkcb cb reportRef = + loop (SomeDecryptStreamState (ActiveDecryptState rs0)) + where + loop :: + (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) + => SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome + loop streamState = do + case streamState of + SomeDecryptStreamState (MalformedDecryptState _ reason) -> + return (DecryptMalformedStructure reason) + SomeDecryptStreamState state -> do + mpkt <- await + case mpkt of + Nothing -> return (finalOutcome state) + Just pkt -> do + (state', pkts) <- lift (push pkt state) + mapM_ yield pkts + loop state' + + push :: + (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) + => Pkt + -> DecryptStreamState phase + -> m (SomeDecryptStreamState, [Pkt]) + push i (ActiveDecryptState s) + | _depth s > 42 = fail "I think we've been quine-attacked" + | hasPendingESKPrelude s && not (packetCanFollowESKPrelude i) = + return + ( SomeDecryptStreamState + (MalformedDecryptState + s + "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data") + , [] ) + | otherwise = + let dp = _decryptPolicy s + in case i of + SKESKPkt payload -> + do + when (decryptRejectDeprecatedSKESK dp) $ + case skeskPayloadS2K payload of + Simple _ -> + fail "SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy" + Salted _ _ -> + fail "SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy" + _ -> pure () + return + ( SomeDecryptStreamState + (ActiveDecryptState + (s {_pendingESKs = _pendingESKs s ++ [PendingSKESK payload]})) + , [] ) + PKESKPkt p -> + return + ( SomeDecryptStreamState + (ActiveDecryptState + (s {_pendingESKs = _pendingESKs s ++ [PendingPKESK p]})) + , [] ) + (SymEncDataPkt bs) -> + if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s + then + return + ( SomeDecryptStreamState + (MalformedDecryptState + s + ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ + "legacy SED payload")) + , [] ) + else do + when (not (decryptAllowSEDNoIntegrity dp)) $ + fail + "Received unauthenticated SED (Symmetrically Encrypted Data) packet; \ + \RFC9580 policy requires integrity-protected SEIPD. \ + \Use lenientDecryptPolicy to permit legacy messages." + (symalgo, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + LegacyEncryptedPayload + reportRef + checkDecryptSymmetricAlgo dp symalgo + d <- + decryptSEDP + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + symalgo + sessionKey + bs + -- SED is the terminal outer-stream packet. + return (finalizeOuterEncryptedPayload s d) + (SymEncIntegrityProtectedDataPkt (SEIPD1 _ bs)) -> + if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s + then + return + ( SomeDecryptStreamState + (MalformedDecryptState + s + ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ + "SEIPDv1 payload")) + , [] ) + else do + when (not (decryptAllowSEIPDv1 dp)) $ + fail + "Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only." + (symalgo, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + LegacyEncryptedPayload + reportRef + checkDecryptSymmetricAlgo dp symalgo + d <- + decryptSEIPDP + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + symalgo + sessionKey + bs + -- The outer SEIPD1 packet is terminal; inner MDC is handled by + -- the recursive conduit's own _seenMessageEnd tracking. + return (finalizeOuterEncryptedPayload s d) + (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) -> + if hasESKPayloadVersionMismatch dp (SEIPDv2EncryptedPayload sa aa) s + then + return + ( SomeDecryptStreamState + (MalformedDecryptState + s + ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ + "SEIPDv2 payload")) + , [] ) + else do + checkDecryptSymmetricAlgo dp sa + checkDecryptAEADAlgo dp aa + (_, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + (SEIPDv2EncryptedPayload sa aa) + reportRef + d <- + decryptSEIPDv2P + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + sa + aa + chunkSize + salt + sessionKey + bs + -- SEIPD2 final AEAD tag was verified inside decryptSEIPDv2P. + return (finalizeOuterEncryptedPayload s d) + m@(ModificationDetectionCodePkt mdc) -> do + when (isNothing (_lastClearText s)) $ fail "MDC with no referent" + let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s + expectedMdc <- + case mcalculated of + Nothing -> fail "MDC with no nonce or cleartext" + Just Nothing -> fail "MDC referent is too short" + Just (Just x) -> return x + when (expectedMdc /= mdc) $ + fail $ + "MDC indicates tampering: " ++ + show mdc ++ + " versus " ++ + maybe "" show mcalculated ++ + " ... " ++ + show (_lastNonce s) ++ " / " ++ show (_lastClearText s) + -- MDC is the integrity boundary inside a SEIPD1 inner stream. + return + ( SomeDecryptStreamState (FinishedDecryptState s False) + , [m] ) + -- RFC9580 Padding Packet (tag 21) can be ignored after decryption. + (OtherPacketPkt 21 _) -> + return (SomeDecryptStreamState (ActiveDecryptState s), []) + (OtherPacketPkt t _) | t < 40 -> + fail ("Unknown critical packet type in packet sequence: " ++ show t) + (OtherPacketPkt _ _) -> + return (SomeDecryptStreamState (ActiveDecryptState s), []) + p -> + return (SomeDecryptStreamState (ActiveDecryptState s), [p]) + push i (FinishedDecryptState s hadTrailing) = + if decryptRejectTrailingData (_decryptPolicy s) + then + return + ( SomeDecryptStreamState + (MalformedDecryptState + s + "packet received after message integrity boundary") + , [] ) + else + return + (SomeDecryptStreamState (FinishedDecryptState s True), [i]) + push _ malformedState@(MalformedDecryptState _ _) = + return (SomeDecryptStreamState malformedState, []) + + hasPendingESKPrelude s = not (null (_pendingESKs s)) + + hasESKPayloadVersionMismatch dp payloadFlavor state = + decryptRejectESKVersionMismatch dp + && hasPendingESKPrelude state + && null (alignedPrecedingESKs payloadFlavor (_pendingESKs state)) + + finalizeOuterEncryptedPayload state decryptedPkts = + ( SomeDecryptStreamState + (FinishedDecryptState (state { _pendingESKs = [] }) False) + , decryptedPkts ) + + finalOutcome :: DecryptStreamState phase -> DecryptOutcome + finalOutcome (ActiveDecryptState _) = DecryptTruncated + finalOutcome (FinishedDecryptState _ hadTrailing) = + if hadTrailing + then DecryptTrailingData + else DecryptClean + finalOutcome (MalformedDecryptState _ reason) = + DecryptMalformedStructure reason + + packetCanFollowESKPrelude pkt = + case pkt of + SKESKPkt _ -> True + PKESKPkt _ -> True + SymEncDataPkt _ -> True + SymEncIntegrityProtectedDataPkt _ -> True + MarkerPkt _ -> True + OtherPacketPkt 21 _ -> True + _ -> False + +-- | Describes what integrity-terminating marker (if any) an inner packet +-- stream is expected to contain. Passed to 'checkInnerOutcome' to +-- distinguish a legitimate end-of-stream from a missing marker. +data InnerIntegrityExpectation + = NoIntegrityMarker + -- ^ The inner stream has no integrity-terminating packet. SED has none + -- by design; SEIPD2 authenticates via AEAD before the conduit runs. + -- 'DecryptTruncated' is the normal end-of-stream outcome. + +-- | Propagate non-clean inner-stream outcomes as a 'fail'. Called after each +-- recursive decrypt helper so that structural violations and (for SEIPD1) a +-- missing MDC are not silently swallowed. +checkInnerOutcome :: MonadFail m => InnerIntegrityExpectation -> DecryptOutcome -> m () +checkInnerOutcome _ DecryptClean = pure () +checkInnerOutcome _ DecryptTrailingData = pure () +checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure () +checkInnerOutcome _ (DecryptMalformedStructure reason) = + fail ("Inner encrypted payload had malformed structure: " ++ reason) + +decryptSEDP :: + (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do + decrypted <- + case decryptOpenPGPCfb symalgo (BL.toStrict bs) sessionKey of + Left e -> fail (renderCipherError e) + Right x -> pure x + (innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decrypted + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptSEIPDP :: + (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEIPDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do + (nonce, decrypted) <- + case decryptPreservingNonce symalgo (BL.toStrict bs) sessionKey of + Left e -> fail (renderCipherError e) + Right x -> pure x + decryptedWithoutMDC <- + case validateSEIPD1MDC nonce decrypted of + Left err -> fail err + Right x -> pure x + (innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decryptedWithoutMDC + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptSEIPDv2P :: + (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEIPDv2P rs allowManualPKESKPrompt pkcb cb reportRef symalgo aeadalgo chunkSize salt sessionKey bs = do + let decrypted = + decryptSEIPDv2Payload + symalgo + aeadalgo + chunkSize + salt + (BL.toStrict bs) + sessionKey + case decrypted of + Left e -> fail e + Right cleartext -> do + (innerOutcome, pkts) <- + decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptInnerPackets :: + (MonadFail m, MonadUnliftIO m, MonadThrow m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> B.ByteString + -> m (DecryptOutcome, [Pkt]) +decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext = + runConduitRes $ + CB.sourceLbs (BL.fromStrict cleartext) .| conduitGet get .| conduitDecompress .| + fuseBoth + (conduitDecryptChecked' + rs {_depth = _depth rs + 1} + allowManualPKESKPrompt + pkcb + cb + reportRef) + CL.consume + +decryptSEIPDv2Payload :: + SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> B.ByteString + -> SessionKey + -> Either String B.ByteString +decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do + when (chunkSize > 16) $ + Left "SEIPD v2 chunk size octet must be between 0 and 16" + (mode, nonceSize) <- aeadModeAndNonceSize aeadalgo + keyLen <- symKeySize symalgo + let outputLen = keyLen + nonceSize - 8 + when (B.length (unSalt salt) /= 32) $ + Left "SEIPD v2 salt must be exactly 32 octets" + when (B.length encrypted < 32) $ + Left "SEIPD v2 ciphertext must include at least one chunk tag and a final tag" + let info = + B.pack + [0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize] + prk = extract @CHA.SHA256 (unSalt salt) sessionKey + okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString + messageKey = B.take keyLen okm + noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) + decryptSEIPDv2WithKey + symalgo + mode + chunkSize + info + noncePrefix + messageKey + encrypted + +decryptSEIPDv2WithKey :: + SymmetricAlgorithm + -> CCT.AEADMode + -> Word8 + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted = + withAESCipher + "SEIPD v2 decrypt currently supports AES-128/192/256 only" + symalgo + sessionKey + (decryptChunks mode info chunkSize noncePrefix encrypted) + +decryptChunks :: + CCT.BlockCipher cipher + => CCT.AEADMode + -> B.ByteString + -> Word8 + -> B.ByteString + -> B.ByteString + -> cipher + -> Either String B.ByteString +decryptChunks mode info chunkSize noncePrefix encrypted cipher = + let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher + in runReaderT decryptChunksWithReader ctx + where + decryptChunksWithReader :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString + decryptChunksWithReader = go 0 encrypted [] 0 + where + chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) + tagLen = 16 + + go idx remaining acc totalPlain + | B.length remaining < 2 * tagLen = + lift $ Left "SEIPD v2 ciphertext is too short for chunk and final authentication tags" + | otherwise = do + let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen + currentChunkLen = + if hasMoreChunks + then chunkLen + else B.length remaining - 2 * tagLen + when (currentChunkLen < 0) $ + lift $ Left "SEIPD v2 malformed chunk lengths" + let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining + (chunkTag, r2) = B.splitAt tagLen r1 + plainChunk <- decryptChunkWithContext idx chunkCiphertext chunkTag + if hasMoreChunks + then go + (idx + 1) + r2 + (plainChunk : acc) + (totalPlain + B.length plainChunk) + else do + when (B.length r2 /= tagLen) $ + lift $ Left "SEIPD v2 missing final authentication tag" + verifyFinalTagWithContext + (idx + 1) + (totalPlain + B.length plainChunk) + r2 + return (B.concat (reverse (plainChunk : acc))) + + decryptChunkWithContext idx chunkCiphertext chunkTag = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + if mode' == CCT.AEAD_OCB + then + lift $ + decryptWithOCBRFC7253With + (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") + cipher' + (noncePrefix' <> encodeWord64be idx) + info + chunkCiphertext + (mkAuthTag chunkTag) + else do + aead <- initAEADWithContext idx + let mPlain = + CCT.aeadSimpleDecrypt + aead + info + chunkCiphertext + (mkAuthTag chunkTag) + case mPlain of + Nothing -> lift $ Left "SEIPD v2 chunk authentication failed" + Just p -> return p + + verifyFinalTagWithContext idx totalPlain finalTag = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + if mode' == CCT.AEAD_OCB + then do + plain <- + lift $ + decryptWithOCBRFC7253With + (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") + cipher' + (noncePrefix' <> encodeWord64be idx) + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + (mkAuthTag finalTag) + if B.null plain + then return () + else lift $ Left "SEIPD v2 final authentication tag verification failed" + else do + aead <- initAEADWithContext idx + let mEmpty = + CCT.aeadSimpleDecrypt + aead + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + (mkAuthTag finalTag) + case mEmpty of + Just p | B.null p -> return () + _ -> lift $ Left "SEIPD v2 final authentication tag verification failed" + + initAEADWithContext idx = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + lift $ first show . CE.eitherCryptoError $ + CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx) + +aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) +aeadModeAndNonceSize = + aeadModeAndNonceSizeForSEIPDv2 + "Unknown AEAD algorithm for SEIPD v2 decrypt" + +symKeySize :: SymmetricAlgorithm -> Either String Int +symKeySize = + seipdv2SymmetricKeySize + "SEIPD v2 decrypt currently supports AES-128/192/256 only" + +encodeWord64be :: Word64 -> B.ByteString +encodeWord64be = BL.toStrict . runPut . putWord64be + +mkAuthTag :: B.ByteString -> CCT.AuthTag +mkAuthTag = CCT.AuthTag . BA.convert + +checkDecryptSymmetricAlgo :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m () +checkDecryptSymmetricAlgo dp sa = + case decryptAllowedSymmetricAlgos dp of + Nothing -> pure () + Just allowed + | sa `elem` allowed -> pure () + | otherwise -> + fail $ + "Decrypt policy rejects symmetric algorithm " ++ + show sa ++ + "; allowed: " ++ + show allowed + +checkDecryptAEADAlgo :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m () +checkDecryptAEADAlgo dp aa = + case decryptAllowedAEADAlgos dp of + Nothing -> pure () + Just allowed + | aa `elem` allowed -> pure () + | otherwise -> + fail $ + "Decrypt policy rejects AEAD algorithm " ++ + show aa ++ + "; allowed: " ++ + show allowed + +skeskPayloadSymmetricAlgorithm :: SKESKPayload -> SymmetricAlgorithm +skeskPayloadSymmetricAlgorithm payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa _ _) -> sa + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa _ _ _ _ _) -> sa + +skeskPayloadS2K :: SKESKPayload -> S2K +skeskPayloadS2K payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 _ s2k _) -> s2k + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ _ s2k _ _ _) -> s2k + +skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm +skeskPayloadAEADAlgorithm payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 _ -> Nothing + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa + +resolveSKESKSessionKey :: BL.ByteString -> SKESKPayload -> Either String B.ByteString +resolveSKESKSessionKey passphrase payload = + first renderSKESKSessionKeyResolutionError $ + resolveSKESKSessionKeyTyped passphrase (classifySKESKPayload payload) + +data SKESKSessionKeyResolutionError + = SKESKSessionKeyS2KError S2KError + | SKESKSessionKeyOtherError String + deriving (Eq, Show) + +renderSKESKSessionKeyResolutionError :: SKESKSessionKeyResolutionError -> String +renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err +renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err + +resolveSKESKSessionKeyTyped :: + BL.ByteString + -> ClassifiedSKESKPayload + -> Either SKESKSessionKeyResolutionError B.ByteString +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) = + first + SKESKSessionKeyS2KError + (skesk2Key (SKESK4Packet sa s2k Nothing) passphrase) +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) = + first + SKESKSessionKeyS2KError + (snd <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase) +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do + keyLen <- first (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm) (keySize sa) + ikm <- first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase) + kek <- first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm) + first + SKESKSessionKeyOtherError + (decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag)) + +data ClassifiedSKESKPayload where + ClassifiedSKESKPayloadV4 :: SKESKPayloadV4 -> ClassifiedSKESKPayload + ClassifiedSKESKPayloadV6 :: SKESKPayloadV6 -> ClassifiedSKESKPayload + +classifySKESKPayload :: SKESKPayload -> ClassifiedSKESKPayload +classifySKESKPayload (SKESKPayloadV4Packet payloadV4) = + ClassifiedSKESKPayloadV4 payloadV4 +classifySKESKPayload (SKESKPayloadV6Packet payloadV6) = + ClassifiedSKESKPayloadV6 payloadV6 + +resolveSessionKey :: + (MonadFail m, MonadIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> EncryptedPayloadFlavor v + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> m (SymmetricAlgorithm, SessionKey) +resolveSessionKey rs allowManualPKESKPrompt pkcb cb payloadFlavor reportRef = + case precedingCandidates of + [] -> + if null (_pendingESKs rs) + then fail "Encrypted data packet has no preceding SKESK or PKESK packet" + else + fail + "Encrypted data packet has no preceding SKESK or PKESK packet aligned with payload version" + candidates -> + case skeskCandidates candidates of + [] -> resolvePKESKCandidates (pkeskCandidates candidates) [] [] [] + skesks -> do + passphrase <- liftIO $ cb "Input the passphrase I want" + resolveSKESKCandidates passphrase skesks (pkeskCandidates candidates) [] + where + precedingCandidates + | strictAlignment = alignedByVersion + | null alignedByVersion = _pendingESKs rs + | otherwise = alignedByVersion + + strictAlignment = decryptRejectESKVersionMismatch (_decryptPolicy rs) + alignedByVersion = pendingESKsFromAligned alignedStrict + alignedStrict = alignedPrecedingESKs payloadFlavor (_pendingESKs rs) + + skeskCandidates esks = reverse [skesk | PendingSKESK skesk <- esks] + + pkeskCandidates esks = reverse [pkesk | PendingPKESK pkesk <- esks] + + resolveSKESKCandidates :: + (MonadFail m, MonadIO m) + => BL.ByteString + -> [SKESKPayload] + -> [PKESKPayload] + -> [String] + -> m (SymmetricAlgorithm, SessionKey) + resolveSKESKCandidates _ [] pkesks skeskErrs = + resolvePKESKCandidates pkesks skeskErrs [] [] + resolveSKESKCandidates passphrase (skesk:rest) pkesks skeskErrs = + case resolveSKESKCandidate passphrase skesk of + Left err -> + resolveSKESKCandidates + passphrase + rest + pkesks + ((skeskErrPrefix skesk ++ err) : skeskErrs) + Right resolved -> do + emitResolutionReport + (mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] []) + pure resolved + + resolveSKESKCandidate :: + BL.ByteString + -> SKESKPayload + -> Either String (SymmetricAlgorithm, SessionKey) + resolveSKESKCandidate passphrase skesk = do + let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk + expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk + case expectedSymAlgo of + Just expected | expected /= skeskSymAlgo -> + Left "SKESK/encrypted-payload symmetric algorithm mismatch" + _ -> + case (payloadExpectedAEADAlgorithm payloadFlavor, skeskPayloadAEADAlgorithm skesk) of + (Just expectedAEAD, Just skeskAEAD) + | expectedAEAD /= skeskAEAD -> + Left "SKESK/encrypted-payload AEAD algorithm mismatch" + _ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes) + + skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] " + + resolvePKESKCandidates :: + (MonadFail m, MonadIO m) + => [PKESKPayload] + -> [String] + -> [String] + -> [PKESKResolverAttempt] + -> m (SymmetricAlgorithm, SessionKey) + resolvePKESKCandidates [] [] [] _ = + fail "Encrypted data packet has no usable preceding SKESK or PKESK packet" + resolvePKESKCandidates [] skeskErrs [] _ = + fail + ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ + "candidate errors: " ++ unwords (reverse skeskErrs)) + resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts = + if allowManualPKESKPrompt + then do + let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + errs = skeskErrs ++ pkeskErrs + encodedSessionKey <- + BL.toStrict <$> + liftIO + (cb + "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)") + case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of + Left manualErr -> + fail + ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ + "candidate errors: " ++ + unwords (reverse errs) ++ + "; manual input failed: " ++ manualErr) + Right (sa, k) -> do + emitResolutionReport + (mkResolutionReport + DecryptResolvedViaManualPKESKInput + skeskErrs + pkeskErrs + resolverAttempts) + pure (sa, SessionKey k) + else + fail + ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ + "candidate errors: " ++ + unwords (reverse (skeskErrs ++ pkeskErrs))) + resolvePKESKCandidates (pkesk:rest) skeskErrs pkeskErrs resolverAttempts = do + let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + errPrefix = "[" ++ describePKESK pkesk ++ "] " + attemptPKESKCandidate [] [] 0 expectedSymAlgo errPrefix resolverAttempts + where + attemptPKESKCandidate attemptedSKeys previousFailures attemptIndex expectedSymAlgo errPrefix resolverAttemptsAcc = do + let callbackProbeSummary = describeCallbackProbeSummary pkesk + resolverResult <- + liftIO (resolvePKESKRecipientKey pkesk previousFailures attemptIndex) + case resolverResult of + Left resolverErr -> + fail (errPrefix ++ resolverErr) + Right (Nothing, _, newAttempts) -> + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + terminalError = + case reverse previousFailures of + (latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure + [] -> + errPrefix ++ + "no matching key context (callback probes: " ++ + callbackProbeSummary ++ + ")" + in + resolvePKESKCandidates + rest + skeskErrs + (terminalError : pkeskErrs) + resolverAttempts' + Right (Just keyInfo, nextAttemptIndex, newAttempts) + | pkeskRecipientSKey keyInfo `elem` attemptedSKeys -> + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + terminalError = + case reverse previousFailures of + (latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure + [] -> + errPrefix ++ + "key context callback repeated without yielding a usable key" + in + resolvePKESKCandidates + rest + skeskErrs + (terminalError : pkeskErrs) + resolverAttempts' + | otherwise -> do + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + unwrapped <- liftIO (tryUnwrapPKESKSessionMaterial pkesk keyInfo) + case unwrapped of + Left err -> + attemptPKESKCandidate + (pkeskRecipientSKey keyInfo : attemptedSKeys) + (previousFailures ++ [mkAttemptFailure keyInfo PKESKAttemptUnwrapFailed err]) + nextAttemptIndex + expectedSymAlgo + errPrefix + resolverAttempts' + Right encodedSessionKey -> + case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of + Left err -> + attemptPKESKCandidate + (pkeskRecipientSKey keyInfo : attemptedSKeys) + (previousFailures ++ + [ mkAttemptFailure + keyInfo + PKESKAttemptSessionMaterialDecodeFailed + err + ]) + nextAttemptIndex + expectedSymAlgo + errPrefix + resolverAttempts' + Right (sa, k) -> do + emitResolutionReport + (mkResolutionReport + DecryptResolvedViaPKESK + skeskErrs + pkeskErrs + resolverAttempts') + pure (sa, SessionKey k) + + emitResolutionReport :: MonadIO m => DecryptSessionKeyResolutionReport -> m () + emitResolutionReport report = + case reportRef of + Nothing -> pure () + Just ref -> liftIO (modifyIORef' ref (report :)) + + mkResolutionReport :: + DecryptSessionKeyResolutionPath + -> [String] + -> [String] + -> [PKESKResolverAttempt] + -> DecryptSessionKeyResolutionReport + mkResolutionReport path skeskErrs pkeskErrs resolverAttempts = + DecryptSessionKeyResolutionReport + { decryptSessionResolutionPath = path + , decryptSessionResolutionSKESKErrors = reverse skeskErrs + , decryptSessionResolutionPKESKErrors = reverse pkeskErrs + , decryptSessionResolutionResolverAttempts = resolverAttempts + } + + mkAttemptFailure keyInfo failureKind reason = + PKESKAttemptFailure + { pkeskAttemptFailureKeyContext = + recipientKeyContext keyInfo + , pkeskAttemptFailureKind = failureKind + , pkeskAttemptFailureReason = reason + } + + recipientKeyContext :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm) + recipientKeyContext keyInfo = + fmap (\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 [] (pkeskCallbackPackets payload) + where + probePacketVariants attemptIndex attemptsAcc [] = + pure (Right (Nothing, attemptIndex, reverse attemptsAcc)) + probePacketVariants attemptIndex attemptsAcc (probePkt:restProbePkts) = do + let request = + PKESKResolveRequest + { reqPKESK = payload + , reqProbePacket = probePkt + , reqIsWildcardRecipient = isWildcardPKESKPayload payload + , reqAttemptIndex = attemptIndex + , reqPreviousFailures = previousFailures + } + resolveAction <- + pkcb request + let attemptRecord = + PKESKResolverAttempt + { pkeskResolverAttemptPreviousFailures = previousFailures + , pkeskResolverAttemptAction = + case resolveAction of + ResolveWith keyInfo -> + ResolverAttemptResolveWith (recipientKeyContext keyInfo) + ResolveSkip -> ResolverAttemptSkip + ResolveExhausted -> ResolverAttemptExhausted + ResolveFail resolverErr -> ResolverAttemptFail resolverErr + } + case resolveAction of + ResolveWith keyInfo -> + pure + (Right (Just keyInfo, attemptIndex + 1, reverse (attemptRecord : attemptsAcc))) + ResolveSkip -> + probePacketVariants + (attemptIndex + 1) + (attemptRecord : attemptsAcc) + restProbePkts + ResolveExhausted -> + pure + (Right (Nothing, attemptIndex + 1, reverse (attemptRecord : attemptsAcc))) + ResolveFail resolverErr -> + pure (Left (renderPKESKResolverError resolverErr)) + + pkeskCallbackPackets payload = + nub $ + case payload of + PKESKPayloadV3Packet (PKESKPayloadV3 v rid pka mpis) -> + map + (\ridVariant -> + PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis))) + (recipientIdCallbackVariantsV3 rid) + PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) -> + map + (\ridVariant -> + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk))) + (recipientIdCallbackVariants rid) + + describeCallbackProbeSummary payload = + intercalate ", " (map describePKESKCallbackProbe (pkeskCallbackPackets payload)) + + describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) = + "PKESK3 " ++ + show pka ++ + " rid=" ++ + show rid ++ + if isWildcardV3RecipientKeyId rid + then " (wildcard)" + else "" + describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) = + "PKESK6 " ++ show pka ++ " rid=" ++ show rid + describePKESKCallbackProbe pkt = show pkt + + recipientIdCallbackVariantsV3 rid + | isWildcardV3RecipientKeyId rid = [rid] + | otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)] + + isWildcardV3RecipientKeyId (EightOctetKeyId rid) = + BL.length rid == 8 && BL.all (== 0) rid + + recipientIdCallbackVariants rid + | BL.length rid == 20 = [rid, BL.cons 0x04 rid] + | BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid] + | BL.length rid == 32 = [rid, BL.cons 0x06 rid] + | BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid] + | otherwise = [rid] + + isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) = + isWildcardV3RecipientKeyId (EightOctetKeyId rid) + isWildcardPKESKPayload _ = False + describePKESK payload = + case classifyPKESKPayload payload of + ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) -> + "PKESK3 " ++ show pka ++ " rid=" ++ show rid + ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) -> + "PKESK6 " ++ show pka ++ " rid=" ++ show rid + + describeSKESK payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k _) -> + "SKESK4 " ++ show sa ++ " s2k=" ++ show s2k + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aa s2k _ _ _) -> + "SKESK6 " ++ show sa ++ "/" ++ show aa ++ " s2k=" ++ show s2k + +data AlignedPendingESK (v :: EncryptedPayloadVersion) where + LegacyAlignedSKESK :: SKESKPayloadV4 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion + LegacyAlignedPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion + SEIPDv2AlignedSKESK :: SKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + SEIPDv2AlignedPKESK :: PKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + -- | A version 3 PKESK that precedes a SEIPDv2 payload. + -- + -- RFC 9580 §5.13 explicitly permits version 3 PKESKs before a version 2 + -- SEIPD packet, as a backward-compatibility allowance for implementations + -- that cannot yet produce v6 key material. The v3 PKESK carries the + -- session key wrapped with legacy (v3) asymmetric key wrapping; the SEIPD + -- v2 payload itself is still authenticated with modern AEAD. This + -- constructor therefore counts as "aligned" for SEIPDv2 — it does not + -- indicate a mis-assembled message — even though the PKESK version does + -- not match the SEIPD version. + SEIPDv2AlignedLegacyPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + +alignedPrecedingESKs :: + EncryptedPayloadFlavor v + -> [PendingESK] + -> [AlignedPendingESK v] +alignedPrecedingESKs LegacyEncryptedPayload = + mapMaybe + (\esk -> + case esk of + PendingSKESK (SKESKPayloadV4Packet skesk4) -> Just (LegacyAlignedSKESK skesk4) + PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (LegacyAlignedPKESK pkesk3) + _ -> Nothing) +alignedPrecedingESKs (SEIPDv2EncryptedPayload _ _) = + mapMaybe + (\esk -> + case esk of + PendingSKESK (SKESKPayloadV6Packet skesk6) -> Just (SEIPDv2AlignedSKESK skesk6) + PendingPKESK (PKESKPayloadV6Packet pkesk6) -> Just (SEIPDv2AlignedPKESK pkesk6) + -- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13; + -- see 'SEIPDv2AlignedLegacyPKESK' for details. + PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (SEIPDv2AlignedLegacyPKESK pkesk3) + _ -> Nothing) + +pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK] +pendingESKsFromAligned = + map + (\esk -> + case esk of + LegacyAlignedSKESK skesk4 -> PendingSKESK (SKESKPayloadV4Packet skesk4) + LegacyAlignedPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3) + SEIPDv2AlignedSKESK skesk6 -> PendingSKESK (SKESKPayloadV6Packet skesk6) + SEIPDv2AlignedPKESK pkesk6 -> PendingPKESK (PKESKPayloadV6Packet pkesk6) + SEIPDv2AlignedLegacyPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3)) + +payloadExpectedSymmetricAlgorithm :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm +payloadExpectedSymmetricAlgorithm LegacyEncryptedPayload = Nothing +payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload sa _) = Just sa + +payloadExpectedAEADAlgorithm :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm +payloadExpectedAEADAlgorithm LegacyEncryptedPayload = Nothing +payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload _ aa) = Just aa + +tryUnwrapPKESKSessionMaterial :: + PKESKPayload -> PKESKRecipientKey -> IO (Either String B.ByteString) +tryUnwrapPKESKSessionMaterial pkesk keyInfo = do + attempted <- try @SomeException (unwrapPKESKSessionMaterial pkesk keyInfo :: IO B.ByteString) + pure (first displayException attempted) + +data PKESKUnwrapCase where + PKESKUnwrapV3RSA :: RSATypes.PrivateKey -> MPI -> PKESKUnwrapCase + PKESKUnwrapV6RSA :: RSATypes.PrivateKey -> B.ByteString -> PKESKUnwrapCase + PKESKUnwrapV6ECDH :: + PKESKRecipientKey + -> PubKeyAlgorithm + -> B.ByteString + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + PKESKUnwrapV6XDHRaw :: + PKESKRecipientKey + -> PubKeyAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKUnwrapCase + PKESKUnwrapV3X25519FromECDH :: + PKESKRecipientKey + -> NonEmpty MPI + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + PKESKUnwrapV3X25519Raw :: + PKESKRecipientKey + -> NonEmpty MPI + -> B.ByteString + -> PKESKUnwrapCase + PKESKUnwrapV3ECDH :: + PKESKRecipientKey + -> PubKeyAlgorithm + -> NonEmpty MPI + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + +data ClassifiedPKESKPayload where + ClassifiedPKESKPayloadV3 :: PKESKPayloadV3 -> ClassifiedPKESKPayload + ClassifiedPKESKPayloadV6 :: PKESKPayloadV6 -> ClassifiedPKESKPayload + +data ClassifiedPKESKRecipientKey where + ClassifiedPKESKRecipientRSA :: + PKESKRecipientKey -> RSATypes.PrivateKey -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientECDH :: + PKESKRecipientKey -> ECDSA.PrivateKey -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientX25519 :: + PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientX448 :: + PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientUnsupported :: + PKESKRecipientKey -> ClassifiedPKESKRecipientKey + +classifyPKESKPayload :: PKESKPayload -> ClassifiedPKESKPayload +classifyPKESKPayload (PKESKPayloadV3Packet payloadV3) = + ClassifiedPKESKPayloadV3 payloadV3 +classifyPKESKPayload (PKESKPayloadV6Packet payloadV6) = + ClassifiedPKESKPayloadV6 payloadV6 + +classifyPKESKRecipientKey :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (RSAPrivateKey (RSA_PrivateKey privateKey))) = + ClassifiedPKESKRecipientRSA keyInfo privateKey +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (ECDHPrivateKey (ECDSA_PrivateKey privateKey))) = + ClassifiedPKESKRecipientECDH keyInfo privateKey +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X25519PrivateKey privateKeyRaw)) = + ClassifiedPKESKRecipientX25519 keyInfo privateKeyRaw +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X448PrivateKey privateKeyRaw)) = + ClassifiedPKESKRecipientX448 keyInfo privateKeyRaw +classifyPKESKRecipientKey keyInfo = + ClassifiedPKESKRecipientUnsupported keyInfo + +pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm +pkeskPayloadAlgorithm payload = + case classifyPKESKPayload payload of + ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _) -> pka + ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _) -> pka + +classifyPKESKUnwrapCase :: + PKESKPayload + -> PKESKRecipientKey + -> Either String PKESKUnwrapCase +classifyPKESKUnwrapCase payload keyInfo = + case (classifyPKESKPayload payload, classifyPKESKRecipientKey keyInfo) of + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka (mpi :| [])) + , ClassifiedPKESKRecipientRSA _ privateKey) + | pka == RSA || pka == DeprecatedRSAEncryptOnly -> + Right (PKESKUnwrapV3RSA privateKey mpi) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientRSA _ privateKey) + | pka == RSA -> + Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk)) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey) + | pka == ECDH || pka == X25519 -> + Right (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw) + | pka == X25519 -> + Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw) + | pka == X448 -> + Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey) + | pka == X25519 -> + Right (PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw) + | pka == X25519 -> + Right (PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey) + | pka == ECDH || pka == X25519 -> + Right (PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey) + (ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _), _) -> + Left ("PKESK key unwrap unsupported for packet algorithm " ++ show pka) + (ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _), _) -> + Left + ("PKESKv6 key unwrap unsupported for packet algorithm " ++ + show pka ++ " with secret key " ++ show (pkeskRecipientSKey keyInfo)) + +unwrapPKESKSessionMaterial :: + (MonadFail m, MonadIO m) => PKESKPayload -> PKESKRecipientKey -> m B.ByteString +unwrapPKESKSessionMaterial pkesk keyInfo = do + either fail pure (validateTable30Policy pkesk keyInfo) + unwrapCase <- either fail pure (classifyPKESKUnwrapCase pkesk keyInfo) + case unwrapCase of + PKESKUnwrapV3RSA privateKey mpi -> + rsaUnwrap + privateKey + (leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi))) + PKESKUnwrapV6RSA privateKey esk -> do + normalized <- either fail pure (normalizePKESKv6RSAEsk privateKey esk) + rsaUnwrap privateKey normalized + PKESKUnwrapV6ECDH recipientCtx pka esk privateKey -> + ecdhUnwrapV6 recipientCtx pka esk privateKey + PKESKUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw -> + ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw + PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey -> do + recipientPKP <- + maybe + (fail + "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") + pure + (pkeskRecipientPKPayload recipientCtx) + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + x25519UnwrapV3 recipientCtx mpis recipientSecretRaw + PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw -> + x25519UnwrapV3 recipientCtx mpis privateKeyRaw + PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey -> + ecdhUnwrap recipientCtx pka mpis privateKey + where + validateTable30Policy :: PKESKPayload -> PKESKRecipientKey -> Either String () + validateTable30Policy payload recipientCtx = + case pkeskRecipientPKPayload recipientCtx of + Nothing -> Right () + Just recipientPKP -> + case (pkeskPayloadAlgorithm payload, _pubkey recipientPKP) of + (ECDH, ECDHPubKey _ kdfHA kdfSA) -> + validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA + _ -> Right () + + rsaUnwrap privateKey encryptedSessionMaterial = do + decrypted <- + liftIO + (P15.decryptSafer privateKey encryptedSessionMaterial :: + IO (Either RSATypes.Error B.ByteString)) + case decrypted of + Left err -> fail ("RSA PKESK decrypt failed: " ++ show err) + Right decoded -> pure decoded + + normalizePKESKv6RSAEsk :: + RSATypes.PrivateKey + -> B.ByteString + -> Either String B.ByteString + normalizePKESKv6RSAEsk privateKey esk = do + when (B.length esk < 2) $ + Left "PKESKv6 RSA ESK is too short to contain an MPI" + let mpiBits = + fromIntegral (B.index esk 0) `shiftL` 8 + + fromIntegral (B.index esk 1) + mpiLen = (mpiBits + 7) `div` 8 + when (B.length esk /= 2 + mpiLen) $ + Left + ("PKESKv6 RSA ESK MPI length mismatch: expected " ++ + show (2 + mpiLen) ++ " octets, got " ++ show (B.length esk)) + let mpiPayload = B.drop 2 esk + when (mpiBits > 0) $ do + when (B.null mpiPayload) $ + Left "PKESKv6 RSA ESK MPI has non-zero bit length but empty payload" + let firstOctet = B.head mpiPayload + actualBits = + (B.length mpiPayload - 1) * 8 + (8 - countLeadingZeros firstOctet) + when (actualBits /= mpiBits) $ + Left + ("PKESKv6 RSA ESK MPI bit-length mismatch: declared " ++ + show mpiBits ++ ", actual " ++ show actualBits) + let modulusLen = rsaModulusBytes privateKey + when (B.length mpiPayload > modulusLen) $ + Left + ("PKESKv6 RSA ESK MPI payload exceeds recipient modulus size: " ++ + show (B.length mpiPayload) ++ " > " ++ show modulusLen) + pure (leftPadTo modulusLen mpiPayload) + + ecdhUnwrap recipientCtx pka mpis privateKey = do + recipientPKP <- + maybe + (fail + "ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") + pure + (pkeskRecipientPKPayload recipientCtx) + case _pubkey recipientPKP of + ECDHPubKey ecdhPub kdfHA kdfSA -> do + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parseECDHPKESKMPIs mpis) + sharedSecret <- + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do + ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes + pure + (BA.convert + (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) :: + B.ByteString) + EdDSAPubKey Ed25519 _ -> do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + recipientSecret <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.secretKey recipientSecretRaw + ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + ephPub <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.publicKey ephBytes + pure . BA.convert $ C25519.dh ephPub recipientSecret + EdDSAPubKey Ed448 _ -> + fail + "legacy ECDH PKESK unwrap does not support Curve448Legacy recipients" + _ -> + fail + "ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" + param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) + let wrappedCandidates = + candidateWrappedRFC3394CiphertextsForLegacyECDH + (LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes) + validUnwraps = + [ material + | wrappedCandidate <- wrappedCandidates + , Right decoded <- [aesKeyUnwrapRFC3394 kdfSA kek (unLegacyECDHWrappedRFC3394Ciphertext wrappedCandidate)] + , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] + ] + case validUnwraps of + (material:_) -> pure (encodeLegacyECDHSessionMaterial material) + [] -> + case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of + Left err -> fail err + Right _ -> + fail + "legacy ECDH wrapped session key decrypted but decoded session material is malformed" + _ -> + fail + "ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters" + + ecdhUnwrapV6 recipientCtx pka esk privateKey = do + recipientPKP <- + maybe + (fail + "ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") + pure + (pkeskRecipientPKPayload recipientCtx) + if pka == X25519 + then do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + v6X25519Unwrap recipientPKP recipientSecretRaw esk + else + if pka == X448 + then + fail + "X448 PKESKv6 unwrap requires an X448PrivateKey recipient secret key and recipient PKPayload context" + else + case _pubkey recipientPKP of + ECDHPubKey ecdhPub kdfHA kdfSA -> do + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk pka esk) + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do + ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes + let sharedSecret = + BA.convert + (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) :: + B.ByteString + param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) + case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + EdDSAPubKey Ed25519 _ -> do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + recipientSecret <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.secretKey recipientSecretRaw + ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + ephPub <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + let rfc6637Result = + do kek <- deriveECDHKek kdfHA kdfSA sharedSecret param + aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes + case rfc6637Result of + Right decoded -> pure decoded + Left rfc6637Err -> do + recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) + let kekX25519 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of + Right decoded -> pure decoded + Left x25519Err -> + fail + ("ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: " ++ + rfc6637Err ++ ", X25519: " ++ x25519Err ++ ")") + EdDSAPubKey Ed448 _ -> + fail + "ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets" + _ -> + fail + "ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" + _ -> + fail + "ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters" + + ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw = do + recipientPKP <- + maybe + (fail + "X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") + pure + (pkeskRecipientPKPayload recipientCtx) + case pka of + X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk + X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk + _ -> + fail + ("X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got " ++ + show pka) + + v6X25519Unwrap recipientPKP recipientSecretRaw esk = do + recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk X25519 esk) + ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.secretKey (leftPadTo 32 recipientSecretRaw) + ephPub <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + + extractX25519RecipientPublic recipientPKP = + case _pubkey recipientPKP of + EdDSAPubKey Ed25519 point -> + normalizeX25519EphemeralPublic (edPointBytes point) + ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ -> + normalizeX25519EphemeralPublic (edPointBytes point) + other -> + Left + ("X25519 PKESKv6 unwrap requires an X25519 recipient public key, got " ++ + show other) + + extractX448RecipientPublic recipientPKP = + case _pubkey recipientPKP of + EdDSAPubKey Ed448 point -> + normalizeX448EphemeralPublic (edPointBytes point) + ECDHPubKey (EdDSAPubKey Ed448 point) _ _ -> + normalizeX448EphemeralPublic (edPointBytes point) + other -> + Left + ("X448 PKESKv6 unwrap requires an X448 recipient public key, got " ++ + show other) + + 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 + + v6X448Unwrap recipientPKP recipientSecretRaw esk = do + recipientPublicRaw <- either fail pure (extractX448RecipientPublic recipientPKP) + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk X448 esk) + ephBytes <- either fail pure (normalizeX448EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure . + first show . CE.eitherCryptoError $ + C448.secretKey (leftPadTo 56 recipientSecretRaw) + ephPub <- + either fail pure . + first show . CE.eitherCryptoError $ + C448.publicKey ephBytes + let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString + kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + + x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do + recipientPKP <- + maybe + (fail + "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") + pure + (pkeskRecipientPKPayload recipientCtx) + recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) + (ephemeralBytes, eskBytes) <- + either fail pure (parseECDHPKESKMPIs mpis) + ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.secretKey (leftPadTo 32 recipientSecretRaw) + ephPub <- + either fail pure . + first show . CE.eitherCryptoError $ + C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + kek9580 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key) + rfc9580Result = do + (sessionAlgorithm, wrappedKey) <- parsePKESKv3X25519EskBytes eskBytes + rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey + expectedLen <- symmetricKeyLength sessionAlgorithm + when (B.length rawKey /= expectedLen) $ + Left + ("X25519 PKESKv3 unwrapped session key length mismatch for " ++ + show sessionAlgorithm ++ + ": expected " ++ show expectedLen ++ ", got " ++ show (B.length rawKey)) + Right + (B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> + rawKey <> + checksum16Bytes rawKey) + case rfc9580Result of + Right result -> pure result + Left rfc9580Err -> + -- Fallback: legacy ECDH interpretation where the full eskBytes is + -- AES-KW(algo || key || checksum || padding). Try with the RFC9580 + -- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from + -- any ECDH parameters on the recipient public key. + let kekPairs = (kek9580, AES128) : x25519LegacyECDHKekCandidates recipientPKP sharedSecret + wrapped = LegacyECDHWrappedRFC3394Ciphertext eskBytes + candidates = candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped + validResults = + [ encodeLegacyECDHSessionMaterial material + | (kek, kekSA) <- kekPairs + , candidate <- candidates + , Right decoded <- + [aesKeyUnwrapRFC3394 kekSA kek (unLegacyECDHWrappedRFC3394Ciphertext candidate)] + , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] + ] + in case validResults of + (result:_) -> pure result + [] -> + fail + ("X25519 PKESKv3 unwrap failed (RFC9580: " ++ + rfc9580Err ++ + "; legacy ECDH-style fallback also failed)") + + -- | Derive RFC6637 ECDH KEK candidates for legacy X25519 PKESKv3 fallback. + -- Returns @(kek, kekAlgorithm)@ pairs for each plausible ECDH KDF + -- parameterisation found on the recipient public key. + x25519LegacyECDHKekCandidates :: + SomePKPayload + -> B.ByteString + -> [(B.ByteString, SymmetricAlgorithm)] + x25519LegacyECDHKekCandidates pkPayload sharedSecret = + case _pubkey pkPayload of + ECDHPubKey ecdhPub kdfHA kdfSA -> + [ (kek, kdfSA) + | Right param <- [buildECDHKDFParam pkPayload X25519 ecdhPub kdfHA kdfSA] + , Right kek <- [deriveECDHKek kdfHA kdfSA sharedSecret param] + ] + _ -> [] + +rsaModulusBytes :: RSATypes.PrivateKey -> Int +rsaModulusBytes (RSATypes.PrivateKey (RSATypes.PublicKey sizeField _ _) _ _ _ _ _ _) = + if sizeField > 512 + then (sizeField + 7) `div` 8 + else sizeField + +edPointBytes :: EdPoint -> B.ByteString +edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x +edPointBytes (NativeEPoint (EPoint x)) = i2osp x + +parseECDHPKESKMPIs :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString) +parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) = + Right (i2osp (unMPI ephemeralMPI), i2osp (unMPI wrappedMPI)) +parseECDHPKESKMPIs _ = + Left "ECDH PKESK must contain exactly two MPIs (ephemeral key, wrapped session key)" + +newtype LegacyECDHWrappedRFC3394Ciphertext = + LegacyECDHWrappedRFC3394Ciphertext + { unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString + } + deriving (Eq) + +newtype LegacyECDHSessionKey = LegacyECDHSessionKey { unLegacyECDHSessionKey :: B.ByteString } + +newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding { unLegacyECDHSessionPadding :: B.ByteString } + +data LegacyECDHDecodedSessionMaterial = + LegacyECDHDecodedSessionMaterial + { legacyECDHSessionAlgorithm :: SymmetricAlgorithm + , legacyECDHSessionKey :: LegacyECDHSessionKey + , legacyECDHSessionPadding :: LegacyECDHSessionPadding + } + +candidateWrappedRFC3394CiphertextsForLegacyECDH :: + LegacyECDHWrappedRFC3394Ciphertext -> [LegacyECDHWrappedRFC3394Ciphertext] +candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped = + let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped) + plausibleWrappedLens = legacyECDHRFC3394WrappedLengths + reconstructed = + [ LegacyECDHWrappedRFC3394Ciphertext + (if observedLen == targetLen + then unLegacyECDHWrappedRFC3394Ciphertext wrapped + else leftPadTo targetLen (unLegacyECDHWrappedRFC3394Ciphertext wrapped)) + | targetLen <- plausibleWrappedLens + , targetLen >= observedLen + ] + in nub (wrapped : reconstructed) + +legacyECDHRFC3394WrappedLengths :: [Int] +legacyECDHRFC3394WrappedLengths = + map legacyRFC3394WrappedLenForKeyLen [16, 24, 32] + where + legacyRFC3394WrappedLenForKeyLen keyLen = + let encodedLen = 1 + keyLen + 2 + paddedLen = ((encodedLen + 7) `div` 8) * 8 + in paddedLen + 8 + +parseLegacyECDHDecodedSessionMaterial :: + B.ByteString -> Either String LegacyECDHDecodedSessionMaterial +parseLegacyECDHDecodedSessionMaterial decoded = do + when (B.length decoded < 3) $ + Left "legacy ECDH decoded session material is too short" + let sessionAlgorithm = toFVal (B.head decoded) + sessionKeyLen <- symmetricKeyLength sessionAlgorithm + let payload = B.tail decoded + when (B.length payload < sessionKeyLen + 2) $ + Left "legacy ECDH decoded session material does not contain full key and checksum" + let (sessionKey, checksumAndPad) = B.splitAt sessionKeyLen payload + (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "legacy ECDH decoded session-key checksum mismatch" + if B.null padBytes || B.all (== 0) padBytes + then + Right + (LegacyECDHDecodedSessionMaterial + sessionAlgorithm + (LegacyECDHSessionKey sessionKey) + (LegacyECDHSessionPadding padBytes)) + else do + validatePKCS7Padding padBytes + Right + (LegacyECDHDecodedSessionMaterial + sessionAlgorithm + (LegacyECDHSessionKey sessionKey) + (LegacyECDHSessionPadding padBytes)) + +encodeLegacyECDHSessionMaterial :: LegacyECDHDecodedSessionMaterial -> B.ByteString +encodeLegacyECDHSessionMaterial + (LegacyECDHDecodedSessionMaterial sessionAlgorithm (LegacyECDHSessionKey sessionKey) _) = + B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> + sessionKey <> + checksum16Bytes sessionKey + +parsePKESKv6ECDHEsk :: PubKeyAlgorithm -> B.ByteString -> Either String (B.ByteString, B.ByteString) +parsePKESKv6ECDHEsk pka esk + | pka == X25519 = + case parseFixedEphemeralWithWrappedLen 32 esk of + Right parsed -> Right parsed + Left _ -> parseLenPrefixedEphemeral 32 esk + | pka == X448 = + case parseFixedEphemeralWithWrappedLen 56 esk of + Right parsed -> Right parsed + Left _ -> parseLenPrefixedEphemeral 56 esk + | B.length esk < 33 = + Left "PKESKv6 ECDH ESK is too short" + | otherwise = + let withLen = + let ephLen = fromIntegral (B.head esk) + rest = B.tail esk + in if ephLen > 0 && B.length rest > ephLen + then + let (eph, wrapped) = B.splitAt ephLen rest + in if validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + fixed32WithWrappedLen = parseFixedEphemeralWithWrappedLenMaybe 32 esk + fixed32 = + let (eph, wrapped) = B.splitAt 32 esk + in if validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + mpiWithWrappedLen = + if B.length esk >= 4 + then + let mpiBits = fromIntegral (B.index esk 0) `shiftL` 8 + fromIntegral (B.index esk 1) + mpiLen = (mpiBits + 7) `div` 8 + rest = B.drop (2 + mpiLen) esk + in if mpiLen > 0 && B.length esk > 2 + mpiLen && not (B.null rest) + then + let eph = B.take mpiLen (B.drop 2 esk) + wrappedLen = fromIntegral (B.head rest) + wrapped = B.tail rest + in if wrappedLen == B.length wrapped && validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + else Nothing + in case fixed32WithWrappedLen <|> withLen <|> fixed32 <|> mpiWithWrappedLen of + Just x -> Right x + Nothing -> + Left + "PKESKv6 ECDH ESK could not be parsed as {ephemeral32||len||wrapped}, {len||ephemeral||wrapped}, {ephemeral32||wrapped}, or {mpi(ephemeral)||len||wrapped}" + where + validWrappedPayload wrapped = B.length wrapped >= 24 && B.length wrapped `mod` 8 == 0 + + parseFixedEphemeralWithWrappedLenMaybe ephLen payload = + let (eph, rest) = B.splitAt ephLen payload + in if B.length rest >= 2 + then + let wrappedLen = fromIntegral (B.head rest) + wrapped = B.tail rest + in if wrappedLen == B.length wrapped && validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + + parseFixedEphemeralWithWrappedLen ephLen payload = + maybe + (Left + ("PKESKv6 XDH ESK expected {ephemeral" ++ + show ephLen ++ "||len||wrapped} framing")) + Right + (parseFixedEphemeralWithWrappedLenMaybe ephLen payload) + + parseLenPrefixedEphemeral expectedLen payload = + if B.null payload + then Left "PKESKv6 XDH ESK is empty" + else + let ephLen = fromIntegral (B.head payload) + rest = B.tail payload + in if ephLen == expectedLen && B.length rest > ephLen + then + let (eph, wrapped) = B.splitAt ephLen rest + in if validWrappedPayload wrapped + then Right (eph, wrapped) + else Left "PKESKv6 XDH ESK wrapped payload has invalid length" + else + Left + ("PKESKv6 XDH ESK expected " ++ + show expectedLen ++ "-octet ephemeral value") + +normalizeX25519EphemeralPublic :: B.ByteString -> Either String B.ByteString +normalizeX25519EphemeralPublic = + normalizeMontgomeryPublic + 32 + "invalid X25519 ephemeral public key length/prefix: " + +normalizeX448EphemeralPublic :: B.ByteString -> Either String B.ByteString +normalizeX448EphemeralPublic = + normalizeMontgomeryPublic + 56 + "invalid X448 ephemeral public key length/prefix: " + +parseUncompressedPointForCurve :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point +parseUncompressedPointForCurve curve bs + | B.length bs < 1 = fail "ECDH ephemeral point is empty" + | Just expectedLen <- expectedUncompressedPointLength curve + , B.length bs /= expectedLen = + fail + ("ECDH ephemeral point has invalid length for recipient curve: expected " ++ + show expectedLen ++ ", got " ++ show (B.length bs)) + | B.head bs /= 0x04 = fail "ECDH ephemeral point must be uncompressed (0x04)" + | otherwise = + let xy = B.tail bs + in if odd (B.length xy) + then fail "ECDH ephemeral point has malformed coordinate length" + else + let (xb, yb) = B.splitAt (B.length xy `div` 2) xy + in pure (ECCT.Point (os2ip xb) (os2ip yb)) + +expectedUncompressedPointLength :: ECCT.Curve -> Maybe Int +expectedUncompressedPointLength curve + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 = Just 65 + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 = Just 97 + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 = Just 133 + | otherwise = Nothing + +deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA256 B.empty ikm + info :: B.ByteString + info = "OpenPGP X25519" + okm :: B.ByteString + okm = expand @CHA.SHA256 prk info 16 + in okm + +deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX448Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA512 B.empty ikm + info :: B.ByteString + info = "OpenPGP X448" + okm :: B.ByteString + okm = expand @CHA.SHA512 prk info 32 + in okm + +aesKeyUnwrapRFC3394 :: + SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString +aesKeyUnwrapRFC3394 sa kek wrapped = + withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek unwrapWithCipher + where + unwrapWithCipher :: + CCT.BlockCipher cipher + => cipher + -> Either String B.ByteString + unwrapWithCipher cipher = do + when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $ + Left "ECDH wrapped session key must be at least 24 octets and a multiple of 8" + let (a0, rBytes) = B.splitAt 8 wrapped + rs = chunksOf8 rBytes + when (length rs < 2) $ + Left "ECDH wrapped session key must contain at least two 64-bit blocks" + (aFinal, rFinal) <- unwrapRounds cipher a0 rs + when (aFinal /= B.replicate 8 0xA6) $ + Left "ECDH wrapped session key integrity check failed" + Right (B.concat rFinal) + + unwrapRounds :: + CCT.BlockCipher cipher + => cipher + -> B.ByteString + -> [B.ByteString] + -> Either String (B.ByteString, [B.ByteString]) + unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit + where + n = length rsInit + goJ j aState rsState + | j < 0 = Right (aState, rsState) + | otherwise = do + (a', rs') <- goI n aState rsState + goJ (j - 1) a' rs' + where + goI i aCurrent rsCurrent + | i <= 0 = Right (aCurrent, rsCurrent) + | otherwise = do + let t = fromIntegral (n * j + i) :: Word64 + aXorT = xorBS aCurrent (encodeWord64be t) + rI = rsCurrent !! (i - 1) + block = CCT.ecbDecrypt cipher (aXorT <> rI) + (aNext, rNext) = B.splitAt 8 block + rsNext = (ix (i - 1) .~ rNext) rsCurrent + goI (i - 1) aNext rsNext + +chunksOf8 :: B.ByteString -> [B.ByteString] +chunksOf8 bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8 t + +xorBS :: B.ByteString -> B.ByteString -> B.ByteString +xorBS a b = B.pack (B.zipWith xor a b) + +decodePKESKSessionKey :: + Maybe SymmetricAlgorithm + -> B.ByteString + -> Either String (SymmetricAlgorithm, B.ByteString) +decodePKESKSessionKey expectedSymAlgo encodedSessionKey = + case decodeOpenPGPEncodedSessionKey encodedSessionKey of + Right (symalgo, sessionKey) -> + case expectedSymAlgo of + Just expected | expected /= symalgo -> + Left "Decrypted PKESK symmetric algorithm does not match payload" + _ -> Right (symalgo, sessionKey) + Left decodeErr -> + case expectedSymAlgo of + Nothing -> + Left + ("PKESK session key material must be OpenPGP encoded when payload algorithm is unknown: " ++ + renderEncodedSessionKeyError decodeErr) + Just expected -> do + expectedLen <- symmetricKeyLength expected + case decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey of + Left err -> Left err + Right sessionKey -> Right (expected, sessionKey) + +parsePKESKv3X25519EskBytes :: + B.ByteString -> Either String (SymmetricAlgorithm, B.ByteString) +parsePKESKv3X25519EskBytes eskBytes = do + when (B.length eskBytes < 2) $ + Left "PKESKv3 X25519 ESK field is too short" + let sessionAlgorithm = toFVal (B.head eskBytes) + wrappedSessionKeyBytes = B.tail eskBytes + when (sessionAlgorithm `notElem` [AES128, AES192, AES256]) $ + Left "PKESKv3 X25519 ESK field uses unsupported symmetric algorithm" + when (B.length wrappedSessionKeyBytes < 24 || B.length wrappedSessionKeyBytes `mod` 8 /= 0) $ + Left "PKESKv3 X25519 wrapped session key must be at least 24 octets and a multiple of 8" + pure (sessionAlgorithm, wrappedSessionKeyBytes) + +decodeExpectedRawOrPaddedSessionKey :: + SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString +decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey + | B.length encodedSessionKey == expectedLen = Right encodedSessionKey + | otherwise = + case decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey of + Right sessionKey -> Right sessionKey + Left _ -> + case decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey of + Right sessionKey -> Right sessionKey + Left _ -> + Left "PKESK raw session key length does not match payload algorithm" + +decodeV6PaddedSessionKeyWithoutAlgo :: Int -> B.ByteString -> Either String B.ByteString +decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey = do + when (B.length encodedSessionKey < expectedLen + 2) $ + Left "v6 ECDH decoded session material is too short" + let (sessionKey, rest) = B.splitAt expectedLen encodedSessionKey + (checksumBytes, padBytes) = B.splitAt 2 rest + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "v6 ECDH decoded session-key checksum mismatch" + validatePKCS7Padding padBytes + Right sessionKey + +decodeV6PaddedSessionKeyWithAlgo :: + SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString +decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey = do + when (B.length encodedSessionKey < expectedLen + 3) $ + Left "v6 ECDH decoded session material with algorithm octet is too short" + let algOctet = B.head encodedSessionKey + when (toFVal algOctet /= expected) $ + Left "v6 ECDH decoded session material algorithm mismatch" + let rest = B.tail encodedSessionKey + (sessionKey, checksumAndPad) = B.splitAt expectedLen rest + (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "v6 ECDH decoded session-key checksum mismatch" + validatePKCS7Padding padBytes + Right sessionKey + +validatePKCS7Padding :: B.ByteString -> Either String () +validatePKCS7Padding padBytes + | B.null padBytes = Right () + | otherwise = do + let padLen = fromIntegral (B.last padBytes) :: Int + when (padLen <= 0 || padLen > 8 || B.length padBytes /= padLen) $ + Left "v6 ECDH decoded session material has invalid PKCS#7-style padding length" + when (B.any (/= fromIntegral padLen) padBytes) $ + Left "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes" + +symmetricKeyLength :: SymmetricAlgorithm -> Either String Int +symmetricKeyLength = first renderCipherError . keySize + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral . + B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 + +checksum16Bytes :: B.ByteString -> B.ByteString +checksum16Bytes sessionKey = + B.pack [fromIntegral (chk `shiftR` 8), fromIntegral chk] + where + chk = checksum16 sessionKey diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs --- a/Data/Conduit/OpenPGP/Filter.hs +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -1,7 +1,8 @@ -- Filter.hs: OpenPGP (RFC4880) packet filtering --- Copyright © 2014-2020 Clint Adams +-- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE GADTs #-} module Data.Conduit.OpenPGP.Filter @@ -19,7 +20,7 @@ import Codec.Encryption.OpenPGP.Types data FilterPredicates r a - = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys + = RTKFilterPredicate (Reader TKUnknown Bool) -- ^ fp for transferable keys | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets | RFilterPredicate (Reader a Bool) -- ^ generic filter predicate | RPairFilterPredicate (Reader (r, a) Bool) -- ^ generic filter predicate with additional context @@ -33,10 +34,10 @@ superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet -conduitTKFilter :: Monad m => FilterPredicates Void TK -> ConduitT TK TK m () +conduitTKFilter :: Monad m => FilterPredicates Void TKUnknown -> ConduitT TKUnknown TKUnknown m () conduitTKFilter = CL.filter . superTKPredicate -superTKPredicate :: FilterPredicates Void TK -> TK -> Bool +superTKPredicate :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e superTKPredicate (RFilterPredicate e) = runReader e diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -1,23 +1,74 @@ --- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright © 2012-2018 Clint Adams +-- Keyring.hs: OpenPGP (RFC9580) transferable keys parsing +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + module Data.Conduit.OpenPGP.Keyring - ( conduitToTKs + ( conduitToUnknownTKs + , conduitToTKs + , conduitToPublicTKs + , conduitToPublicViewTKs + , conduitToSecretTKs + , AuthSecretSubkeyUID(..) + , AuthSecretSubkeyAtTime(..) + , AuthSecretSubkeyRejectionReason(..) + , AuthSecretSubkeyRejectedAtTime(..) + , AuthSecretSubkeysAtReport(..) + , authSecretSubkeysAt + , authSecretSubkeysAtReport + , conduitToAuthSecretSubkeysAt + , conduitToAuthSecretSubkeysAtReport , conduitToTKsDropping - , sinkKeyringMap + , conduitToTKsEither + , conduitToTKsDroppingEither + , conduitToTKsWithWireRep + , conduitToTKsDroppingWithWireRep + , conduitToTKsWithWireRepEither + , conduitToTKsDroppingWithWireRepEither + , KeyringChunkParseError(..) + , sinkPublicKeyringMap + , sinkSecretKeyringMap + , publicTKToKeyring + , secretTKToKeyring + , partitionSomeTKs ) where import Data.Conduit import qualified Data.Conduit.List as CL +import Data.List (find) +import Data.Maybe (maybeToList) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Time.Clock (UTCTime) import Data.IxSet.Typed (empty, insert) +import Codec.Encryption.OpenPGP.Expirations + ( isCertificationSig + , isPKTimeValidWithSelfSignatures + , isTKTimeValid + , newestByCreationTime + , signatureCreationTime + , signatureEffectiveAt + ) import Codec.Encryption.OpenPGP.KeyringParser - ( anyTK - , finalizeParsing - , parseAChunk + ( KeyringChunkParseError(..) + , anyTK + , anyTKWithWireRep + , finalizeParsingEither + , parseAChunkEither ) -import Codec.Encryption.OpenPGP.Ontology (isTrustPkt) +import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isTrustPkt) +import Codec.Encryption.OpenPGP.SignatureQualities + ( signatureHashedSubpacketsKnown + ) +import Codec.Encryption.OpenPGP.Signatures + ( verifyAgainstKeys + , verifySigWith + , verifyTKWith + ) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () @@ -30,37 +81,382 @@ | SkippingBroken deriving (Eq, Ord, Show) -conduitToTKs :: Monad m => ConduitT Pkt TK m () -conduitToTKs = conduitToTKs' True +conduitToUnknownTKs :: Monad m => ConduitT Pkt TKUnknown m () +conduitToUnknownTKs = + conduitToTKsEither .| + conduitDropErrorsAndNothings -conduitToTKsDropping :: Monad m => ConduitT Pkt TK m () -conduitToTKsDropping = conduitToTKs' False +conduitToTKs :: Monad m => ConduitT Pkt SomeTK m () +conduitToTKs = + conduitToUnknownTKs .| + CL.mapMaybe (either (const Nothing) Just . fromUnknownToTK) -fakecmAccum :: +conduitToPublicTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m () +conduitToPublicTKs = + conduitToTKs .| + CL.mapMaybe + (\stk -> + case stk of + SomePublicTK tk -> Just tk + SomeSecretTK _ -> Nothing) + +-- | Yield public TKs from any input: native public TKs pass through, +-- secret TKs are stripped to their public view +conduitToPublicViewTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m () +conduitToPublicViewTKs = + conduitToTKs .| + CL.map + (\stk -> + case stk of + SomePublicTK tk -> tk + SomeSecretTK tk -> publicViewTK tk) + +conduitToSecretTKs :: Monad m => ConduitT Pkt (TK 'SecretTK) m () +conduitToSecretTKs = + conduitToTKs .| + CL.mapMaybe + (\stk -> + case stk of + SomeSecretTK tk -> Just tk + SomePublicTK _ -> Nothing) + +data AuthSecretSubkeyUID = + AuthSecretSubkeyUID + { authSecretSubkeyUIDValue :: Text + , authSecretSubkeyUIDIsPrimary :: Bool + } + deriving (Eq, Show) + +data AuthSecretSubkeyAtTime = + AuthSecretSubkeyAtTime + { authSecretSubkeyPrimaryKey :: KeyPkt 'SecretPkt + , authSecretSubkeyValue :: KeyPkt 'SecretPkt + , authSecretSubkeyUIDs :: [AuthSecretSubkeyUID] + , authSecretSubkeyPrimaryUID :: Maybe Text + } + deriving (Eq, Show) + +data AuthSecretSubkeyRejectionReason + = AuthSecretSubkeyTKVerificationFailed + | AuthSecretSubkeyPrimaryKeyInvalidAtTime + | AuthSecretSubkeyNotSecretSubkeyPacket + | AuthSecretSubkeyNotSubkeyPacket + | AuthSecretSubkeySubkeyInvalidAtTime + | AuthSecretSubkeyMissingAuthCapability + deriving (Eq, Show) + +data AuthSecretSubkeyRejectedAtTime = + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey :: KeyPkt 'SecretPkt + , authSecretSubkeyRejectedValue :: Maybe (KeyPkt 'SecretPkt) + , authSecretSubkeyRejectedUIDs :: [AuthSecretSubkeyUID] + , authSecretSubkeyRejectedPrimaryUID :: Maybe Text + , authSecretSubkeyRejectedReason :: AuthSecretSubkeyRejectionReason + } + deriving (Eq, Show) + +data AuthSecretSubkeysAtReport = + AuthSecretSubkeysAtReport + { authSecretSubkeysAccepted :: [AuthSecretSubkeyAtTime] + , authSecretSubkeysRejected :: [AuthSecretSubkeyRejectedAtTime] + } + deriving (Eq, Show) + +conduitToAuthSecretSubkeysAtReport :: Monad m - => (accum -> (accum, [b])) - -> (a -> accum -> (accum, [b])) + => UTCTime + -> ConduitT (TK 'SecretTK) AuthSecretSubkeysAtReport m () +conduitToAuthSecretSubkeysAtReport validationTime = + CL.map (authSecretSubkeysAtReport validationTime) + +conduitToAuthSecretSubkeysAt :: + Monad m + => UTCTime + -> ConduitT (TK 'SecretTK) AuthSecretSubkeyAtTime m () +conduitToAuthSecretSubkeysAt validationTime = + CL.concatMap (authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime) + +authSecretSubkeysAt :: UTCTime -> TK 'SecretTK -> [AuthSecretSubkeyAtTime] +authSecretSubkeysAt validationTime = + authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime + +authSecretSubkeysAtReport :: UTCTime -> TK 'SecretTK -> AuthSecretSubkeysAtReport +authSecretSubkeysAtReport validationTime typedTk = + case verifyTKWith (verifySigWith (verifyAgainstKeys [untyped])) (Just validationTime) typedTk of + Left _ -> + AuthSecretSubkeysAtReport + [] + [ AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Nothing + , authSecretSubkeyRejectedUIDs = [] + , authSecretSubkeyRejectedPrimaryUID = Nothing + , authSecretSubkeyRejectedReason = AuthSecretSubkeyTKVerificationFailed + } + ] + Right verifiedTk + | not (isTKTimeValid validationTime (tkToUnknown verifiedTk)) -> + let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) + primaryUid = authSecretSubkeyUIDValue <$> find authSecretSubkeyUIDIsPrimary uids + in AuthSecretSubkeysAtReport + [] + [ AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Nothing + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = AuthSecretSubkeyPrimaryKeyInvalidAtTime + } + ] + | otherwise -> + let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) + primaryUid = authSecretSubkeyUIDValue <$> find authSecretSubkeyUIDIsPrimary uids + in foldr + (\subCandidate acc -> + case classifySecretSubkeyAtTime validationTime primaryKey uids primaryUid subCandidate of + Left rejected -> + acc {authSecretSubkeysRejected = rejected : authSecretSubkeysRejected acc} + Right accepted -> + acc {authSecretSubkeysAccepted = accepted : authSecretSubkeysAccepted acc}) + (AuthSecretSubkeysAtReport [] []) + (_tkSubs verifiedTk) + where + untyped = tkToUnknown typedTk + primaryKey = _tkPrimaryKey typedTk + +classifySecretSubkeyAtTime :: + UTCTime + -> KeyPkt 'SecretPkt + -> [AuthSecretSubkeyUID] + -> Maybe Text + -> (KeyPkt 'SecretPkt, [SignaturePayload]) + -> Either AuthSecretSubkeyRejectedAtTime AuthSecretSubkeyAtTime +classifySecretSubkeyAtTime validationTime primaryKey uids primaryUid (subkey, sigs) + | keyPktRole subkey /= KeyPktSubkey = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = AuthSecretSubkeyNotSubkeyPacket + } + | not (isPKTimeValidWithSelfSignatures validationTime (keyPktPKPayload subkey) sigs) = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = AuthSecretSubkeySubkeyInvalidAtTime + } + | not (subkeyAuthCapableAt validationTime sigs) = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = AuthSecretSubkeyMissingAuthCapability + } + | otherwise = + Right + AuthSecretSubkeyAtTime + { authSecretSubkeyPrimaryKey = primaryKey + , authSecretSubkeyValue = subkey + , authSecretSubkeyUIDs = uids + , authSecretSubkeyPrimaryUID = primaryUid + } + +uidContextsAt :: UTCTime -> TKUnknown -> [AuthSecretSubkeyUID] +uidContextsAt validationTime tk = + map + (\(uid, _) -> + AuthSecretSubkeyUID + { authSecretSubkeyUIDValue = uid + , authSecretSubkeyUIDIsPrimary = Just uid == primaryUid + }) + (_tkuUIDs tk) + where + primaryUid = primaryUIDAt validationTime (_tkuUIDs tk) + +primaryUIDAt :: UTCTime -> [(Text, [SignaturePayload])] -> Maybe Text +primaryUIDAt validationTime uids = + snd <$> newestByCreationTime candidates + where + candidates = + [ (createdAt, uid) + | (uid, sigs) <- uids + , cert <- maybeToList (latestEffectiveCertificationAt validationTime sigs) + , signatureMarksPrimaryUID cert + , createdAt <- maybeToList (signatureCreationTime cert) + ] + +subkeyAuthCapableAt :: UTCTime -> [SignaturePayload] -> Bool +subkeyAuthCapableAt validationTime sigs = + maybe False signatureHasAuthKeyFlag (latestEffectiveBindingSignatureAt validationTime sigs) + +latestEffectiveBindingSignatureAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestEffectiveBindingSignatureAt validationTime sigs = + snd <$> + newestByCreationTime + [ (createdAt, sig) + | sig <- sigs + , isSubkeyBindingSig sig + , signatureEffectiveAt validationTime sig + , createdAt <- maybeToList (signatureCreationTime sig) + ] + +latestEffectiveCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestEffectiveCertificationAt validationTime sigs = + snd <$> + newestByCreationTime + [ (createdAt, sig) + | sig <- sigs + , isCertificationSig sig + , signatureEffectiveAt validationTime sig + , createdAt <- maybeToList (signatureCreationTime sig) + ] + +signatureHasAuthKeyFlag :: SignaturePayload -> Bool +signatureHasAuthKeyFlag sig = + Set.member AuthKey (signatureKeyFlags sig) + +signatureKeyFlags :: SignaturePayload -> Set.Set KeyFlag +signatureKeyFlags sig = + foldr + (\sp acc -> + case sp of + SigSubPacket _ (KeyFlags flags) -> Set.union flags acc + _ -> acc) + Set.empty + (maybe [] id (signatureHashedSubpacketsKnown sig)) + +signatureMarksPrimaryUID :: SignaturePayload -> Bool +signatureMarksPrimaryUID sig = + any + (\sp -> + case sp of + SigSubPacket _ (PrimaryUserId True) -> True + _ -> False) + (maybe [] id (signatureHashedSubpacketsKnown sig)) + +conduitToTKsEither :: + Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsEither = conduitToTKsEither' True + +conduitToTKsDropping :: Monad m => ConduitT Pkt TKUnknown m () +conduitToTKsDropping = + conduitToTKsDroppingEither .| + conduitDropErrorsAndNothings + +conduitToTKsDroppingEither :: + Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsDroppingEither = conduitToTKsEither' False + +conduitToTKsWithWireRep :: Monad m => ConduitT PktWithWireRep TKWithWireRep m () +conduitToTKsWithWireRep = + conduitToTKsWithWireRepEither .| + conduitDropErrorsAndNothings + +conduitToTKsWithWireRepEither :: + Monad m + => ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () +conduitToTKsWithWireRepEither = conduitToTKsWithWireRepEither' True + +conduitToTKsDroppingWithWireRep :: + Monad m => ConduitT PktWithWireRep TKWithWireRep m () +conduitToTKsDroppingWithWireRep = + conduitToTKsDroppingWithWireRepEither .| + conduitDropErrorsAndNothings + +conduitToTKsDroppingWithWireRepEither :: + Monad m + => ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () +conduitToTKsDroppingWithWireRepEither = conduitToTKsWithWireRepEither' False + +fakecmAccumEither :: + Monad m + => (accum -> Either e (accum, [b])) + -> (a -> accum -> Either e (accum, [b])) -> accum - -> ConduitT a b m () -fakecmAccum finalizer f = loop + -> ConduitT a (Either e b) m () +fakecmAccumEither finalizer f initialAccum = loop initialAccum where - loop accum = await >>= maybe (mapM_ yield (snd (finalizer accum))) go - where - go a = do - let (accum', bs) = f a accum - mapM_ yield bs - loop accum' + loop accum = + await >>= + maybe + (case finalizer accum of + Left err -> yield (Left err) + Right (_, bs) -> mapM_ (yield . Right) bs) + go + where + go a = do + case f a accum of + Left err -> do + yield (Left err) + loop initialAccum + Right (accum', bs) -> do + mapM_ (yield . Right) bs + loop accum' -conduitToTKs' :: Monad m => Bool -> ConduitT Pkt TK m () -conduitToTKs' intolerant = +conduitDropErrorsAndNothings :: + Monad m => ConduitT (Either e (Maybe a)) a m () +conduitDropErrorsAndNothings = + CL.mapMaybe (either (const Nothing) id) + +conduitToTKsEither' :: + Monad m => Bool -> ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsEither' intolerant = CL.filter notTrustPacket .| CL.map (: []) .| - fakecmAccum - finalizeParsing - (parseAChunk (anyTK intolerant)) - ([], Just (Nothing, anyTK intolerant)) .| - CL.catMaybes + fakecmAccumEither + finalizeParsingEither + (parseAChunkEither (anyTK intolerant)) + ([], Just (Nothing, anyTK intolerant)) where notTrustPacket = not . isTrustPkt -sinkKeyringMap :: Monad m => ConduitT TK Void m Keyring -sinkKeyringMap = CL.fold (flip insert) empty +conduitToTKsWithWireRepEither' :: + Monad m + => Bool + -> ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () +conduitToTKsWithWireRepEither' intolerant = + CL.filter notTrustPacket .| CL.map (: []) .| + fakecmAccumEither + finalizeParsingEither + (parseAChunkEither (anyTKWithWireRep intolerant)) + ([], Just (Nothing, anyTKWithWireRep intolerant)) + where + notTrustPacket = not . isTrustPkt . _pktValue + +sinkPublicKeyringMap :: Monad m => ConduitT (TK 'PublicTK) Void m PublicKeyring +sinkPublicKeyringMap = CL.fold (flip insert) empty + +sinkSecretKeyringMap :: Monad m => ConduitT (TK 'SecretTK) Void m SecretKeyring +sinkSecretKeyringMap = CL.fold (flip insert) empty + +-- | Lift a single typed TK into its kinded keyring +publicTKToKeyring :: TK 'PublicTK -> PublicKeyring +publicTKToKeyring tk = insert tk empty + +secretTKToKeyring :: TK 'SecretTK -> SecretKeyring +secretTKToKeyring tk = insert tk empty + +-- | Partition a list of SomeTK into homogeneous public and secret keyrings +partitionSomeTKs :: [SomeTK] -> (PublicKeyring, SecretKeyring) +partitionSomeTKs = foldr step (empty, empty) + where + step (SomePublicTK tk) (pub, sec) = (insert tk pub, sec) + step (SomeSecretTK tk) (pub, sec) = (pub, insert tk sec) diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs --- a/Data/Conduit/OpenPGP/Keyring/Instances.hs +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -1,7 +1,9 @@ --- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys --- Copyright © 2012-2019 Clint Adams +-- Instances.hs: OpenPGP (RFC9580) additional types for transferable keys +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -14,6 +16,7 @@ import Codec.Encryption.OpenPGP.Internal (issuer) import Codec.Encryption.OpenPGP.SignatureQualities (sigCT) import Codec.Encryption.OpenPGP.Types +import Control.Arrow (second) import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate) import Data.Either (rights) @@ -21,41 +24,146 @@ import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (Indexable(..), ixFun, ixList) import Data.List (nub, sort) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Semigroup (Semigroup, (<>)) import Data.Text (Text) -instance Indexable KeyringIxs TK where - indices = ixList (ixFun getEOKIs) (ixFun getTOFs) (ixFun getUIDs) +instance Indexable KeyringIxs TKUnknown where + indices = ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs) -getEOKIs :: TK -> [EightOctetKeyId] -getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload])) +getEOKIs :: TKUnknown -> [EightOctetKeyId] +getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload])) -getTOFs :: TK -> [TwentyOctetFingerprint] -getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload]) +getFingerprints :: TKUnknown -> [Fingerprint] +getFingerprints tk = map fingerprint (tk ^.. biplate :: [SomePKPayload]) -getUIDs :: TK -> [Text] -getUIDs tk = (tk ^. tkUIDs) ^.. folded . _1 +getUIDs :: TKUnknown -> [Text] +getUIDs tk = (tk ^. tkuUIDs) ^.. folded . _1 -instance Ord SignaturePayload where - compare s1@(SigV3 st1 ct1 eoki1 pka1 ha1 left16_1 mpis1) s2@(SigV3 st2 ct2 eoki2 pka2 ha2 left16_2 mpis2) = - compare ct1 ct2 <> compare st1 st2 <> compare eoki1 eoki2 -- FIXME: nondeterministic - compare s1@(SigV4 st1 pka1 ha1 has1 uhas1 left16_1 mpis1) s2@(SigV4 st2 pka2 ha2 has2 uhas2 left16_2 mpis2) = - compare (sigCT s1) (sigCT s2) <> compare st1 st2 <> - compare (issuer (SignaturePkt s1)) (issuer (SignaturePkt s2)) -- FIXME: nondeterministic - compare s1@(SigVOther sv1 bs1) s2@(SigVOther sv2 bs2) = - compare sv1 sv2 <> compare bs1 bs2 - compare SigV3 {} SigV4 {} = LT - compare SigV3 {} SigVOther {} = LT - compare SigV4 {} SigV3 {} = GT - compare SigV4 {} SigVOther {} = LT - compare SigVOther {} SigV3 {} = GT - compare SigVOther {} SigV4 {} = GT +instance Semigroup TKUnknown where + (<>) a b = + TKUnknown + (_tkuKey a) + (nub . sort $ _tkuRevs a ++ _tkuRevs b) + ((kvmerge `on` _tkuUIDs) a b) + ((kvmerge `on` _tkuUAts) a b) + ((ukvmerge `on` _tkuSubs) a b) + where + kvmerge x y = + Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y)) + ukvmerge x y = + HashMap.toList + (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) + nsa x y = nub . sort $ x ++ y -instance Semigroup TK where +instance Semigroup TKWithWireRep where (<>) a b = + let mergedTK = _tkValue a <> _tkValue b + mergedPackets = + selectPacketRefsByValue + (flattenTKPackets mergedTK) + (dedupePacketRefsById (_tkPackets a ++ _tkPackets b)) + in TKWithWireRep + (mergeWireRepRefs (_tkWireRepRefs a) (_tkWireRepRefs b)) + (mergedWireRepRange mergedPackets) + mergedPackets + mergedTK + +flattenTKPackets :: TKUnknown -> [Pkt] +flattenTKPackets tk = + [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ + map SignaturePkt (_tkuRevs tk) ++ + concatMap flattenUID (_tkuUIDs tk) ++ + concatMap flattenUAT (_tkuUAts tk) ++ + concatMap flattenSub (_tkuSubs tk) + where + (pkp, mska) = _tkuKey tk + flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs + flattenUAT (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs + flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs + +mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs +mergeWireRepRefs left right = + case dedupe (NE.toList left ++ NE.toList right) of + [] -> left + (x:xs) -> x NE.:| xs + where + dedupe [] = [] + dedupe (x:xs) = x : dedupe (filter (/= x) xs) + +mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange +mergedWireRepRange [] = Nothing +mergedWireRepRange (pkt:rest) + | all ((== _pktWireRepRef pkt) . _pktWireRepRef) rest = + spanByteRanges (map _pktRange (pkt : rest)) + | otherwise = Nothing + +dedupePacketRefsById :: [PktWithWireRep] -> [PktWithWireRep] +dedupePacketRefsById = go [] + where + go _ [] = [] + go seen (pkt:rest) = + let packetRefId = packetRefIdOf pkt + in if packetRefId `elem` seen + then go seen rest + else pkt : go (packetRefId : seen) rest + +selectPacketRefsByValue :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] +selectPacketRefsByValue expected available = go expected available [] + where + go [] _ acc = reverse acc + go (pkt:pktRest) refs acc = + case extractFirstByValue pkt refs of + Nothing -> + error + ("TKWithWireRep Semigroup merge missing packet reference for tag " ++ + show (pktTag pkt)) + Just (matched, remaining) -> go pktRest remaining (matched : acc) + +extractFirstByValue :: Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep]) +extractFirstByValue _ [] = Nothing +extractFirstByValue expected (pkt:rest) + | _pktValue pkt == expected = Just (pkt, rest) + | otherwise = second (pkt :) <$> extractFirstByValue expected rest + +-- | Extract all SomePKPayloads from a TK (primary + subkeys) without biplate +tkPKPayloads :: TK k -> [SomePKPayload] +tkPKPayloads tk = + keyPktPKPayload (_tkPrimaryKey tk) : + map (keyPktPKPayload . fst) (_tkSubs tk) + +-- | Index public TKs by key ID, fingerprint, and UID +instance Indexable KeyringIxs (TK 'PublicTK) where + indices = ixList (ixFun getEOKIsPublic) (ixFun getFingerprintsPublic) (ixFun getUIDsPublic) + +getEOKIsPublic :: TK 'PublicTK -> [EightOctetKeyId] +getEOKIsPublic tk = rights (map eightOctetKeyID (tkPKPayloads tk)) + +getFingerprintsPublic :: TK 'PublicTK -> [Fingerprint] +getFingerprintsPublic tk = map fingerprint (tkPKPayloads tk) + +getUIDsPublic :: TK 'PublicTK -> [Text] +getUIDsPublic tk = (tk ^. tkUIDs) ^.. folded . _1 + +-- | Index secret TKs by key ID, fingerprint, and UID +instance Indexable KeyringIxs (TK 'SecretTK) where + indices = ixList (ixFun getEOKIsSecret) (ixFun getFingerprintsSecret) (ixFun getUIDsSecret) + +getEOKIsSecret :: TK 'SecretTK -> [EightOctetKeyId] +getEOKIsSecret tk = rights (map eightOctetKeyID (tkPKPayloads tk)) + +getFingerprintsSecret :: TK 'SecretTK -> [Fingerprint] +getFingerprintsSecret tk = map fingerprint (tkPKPayloads tk) + +getUIDsSecret :: TK 'SecretTK -> [Text] +getUIDsSecret tk = (tk ^. tkUIDs) ^.. folded . _1 + + +instance Semigroup (TK k) where + a <> b = TK - (_tkKey a) + (_tkPrimaryKey a) (nub . sort $ _tkRevs a ++ _tkRevs b) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) diff --git a/Data/Conduit/OpenPGP/Message.hs b/Data/Conduit/OpenPGP/Message.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Message.hs @@ -0,0 +1,95 @@ +-- Message.hs: conduit-backed OpenPGP message helpers +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +module Data.Conduit.OpenPGP.Message + ( VerificationPolicy(..) + , VerificationOptions(..) + , defaultVerificationOptions + , verifyMessagePackets + , verifyMessage + , VerificationMode(..) + ) where + +import qualified Data.ByteString.Lazy as BL +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.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.Signatures (VerificationError) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Verify + ( VerificationMode(..) + , VerificationModeW(..) + , verifyPacketsWithModeTyped + , verifyPacketsBatch + ) + +data VerificationPolicy + = VerifyInformational + | VerifyStrict + deriving (Eq, Show) + +data VerificationOptions = VerificationOptions + { 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 + } + +verifyMessagePackets :: + VerificationOptions + -> PublicKeyring + -> [Pkt] + -> [Either VerificationError Verification] +verifyMessagePackets options keyring packets = + 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 + +verifyMessage :: + VerificationOptions + -> PublicKeyring + -> BL.ByteString + -> [Either VerificationError Verification] +verifyMessage options keyring signedMessage = + verifyMessagePackets + options + keyring + (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) + +applyVerificationPolicy :: + VerificationPolicy + -> [Either VerificationError Verification] + -> [Either VerificationError Verification] +applyVerificationPolicy VerifyInformational results = results +applyVerificationPolicy VerifyStrict results = + either (pure . Left) (Right <$>) (sequence results) diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -1,36 +1,138 @@ --- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2016 Clint Adams +-- Verify.hs: OpenPGP (RFC9580) signature verification +-- 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 Data.Conduit.OpenPGP.Verify - ( conduitVerify + ( VerificationMode(..) + , VerificationModeW(..) + , conduitVerify + , verifyPacketsBatch + , verifyPacketsWithModeTyped + , verifyPacketsWithMode ) where import Data.Conduit import Data.Time.Clock (UTCTime) +import Data.List (foldl') import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) -import Codec.Encryption.OpenPGP.Signatures (verifyAgainstKeyring, verifySigWith) +import Codec.Encryption.OpenPGP.Signatures + ( VerificationError(..) + , verifyAgainstKeyring + , verifySigWith + ) import Codec.Encryption.OpenPGP.Types import qualified Data.Conduit.List as CL +data VerificationMode + = VerificationStreaming + | VerificationBatch + deriving (Eq, Show) + +data VerificationModeW (mode :: VerificationMode) where + VerificationStreamingW :: VerificationModeW 'VerificationStreaming + VerificationBatchW :: VerificationModeW 'VerificationBatch + conduitVerify :: Monad m - => Keyring + => PublicKeyring -> Maybe UTCTime - -> ConduitT Pkt (Either String Verification) m () -conduitVerify kr mt = CL.concatMapAccum (flip push) emptyPSC + -> ConduitT Pkt (Either VerificationError Verification) m () +conduitVerify kr mt = + CL.concatMapAccum (\pkt state -> pushPacketTyped kr mt pkt state) emptyPSC + +verifyPacketsBatch :: + PublicKeyring + -> Maybe UTCTime + -> [Pkt] + -> [Either VerificationError Verification] +verifyPacketsBatch kr mt = + verifyPacketsBatchTyped kr mt + +verifyPacketsBatchTyped :: + PublicKeyring + -> Maybe UTCTime + -> [Pkt] + -> [Either VerificationError Verification] +verifyPacketsBatchTyped kr mt = + reverse . snd . foldl' step (emptyPSC, []) where - push state ld@LiteralDataPkt {} = (state {lastLD = ld}, []) - push state uid@(UserIdPkt _) = (state {lastUIDorUAt = uid}, []) - push state uat@(UserAttributePkt _) = (state {lastUIDorUAt = uat}, []) - push state pk@(PublicKeyPkt _) = (state {lastPrimaryKey = pk}, []) - push state pk@(PublicSubkeyPkt _) = (state {lastSubkey = pk}, []) - push state sk@(SecretKeyPkt _ _) = (state {lastPrimaryKey = sk}, []) - push state sk@(SecretSubkeyPkt _ _) = (state {lastSubkey = sk}, []) - push state sig@(SignaturePkt SigV4 {}) = + step (state, outputs) pkt = + let (nextState, newOutputs) = pushPacketTyped kr mt pkt state + in (nextState, reverse newOutputs ++ outputs) + +verifyPacketsWithMode :: + Monad m + => VerificationMode + -> PublicKeyring + -> Maybe UTCTime + -> ConduitT Pkt (Either VerificationError Verification) m () +verifyPacketsWithMode VerificationStreaming kr mt = + verifyPacketsWithModeTyped VerificationStreamingW kr mt +verifyPacketsWithMode VerificationBatch kr mt = + verifyPacketsWithModeTyped VerificationBatchW kr mt + +verifyPacketsWithModeTyped :: + Monad m + => VerificationModeW mode + -> PublicKeyring + -> Maybe UTCTime + -> ConduitT Pkt (Either VerificationError Verification) m () +verifyPacketsWithModeTyped modeW kr mt = + case modeW of + VerificationStreamingW -> conduitVerify kr mt + VerificationBatchW -> CL.consume >>= mapM_ yield . verifyPacketsBatch kr mt + +pushPacketTyped :: + PublicKeyring + -> Maybe UTCTime + -> Pkt + -> PktStreamContext + -> (PktStreamContext, [Either VerificationError Verification]) +pushPacketTyped _ _ ld@LiteralDataPkt {} state = (state {lastLD = ld}, []) +pushPacketTyped _ _ uid@(UserIdPkt _) state = (state {lastUIDorUAt = uid}, []) +pushPacketTyped _ _ uat@(UserAttributePkt _) state = (state {lastUIDorUAt = uat}, []) +pushPacketTyped _ _ pk@(PublicKeyPkt _) state = (state {lastPrimaryKey = pk}, []) +pushPacketTyped _ _ pk@(PublicSubkeyPkt _) state = (state {lastSubkey = pk}, []) +pushPacketTyped _ _ sk@(SecretKeyPkt _ _) state = (state {lastPrimaryKey = sk}, []) +pushPacketTyped _ _ sk@(SecretSubkeyPkt _ _) state = (state {lastSubkey = sk}, []) +pushPacketTyped kr mt sig@(SignaturePkt signature) state = + case fromSignaturePayloadVerifiableSignatureV signature of + Just _ -> ( state {lastSig = sig} - , [verifySigWith (verifyAgainstKeyring kr) sig state mt]) - push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, []) - push state _ = (state, []) - normLineEndings = id -- FIXME + , [verifySigWith (verifyAgainstKeyring kr) sig state mt] + ) + Nothing -> (state, []) +pushPacketTyped _ _ (OtherPacketPkt t _) state | t < 40 = + (state, [Left (UnknownCriticalPacketInStream t)]) +pushPacketTyped _ _ (BrokenPacketPkt err t _) state | t < 40 = + (state, [Left (BrokenCriticalPacketInStream t err)]) +pushPacketTyped _ _ pkt@(OnePassSignaturePkt _) state + | isOpeningOnePassSignature pkt = (state, []) +pushPacketTyped _ _ _ state = (state, []) + +data VerifiableSignatureV where + VerifiableSignatureV4 :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV + VerifiableSignatureV6 :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV + +fromSignaturePayloadVerifiableSignatureV :: + SignaturePayload -> Maybe VerifiableSignatureV +fromSignaturePayloadVerifiableSignatureV sigPayload = + case toSomeSignaturePayload sigPayload of + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (VerifiableSignatureV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (VerifiableSignatureV6 payload) + _ -> Nothing + +isOpeningOnePassSignature :: Pkt -> Bool +isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False))) = + True +isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False))) = + True +isOpeningOnePassSignature _ = False diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright © 2012-2014 Clint Adams +Copyright © 2012-2026 Clint Adams Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -6,15 +6,15 @@ without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to -the following conditions: +the following conditions: The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. +included in all copies or substantial portions of the Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/mark.hs b/bench/mark.hs --- a/bench/mark.hs +++ b/bench/mark.hs @@ -1,22 +1,36 @@ -- mark.hs: hOpenPGP benchmark suite --- Copyright © 2014-2018 Clint Adams +-- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). + {-# LANGUAGE FlexibleContexts #-} import Criterion.Main +import Codec.Encryption.OpenPGP.Serialize + ( conduitParsePktsWithWireRep + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + ) import Codec.Encryption.OpenPGP.Signatures ( verifyAgainstKeyring , verifyAgainstKeys , verifySigWith , verifyTKWith + , verifyUnknownTKWith ) +import Codec.Encryption.OpenPGP.Types (wireRepRef) import Data.Binary (get) -import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap) +import Data.Conduit.OpenPGP.Keyring + ( conduitToPublicViewTKs + , conduitToUnknownTKs + , sinkPublicKeyringMap + ) import Data.Conduit.Serialization.Binary (conduitGet) import qualified Data.IxSet.Typed as IxSet +import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB @@ -34,19 +48,41 @@ , bench "self-verify keyring" $ whnfIO (selfVerifyKeyring "tests/data/pubring.gpg") ] + , env (BL.readFile "tests/data/pubring.gpg") $ \pubringPayload -> + let pubringRef = wireRepRef pubringPayload + in + bgroup + "packet-parse" + [ bench "parsePkts/count" $ nf (length . parsePkts) pubringPayload + , bench "parsePktsEither/count" $ + nf + (either (const 0) length . parsePktsEither) + pubringPayload + , bench "parsePktsWithWireRep/count" $ + nf + (length . parsePktsWithWireRep pubringRef) + pubringPayload + , bench "conduitParsePktsWithWireRep/count" $ + whnfIO + (fmap + length + (DC.runConduitRes $ + CB.sourceLbs pubringPayload DC..| conduitParsePktsWithWireRep Nothing DC..| + CL.consume)) + ] ] where loadKeys fp = DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume + CB.sourceFile fp DC..| conduitGet get DC..| conduitToUnknownTKs DC..| CL.consume loadKeyring fp = DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| - sinkKeyringMap + CB.sourceFile fp DC..| conduitGet get DC..| conduitToPublicViewTKs DC..| + sinkPublicKeyringMap selfVerifyKeys fp = fmap (\ks -> - mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) + mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) (loadKeys fp) selfVerifyKeyring fp = fmap diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,8 +1,8 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 2.10.1.1 -Synopsis: native Haskell implementation of OpenPGP (RFC4880) -Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581), plus ECC (RFC6637) +Version: 3.0.0 +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 License: MIT License-file: LICENSE @@ -151,6 +151,8 @@ , tests/data/nist_p-256_secretkey.gpg , tests/data/ecdsa-key-without-ecdh.pubkey , tests/data/sample-eddsa.pubkey + , tests/data/v6-secret.pgp.aa + , tests/data/v6.rev.aa , tests/data/ed25519-without-curve25519.pubkey , tests/data/ed25519.pubkey , tests/data/ed25519.secretkey @@ -161,13 +163,19 @@ , tests/data/v6-encrypted-secret.pgp.aa , tests/data/v6-encrypted.rev.aa , tests/data/seipdv2.pgp.aa + , tests/data/seipdv2-for-v4-key.pgp.aa + , tests/data/v4-encrypted-secret.pgp.aa + , tests/data/v4-encrypted.rev.aa + , tests/data/seipdv2-three-recipients.pgp.aa + , tests/data/seipdv2-two-recipients.pgp.aa + , tests/data/encryption-sym-aes256-sha256.pgp flag use-memory description: Use the 'memory' package instead of 'ram' default: False common deps - build-depends: aeson + build-depends: aeson >= 2.0 && < 3 , attoparsec , base > 4.9 && < 5 , base16-bytestring @@ -181,7 +189,7 @@ , containers , crypto-cipher-types , errors - , hashable + , hashable >= 1.3.4 && <1.6 , incremental-parser >= 0.5.1 , ixset-typed , lens >= 3.0 @@ -206,30 +214,39 @@ common publicmods other-modules: Codec.Encryption.OpenPGP.Types , Codec.Encryption.OpenPGP.CFB + , Codec.Encryption.OpenPGP.Message , Codec.Encryption.OpenPGP.Compression + , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection , Codec.Encryption.OpenPGP.Ontology + , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities + , Codec.Encryption.OpenPGP.Subpackets , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances + , Data.Conduit.OpenPGP.Message , Data.Conduit.OpenPGP.Verify common internalmods other-modules: Codec.Encryption.OpenPGP.Internal + , Codec.Encryption.OpenPGP.Internal.CryptoAES , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes + , Codec.Encryption.OpenPGP.Internal.CryptoECDH + , Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher + , Codec.Encryption.OpenPGP.Internal.RFC7253OCB , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes , Codec.Encryption.OpenPGP.Types.Internal.PKITypes @@ -246,34 +263,47 @@ import: deps, internalmods Exposed-modules: Codec.Encryption.OpenPGP.Types , Codec.Encryption.OpenPGP.CFB + , Codec.Encryption.OpenPGP.Message , Codec.Encryption.OpenPGP.Compression + , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection , Codec.Encryption.OpenPGP.Ontology + , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities + , Codec.Encryption.OpenPGP.Subpackets , Codec.Encryption.OpenPGP.Version , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances + , Data.Conduit.OpenPGP.Message , Data.Conduit.OpenPGP.Verify Build-depends: asn1-encoding - , openpgp-asciiarmor >= 0.1 + , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 Test-Suite tests import: deps, publicmods, internalmods type: exitcode-stdio-1.0 - main-is: tests/suite.hs + hs-source-dirs: . tests + main-is: suite.hs other-modules: Codec.Encryption.OpenPGP.Arbitrary + , Tests.Common + , Tests.Encryption + , Tests.Keys + , Tests.MessageAndArmor + , Tests.Properties + , Tests.Serialization + , Tests.Utilities Ghc-options: -Wall -with-rtsopts=-K1K Build-depends: hOpenPGP , tasty @@ -281,6 +311,7 @@ , tasty-quickcheck , QuickCheck > 2.9 , quickcheck-instances + , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 Benchmark benchmark @@ -290,6 +321,7 @@ Ghc-options: -Wall Build-depends: hOpenPGP , criterion > 0.8 + , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 source-repository head @@ -299,4 +331,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v2.10.1.1 + tag: v3.0.0 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Common.hs @@ -0,0 +1,1539 @@ +-- Common.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.Common + ( addTimestampSeconds + , armorPayload + , assertFalse + , assertTrue + , collectSecretKeyInfos + , conduitDecryptWithPKESKContext + , loadArmor + , loadAndDecompressPkts + , loadSEIPDv2FixtureWithV4Secret + , loadUnencryptedRsaSigner + , loadV4EncryptedSecretKeyFixtureForProperty + , loadV6UnencryptedSecretKeyFixtureForProperty + , prependUnusableLatestPKESK + , readFixtureLazy + , readFixturePackets + , readFixturePayload + , reorderPrecedingPKESKs + , reverseIf + , runGet -- FIXME: this is confusing + , selectRecipientKeyInfo + , setKeyTimestamp + , signCertificationAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , timestampToUTCTime + , assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , encryptMessageDefault + , expectV4PKPayload + , expectV6PKPayload + , extractV4SignatureAlgorithmFields + , fp + , loadKeyring + , loadDeterministicEd25519Signer + , loadDeterministicEd25519SignerV6 + , loadDeterministicEd448Signer + , loadDeterministicEd448SignerV6 + , loadUnencryptedRsaSignerV6 + , messageIssuerSubpacketsAt + , mkTestKeyring + , setPKAlgorithm + , signBinaryMessageWithRSAAt + , signBinaryMessageWithEd25519At + , signKeyRevocationWithReasonAt + , signKeyRevocationWithReasonAndExtrasAt + , signSubkeyBindingWithRSAAt + , verifyTimelinePackets + , signCertificationRevocationWithEd25519At + , signCertificationWithEd25519At + , verificationFixtureGroup + , verifyMessageFromBytestring + , verifyMessageFromBytestringBatch + , verifyMessageFromPackets + , verifyMessageFromPacketsBatch + , certificateVerificationFixtures + , fixturePath + , messageVerificationFixtures + , readPKIPassphrase + , setKeyVersion + , signCertificationRevocationAt + , aesKeyWrapRFC3394ForTest + , assertX25519EskShape + , assertX448EskShape + , buildCurve25519LegacyKdfParamForTest + , buildECDHKDFParamForTest + , cgp + , conduitDecrypt -- FIXME: this is confusing + , conduitDecryptChecked + , conduitDecryptCheckedWithDecryptPolicy + , conduitDecryptWithCandidatesCallbackAndPolicy + , conduitDecryptWithDecryptPolicy + , deriveECDHKekForTest + , deriveX25519KekForTest + , deriveX448KekForTest + , doPkeyAndSkeyMatch + , encodeChecksum16 + , forceVersionedRecipientIdentifier + , isPrecedingESK + , mkPKESKSessionMaterialOrFail + , readFixtureStrict + , selectRecipientKeyInfoByRawRecipientId + , signDirectKeyWithRSAExtrasAt + , testEncodeOpenPGPSessionMaterial + , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testSEIPDv2ForV4KeyArmor + , testSEIPDv2TwoRecipientsArmor + , testSEIPDv2ThreeRecipientsArmor + ) +where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) + +import Codec.Encryption.OpenPGP.Arbitrary () +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) +import Codec.Encryption.OpenPGP.Compression (decompressPkt) +import Codec.Encryption.OpenPGP.Encrypt + ( PKESKSessionMaterial + , mkPKESKSessionMaterial + , encodeOpenPGPSessionMaterial + ) + +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal + ( curveFromCurve + , curveToCurveoidBS + , emptyPSC + , lastPrimaryKey + , lastUIDorUAt + , lastSubkey + ) +import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) +import Codec.Encryption.OpenPGP.Message + ( asV4PKPayload + , asV6PKPayload + , ClearPayload + , EncryptedPayload + , encryptMessage + , EncryptMessageOptions(..) + , Passphrase + , MessageError(..) + , RecoveredSessionMaterial(..) + , SessionMaterialExposure(..) + , VersionedPKPayload + ) +import Codec.Encryption.OpenPGP.SecretKey + ( decryptPrivateKey + ) +import Codec.Encryption.OpenPGP.Serialize + ( dearmorIfAsciiArmored + , parsePkts + ) +import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) +import Codec.Encryption.OpenPGP.Signatures + ( VerificationError(..) + , renderVerificationError + , renderSignError + , signCertificationWithRSA + , signCertRevocationWithRSA + , signSubkeyRevocationWithRSA + , signDataWithRSA + , signDataWithEd25519 + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + ) +import Codec.Encryption.OpenPGP.Types +import Control.Monad (unless, void) +import qualified "crypton" Crypto.Cipher.AES as AES +import qualified "crypton" Crypto.Cipher.Types as CCT +import qualified Crypto.Error as CE +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import Control.Monad.Trans.Resource (ResourceT) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.RSA as RSA +import qualified Data.ByteArray as BA +import Data.Bifunctor (bimap, first) +import Data.Binary (get) +import Data.Binary.Get + ( Get + , getLazyByteString + , getRemainingLazyByteString + , getWord16be + , getWord8 + , runGetOrFail + ) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bits (xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import qualified Data.ByteString.Base16.Lazy as B16L +import Data.Char (toUpper) +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Decrypt + ( DecryptKeyResolution(..) + , DecryptOptions(..) + , PKESKRecipientKey(..) + , DecryptOutcome(..) + ) +import qualified Data.Conduit.OpenPGP.Decrypt as DCD +import Codec.Encryption.OpenPGP.Policy + ( DecryptPolicy + , defaultDecryptPolicy + ) +import Data.Conduit.OpenPGP.Keyring + ( conduitToPublicViewTKs + , sinkPublicKeyringMap + , partitionSomeTKs + ) +import Data.Conduit.OpenPGP.Message + ( VerificationOptions(..) + , VerificationPolicy(..) + , defaultVerificationOptions + , VerificationMode(..) + , verifyMessage + , verifyMessagePackets + ) +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.List (isInfixOf) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word32, Word64) + +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +import qualified Crypto.PubKey.ECC.Types as ECCT + +-- Test assertion helpers +assertTrue :: String -> Bool -> Assertion +assertTrue msg b = assertBool msg b + +assertFalse :: String -> Bool -> Assertion +assertFalse msg b = assertBool msg (not b) + +fixturePath :: FilePath -> FilePath +fixturePath file = "tests/data/" ++ file + +readFixtureLazy :: FilePath -> IO BL.ByteString +readFixtureLazy = BL.readFile . fixturePath + +readFixtureStrict :: FilePath -> IO B.ByteString +readFixtureStrict = B.readFile . fixturePath + +readFixturePackets :: FilePath -> IO [Pkt] +readFixturePackets file = + DC.runConduitRes $ CB.sourceFile (fixturePath file) DC..| conduitGet get DC..| CL.consume + +readFixtureDecompressedPackets :: FilePath -> IO [Pkt] +readFixtureDecompressedPackets file = + DC.runConduitRes $ + CB.sourceFile (fixturePath file) DC..| conduitGet get DC..| conduitDecompress DC..| CL.consume + +loadFirstArmor :: FilePath -> IO Armor +loadFirstArmor file = do + armors <- loadArmor file + case armors of + (a:_) -> pure a + [] -> assertFailure (file ++ " armor file contained no armor blocks") >> fail "expected armor block" + +readPKIPassphrase :: IO BL.ByteString +readPKIPassphrase = readFixtureLazy "pki-password.txt" + +-- this needs a better name +runGet :: Get a -> BL.ByteString -> Either String a +runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs) + +extractV4SignatureAlgorithmFields :: + BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString) +extractV4SignatureAlgorithmFields = + runGet $ do + version <- getWord8 + if version /= 4 + then fail ("expected v4 signature payload, got version " ++ show version) + else do + _ <- getWord8 -- sig type + pka <- getWord8 + _ <- getWord8 -- hash algo + hlen <- getWord16be + _ <- getLazyByteString (fromIntegral hlen) + ulen <- getWord16be + _ <- getLazyByteString (fromIntegral ulen) + _ <- getWord16be -- left16 + algorithmFields <- getRemainingLazyByteString + pure (toFVal pka, BL.toStrict algorithmFields) + +conduitDecrypt :: + (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecrypt cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithPKESKContext :: + (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithPKESKContext pkcb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithDecryptPolicy :: + DecryptPolicy + -> (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithDecryptPolicy dp pkcb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptChecked :: + (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome +conduitDecryptChecked cb = + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptCheckedWithDecryptPolicy :: + DecryptPolicy + -> (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome +conduitDecryptCheckedWithDecryptPolicy dp pkcb cb = + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithCandidatesCallbackAndPolicy :: + DecryptPolicy + -> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback candCb + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +asPKESKUnwrapCandidatesCallback :: + (Pkt -> IO (Maybe PKESKRecipientKey)) + -> KeyIdentifier + -> PubKeyAlgorithm + -> IO [PKESKRecipientKey] +asPKESKUnwrapCandidatesCallback pkcb keyIdentifier pka = do + mk <- pkcb (pkeskProbePacket keyIdentifier pka) + pure (maybe [] (: []) mk) + +pkeskProbePacket :: KeyIdentifier -> PubKeyAlgorithm -> Pkt +pkeskProbePacket keyIdentifier pka = + case keyIdentifier of + KeyIdentifierWildcard -> + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 3 (EightOctetKeyId (BL.replicate 8 0)) pka (MPI 0 :| []))) + KeyIdentifierEightOctet rid -> + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 3 rid pka (MPI 0 :| []))) + KeyIdentifierFingerprint rid -> + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 (unFingerprint rid) pka mempty)) + +readFixturePayload :: FilePath -> IO BL.ByteString +readFixturePayload fpr = do + bs <- BL.readFile ("tests/data/" ++ fpr) + case dearmorIfAsciiArmored bs of + Left err -> assertFailure ("ASCII armor decode failed for " ++ fpr ++ ": " ++ err) >> pure mempty + Right (_, payload) -> pure payload + +testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized :: Assertion +testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume + (publicKey, privateKey) <- + case secretPackets of + (SecretKeyPkt pkp ska:_) -> + case (_pubkey pkp, ska) of + (RSAPubKey (RSA_PublicKey pub), SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _) -> + pure (pub, prv) + _ -> + assertFailure "unencrypted.seckey did not contain a parseable unencrypted RSA key pair" >> + fail "expected RSA key pair from parsed secret key packet" + _ -> + assertFailure "unencrypted.seckey did not begin with a secret key packet" >> + fail "expected secret key packet" + let plaintext = "pkcs1-v1.5 regression payload" :: B.ByteString + encrypted <- (P15.encrypt publicKey plaintext :: IO (Either RSA.Error B.ByteString)) + ciphertext <- + case encrypted of + Left err -> + assertFailure ("RSA PKCS#1 v1.5 encryption failed: " ++ show err) >> pure mempty + Right ct -> pure ct + decrypted <- (P15.decryptSafer privateKey ciphertext :: IO (Either RSA.Error B.ByteString)) + case decrypted of + Left RSA.MessageNotRecognized -> + assertFailure "parsed RSA private key decryption failed with MessageNotRecognized" + Left err -> + assertFailure ("parsed RSA private key decryption failed: " ++ show err) + Right got -> + assertEqual + "parsed RSA private key decrypts PKCS#1 v1.5 payload" + plaintext + got + +testEncodeOpenPGPSessionMaterial :: Assertion +testEncodeOpenPGPSessionMaterial = do + let keyBytes = B.pack [1 .. 32] + expected = + B.singleton (fromFVal AES256) <> keyBytes <> encodeChecksum16 keyBytes + case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of + Left err -> + assertFailure ("encodeOpenPGPSessionMaterial failed: " ++ show err) + Right encoded -> + assertEqual "OpenPGP session material encoding" expected encoded + +mkPKESKSessionMaterialOrFail :: + SymmetricAlgorithm -> SessionKey -> IO PKESKSessionMaterial +mkPKESKSessionMaterialOrFail symalgo sessionKey = + case mkPKESKSessionMaterial symalgo sessionKey of + Left err -> + assertFailure ("mkPKESKSessionMaterial failed: " ++ show err) >> + fail "mkPKESKSessionMaterial failed" + Right material -> pure material + +armorPayload :: Armor -> BL.ByteString +armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs) +armorPayload (ClearSigned _ _ inner) = armorPayload inner + +selectRecipientKeyInfo :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey +selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesRecipientIdentifier rid keyInfo + ] +selectRecipientKeyInfo _ keyInfos = listToMaybe keyInfos + +supportsPKESKAlgorithm :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool +supportsPKESKAlgorithm pka keyInfo = + case pkeskRecipientSKey keyInfo of + RSAPrivateKey {} -> pka == RSA + ECDHPrivateKey {} -> pka == ECDH || pka == X25519 + X25519PrivateKey {} -> pka == X25519 + X448PrivateKey {} -> pka == X448 + _ -> False + +matchesRecipientIdentifier :: BL.ByteString -> PKESKRecipientKey -> Bool +matchesRecipientIdentifier rid keyInfo = + case pkeskRecipientPKPayload keyInfo of + Nothing -> False + Just pkp -> + let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp)) + identifier = BL.toStrict rid + in identifier == fingerprintBytes || + identifier == B.cons 0x04 fingerprintBytes || + identifier == B.cons 0x06 fingerprintBytes + +buildECDHKDFParamForTest :: + SomePKPayload + -> PubKeyAlgorithm + -> ECCT.Curve + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString +buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA = + B.singleton (fromIntegral (B.length curveOid)) <> curveOid <> + B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> + "Anonymous Sender " <> + BL.toStrict (unFingerprint (fingerprint recipientPKP)) + where + curveOid = either (const B.empty) id (curveToCurveoidBS (curveFromCurve curve)) + +buildCurve25519LegacyKdfParamForTest :: + SomePKPayload + -> PubKeyAlgorithm + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString +buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA = + B.singleton (fromIntegral (B.length curveOid)) <> curveOid <> + B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> + "Anonymous Sender " <> + BL.toStrict (unFingerprint (fingerprint recipientPKP)) + where + curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01" + +deriveECDHKekForTest :: + HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam = + B.take (keyLengthForTest kdfSA) digest + where + digest = + case kdfHA of + SHA256 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA256) + SHA384 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA384) + SHA512 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA512) + _ -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA256) + +deriveX448KekForTest :: + B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA512 B.empty ikm + info = "OpenPGP X448" :: B.ByteString + in expand @CHA.SHA512 prk info 32 + +deriveX25519KekForTest :: + B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA256 B.empty ikm + info = "OpenPGP X25519" :: B.ByteString + in expand @CHA.SHA256 prk info 16 + +keyLengthForTest :: SymmetricAlgorithm -> Int +keyLengthForTest AES128 = 16 +keyLengthForTest AES192 = 24 +keyLengthForTest AES256 = 32 +keyLengthForTest _ = 16 + +aesKeyWrapRFC3394ForTest :: + SymmetricAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString +aesKeyWrapRFC3394ForTest sa kek plain = + case sa of + AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain + AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain + AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain + _ -> error "unsupported KEK algorithm in test" + where + initCipher keyBytes = + case CE.eitherCryptoError (CCT.cipherInit keyBytes) of + Left err -> error ("cipher init failed: " ++ show err) + Right c -> c + wrapWithCipher cipher plainBytes = + let rs = chunksOf8ForTest plainBytes + n = length rs + a0 = B.replicate 8 0xA6 + (aFinal, rFinal) = foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5] + in aFinal <> B.concat rFinal + wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n] + where + step (aCurr, rCurr) i = + let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1))) + (aMsb, rLsb) = B.splitAt 8 b + t = fromIntegral (n * j + i) :: Word64 + aNext = xorBSForTest aMsb (encodeWord64beForTest t) + in (aNext, replaceAtForTest (i - 1) rLsb rCurr) + +encodeWord64beForTest :: Word64 -> B.ByteString +encodeWord64beForTest = BL.toStrict . runPut . putWord64be + +chunksOf8ForTest :: B.ByteString -> [B.ByteString] +chunksOf8ForTest bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8ForTest t + +replaceAtForTest :: Int -> a -> [a] -> [a] +replaceAtForTest idx x xs = + let (prefix, suffix) = splitAt idx xs + in case suffix of + [] -> xs + (_:rest) -> prefix <> (x : rest) + +xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString +xorBSForTest a b = B.pack (B.zipWith xor a b) + +encodeChecksum16 :: B.ByteString -> B.ByteString +encodeChecksum16 bs = + B.pack + [fromIntegral (s `div` 256), fromIntegral (s `mod` 256)] + where + s = B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int)) 0 bs + +verifyMessageFromPackets :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromPackets keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + keyring + (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) + +verifyMessageFromPacketsBatch :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromPacketsBatch keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationBatch + } + keyring + (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) + +verifyMessageFromBytestring :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromBytestring keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + keyring + signedMessage + +verifyMessageFromBytestringBatch :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromBytestringBatch keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationBatch + } + keyring + signedMessage + +assertMessageVerification :: + (PublicKeyring -> BL.ByteString -> [Either String Verification]) + -> FilePath + -> FilePath + -> [Fingerprint] + -> Assertion +assertMessageVerification verifier keyringFile messageFile issuers = do + kr <- loadKeyring keyringFile + signedMessage <- readFixtureLazy messageFile + let verification = verifier kr signedMessage + actual = map (fmap (fingerprint . _verificationSigner)) verification + assertEqual + (keyringFile ++ " for " ++ messageFile) + (map Right issuers) + actual + +loadKeyring :: FilePath -> IO PublicKeyring +loadKeyring keyring = + DC.runConduitRes $ + CB.sourceFile (fixturePath keyring) DC..| conduitGet get DC..| conduitToPublicViewTKs DC..| + sinkPublicKeyringMap + +loadAndDecompressPkts :: FilePath -> IO [Pkt] +loadAndDecompressPkts = readFixtureDecompressedPackets + +loadArmor :: FilePath -> IO [Armor] +loadArmor file = do + armored <- readFixtureLazy file + case AA.decodeLazy armored :: Either String [Armor] of + Left err -> + assertFailure ("Failed to decode armored fixture " ++ file ++ ": " ++ err) >> pure [] + Right armors -> pure armors + +encryptMessageDefault :: + SessionMaterialExposure + -> Passphrase + -> ClearPayload + -> Either + MessageError + (EncryptedPayload, Maybe RecoveredSessionMaterial) +encryptMessageDefault exposure passphrase payload = + encryptMessage + (RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = exposure + , rfc9580EncryptMessageSymmetricAlgorithm = AES256 + , rfc9580EncryptMessageS2K = Argon2 (Salt16 (B.pack [0x80 .. 0x8f])) 1 4 15 + , rfc9580EncryptMessageIV = IV "0123456789ABCDEF" + }) + passphrase + payload + +mkTestKeyring :: [TKUnknown] -> PublicKeyring +mkTestKeyring tks = + let someTKs = [stk | Right stk <- map fromUnknownToTK tks] + in fst (partitionSomeTKs someTKs) + +addTimestampSeconds :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp +addTimestampSeconds (ThirtyTwoBitTimeStamp ts) seconds = ThirtyTwoBitTimeStamp (ts + seconds) + +timestampToUTCTime :: ThirtyTwoBitTimeStamp -> UTCTime +timestampToUTCTime = posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp + +signCertificationAt :: + SomePKPayload + -> RSA.PrivateKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationAt signer signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signCertificationWithRSA + GenericCert + signer + uid + (hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure ("failed to sign certification: " ++ renderSignError err) >> + fail "expected certification signature" + Right sigPayload -> pure sigPayload + +signCertificationRevocationAt :: + SomePKPayload + -> RSA.PrivateKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signCertRevocationWithRSA + signer + uid + (hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure ("failed to sign certification revocation: " ++ renderSignError err) >> + fail "expected certification revocation signature" + Right sigPayload -> pure sigPayload + +messageIssuerSubpacketsAt :: + SomePKPayload + -> ThirtyTwoBitTimeStamp + -> IO ([SigSubPacket], [SigSubPacket]) +messageIssuerSubpacketsAt signer creationTime = + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id for timeline test: " ++ err) >> + fail "expected issuer key id" + Right issuerKeyId -> + pure + ( [ SigSubPacket False (SigCreationTime creationTime) + , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) + ] + , [SigSubPacket False (Issuer issuerKeyId)] + ) + +loadUnencryptedRsaSigner :: IO (SomePKPayload, RSA.PrivateKey) +loadUnencryptedRsaSigner = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume + case secretPackets of + (SecretKeyPkt pkp ska:_) -> + case ska of + SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ -> + pure (pkp, privateKey) + _ -> + assertFailure "unencrypted.seckey did not contain an unencrypted RSA key" >> + fail "expected decrypted RSA private key" + _ -> + assertFailure "unencrypted.seckey did not begin with a secret key packet" >> + fail "expected secret key packet" + +loadUnencryptedRsaSignerV6 :: IO (SomePKPayload, RSA.PrivateKey) +loadUnencryptedRsaSignerV6 = do + (signer, signingKey) <- loadUnencryptedRsaSigner + pure (setKeyVersion V6 signer, signingKey) + +setKeyVersion :: KeyVersion -> SomePKPayload -> SomePKPayload +setKeyVersion keyVersion (PKPayload _ ts v3e pka pubkey) = + PKPayload keyVersion ts v3e pka pubkey + +setKeyTimestamp :: ThirtyTwoBitTimeStamp -> SomePKPayload -> SomePKPayload +setKeyTimestamp ts (PKPayload keyVersion _ v3e pka pubkey) = + PKPayload keyVersion ts v3e pka pubkey + +setPKAlgorithm :: PubKeyAlgorithm -> SomePKPayload -> SomePKPayload +setPKAlgorithm algorithm (PKPayload keyVersion ts v3e _ pubkey) = + PKPayload keyVersion ts v3e algorithm pubkey + +expectV4PKPayload :: String -> SomePKPayload -> IO (VersionedPKPayload V4) +expectV4PKPayload label pk = + case asV4PKPayload pk of + Left err -> + assertFailure (label ++ " should have a v4 PKPayload: " ++ err) >> + fail "expected v4 PKPayload" + Right v4pk -> pure v4pk + +expectV6PKPayload :: String -> SomePKPayload -> IO (VersionedPKPayload V6) +expectV6PKPayload label pk = + case asV6PKPayload pk of + Left err -> + assertFailure (label ++ " should have a v6 PKPayload: " ++ err) >> + fail "expected v6 PKPayload" + Right v6pk -> pure v6pk + +loadDeterministicEd25519Signer :: IO (SomePKPayload, Ed25519.SecretKey) +loadDeterministicEd25519Signer = do + let seed = B.pack [1 .. 32] + secretKey <- + case CE.eitherCryptoError (Ed25519.secretKey seed) of + Left err -> + assertFailure ("failed to initialize deterministic Ed25519 secret key: " ++ show err) >> + fail "expected deterministic Ed25519 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V4 + 0 + 0 + EdDSA + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 publicKeyBytes))))) + pure (signer, secretKey) + +loadDeterministicEd25519SignerV6 :: IO (SomePKPayload, Ed25519.SecretKey) +loadDeterministicEd25519SignerV6 = do + let seed = B.pack [1 .. 32] + secretKey <- + case CE.eitherCryptoError (Ed25519.secretKey seed) of + Left err -> + assertFailure ("failed to initialize deterministic Ed25519 secret key: " ++ show err) >> + fail "expected deterministic Ed25519 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V6 + 0 + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicKeyBytes)))) + pure (signer, secretKey) + +loadDeterministicEd448Signer :: IO (SomePKPayload, Ed448.SecretKey) +loadDeterministicEd448Signer = do + let seed = B.pack [1 .. 57] + secretKey <- + case CE.eitherCryptoError (Ed448.secretKey seed) of + Left err -> + assertFailure ("failed to initialize deterministic Ed448 secret key: " ++ show err) >> + fail "expected deterministic Ed448 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V4 + 0 + 0 + EdDSA + (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 publicKeyBytes))))) + pure (signer, secretKey) + +loadDeterministicEd448SignerV6 :: IO (SomePKPayload, Ed448.SecretKey) +loadDeterministicEd448SignerV6 = do + let seed = B.pack [1 .. 57] + secretKey <- + case CE.eitherCryptoError (Ed448.secretKey seed) of + Left err -> + assertFailure ("failed to initialize deterministic Ed448 secret key: " ++ show err) >> + fail "expected deterministic Ed448 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V6 + 0 + 0 + EdDSA + (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip publicKeyBytes)))) + pure (signer, secretKey) + +testSEIPDv2ForV4KeyArmor :: Assertion +testSEIPDv2ForV4KeyArmor = do + armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure "seipdv2-for-v4-key fixture should contain one armored payload" >> + fail "expected one armored payload" + payload <- + case armor of + Armor ArmorMessage _ p -> pure p + Armor atype _ _ -> + assertFailure + ("seipdv2-for-v4-key fixture should decode as a message block, got " ++ + show atype) >> + fail "expected message block" + _ -> + assertFailure "seipdv2-for-v4-key fixture should decode as an armored payload" >> + fail "expected armored payload" + let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) + case packets of + [PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)), SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _)] -> do + let ridHex = map toUpper (BLC8.unpack (B16L.encode rid)) + if ridHex `elem` ["C8263FC6D676044B6E973959C2F2C2CAE30DE908", "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"] + then pure () + else + assertFailure + ("seipdv2-for-v4-key fixture should target the expected recipient fingerprint, got " ++ + ridHex) + assertEqual + "seipdv2-for-v4-key fixture should use ECDH PKESKv6" + ECDH + pka + assertEqual + "seipdv2-for-v4-key fixture should use AES-256" + AES256 + sa + assertEqual + "seipdv2-for-v4-key fixture should use OCB" + OCB + aa + assertEqual + "seipdv2-for-v4-key fixture should use 4KiB chunks" + 6 + chunkSize + _ -> + assertFailure + ("seipdv2-for-v4-key fixture should contain [PKESKPkt (PKESK6 ...), SymEncIntegrityProtectedDataPkt (SEIPD2 ...)], got: " ++ + show packets) + +loadSEIPDv2FixtureWithV4Secret :: FilePath -> IO ([Pkt], [Pkt], BL.ByteString) +loadSEIPDv2FixtureWithV4Secret fixture = do + messageArmor <- loadFirstArmor fixture + encryptedSecretArmor <- loadFirstArmor "v4-encrypted-secret.pgp.aa" + passphrase <- readPKIPassphrase + pure + ( parsePkts (armorPayload messageArmor) + , parsePkts (armorPayload encryptedSecretArmor) + , passphrase + ) + +forceVersionedRecipientIdentifier :: Pkt -> Pkt +forceVersionedRecipientIdentifier pkt = + case pkt of + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk)) + | BL.length rid == 20 -> + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk)) + | BL.length rid == 32 -> + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk)) + | otherwise -> pkt + _ -> pkt + +selectRecipientKeyInfoByRawRecipientId :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey +selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesRawRecipientFingerprint rid keyInfo + ] +selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos + +matchesRawRecipientFingerprint :: BL.ByteString -> PKESKRecipientKey -> Bool +matchesRawRecipientFingerprint rid keyInfo = + case pkeskRecipientPKPayload keyInfo of + Nothing -> False + Just pkp -> + BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp)) + +testSEIPDv2TwoRecipientsArmor :: Assertion +testSEIPDv2TwoRecipientsArmor = + testSEIPDv2RecipientFixtureArmor "seipdv2-two-recipients.pgp.aa" 2 + +testSEIPDv2ThreeRecipientsArmor :: Assertion +testSEIPDv2ThreeRecipientsArmor = + testSEIPDv2RecipientFixtureArmor "seipdv2-three-recipients.pgp.aa" 3 + +testSEIPDv2RecipientFixtureArmor :: FilePath -> Int -> Assertion +testSEIPDv2RecipientFixtureArmor file expectedRecipients = do + armors <- loadArmor file + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure (file ++ " fixture should contain one armored payload") >> + fail "expected one armored payload" + payload <- + case armor of + Armor ArmorMessage _ p -> pure p + Armor atype _ _ -> + assertFailure + (file ++ " fixture should decode as a message block, got " ++ show atype) >> + fail "expected message block" + _ -> + assertFailure (file ++ " fixture should decode as an armored payload") >> + fail "expected armored payload" + let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) + pkesks = [(rid, pka) | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <- packets] + x25519Esks = [BL.toStrict esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <- packets] + x448Esks = [BL.toStrict esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <- packets] + seipdv2Packets = + [(sa, aa, chunkSize) | SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) <- packets] + assertEqual + (file ++ " fixture should contain expected number of PKESKv6 packets") + expectedRecipients + (length pkesks) + if all (\(_, pka) -> pka == ECDH || pka == X25519) pkesks + then pure () + else + assertFailure + (file ++ " fixture should use only ECDH/X25519 PKESKv6 packets, got " ++ + show (map snd pkesks)) + if any ((== ECDH) . snd) pkesks + then pure () + else + assertFailure (file ++ " fixture should include an ECDH recipient for the v4 key") + mapM_ (assertX25519EskShape file) x25519Esks + mapM_ (assertX448EskShape file) x448Esks + if all + (\(rid, _) -> + let l = BL.length rid + in l == 20 || l == 21 || l == 32 || l == 33) + pkesks + then pure () + else + assertFailure + (file ++ " fixture should use 20/21-byte or 32/33-byte recipient identifiers") + case seipdv2Packets of + [(sa, aa, chunkSize)] -> do + assertEqual (file ++ " fixture should use AES-256") AES256 sa + assertEqual (file ++ " fixture should use OCB") OCB aa + assertEqual (file ++ " fixture should use 4KiB chunks") 6 chunkSize + _ -> + assertFailure + (file ++ " fixture should contain one SymEncIntegrityProtectedDataV2 packet") + +assertX25519EskShape :: FilePath -> B.ByteString -> Assertion +assertX25519EskShape file x25519Esk + | B.length x25519Esk < 33 = + assertFailure + (file ++ " X25519 PKESKv6 ESK should contain 32-octet ephemeral and wrapped-len") + | otherwise = do + let wrappedLen = fromIntegral (B.index x25519Esk 32) :: Int + wrapped = B.drop 33 x25519Esk + assertEqual + (file ++ " X25519 PKESKv6 wrapped length octet") + wrappedLen + (B.length wrapped) + +assertX448EskShape :: FilePath -> B.ByteString -> Assertion +assertX448EskShape file x448Esk + | B.length x448Esk < 57 = + assertFailure + (file ++ " X448 PKESKv6 ESK should contain 56-octet ephemeral and wrapped-len") + | otherwise = do + let wrappedLen = fromIntegral (B.index x448Esk 56) :: Int + wrapped = B.drop 57 x448Esk + assertEqual + (file ++ " X448 PKESKv6 wrapped length octet") + wrappedLen + (B.length wrapped) + +prependUnusableLatestPKESK :: [Pkt] -> [Pkt] +prependUnusableLatestPKESK packets = + let bogusRid = BL.pack (0x06 : replicate 32 0x99) + bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) + (eskPrefix, encryptedSuffix) = span isPrecedingESK packets + in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix + +reorderPrecedingPKESKs :: [Pkt] -> [Pkt] +reorderPrecedingPKESKs packets = + let (eskPrefix, encryptedSuffix) = span isPrecedingESK packets + reorderedPKESKs = reverse [pkt | pkt@(PKESKPkt _) <- eskPrefix] + in refillPKESKSlots eskPrefix reorderedPKESKs ++ encryptedSuffix + where + refillPKESKSlots [] _ = [] + refillPKESKSlots (pkt:rest) pkesks = + case pkt of + PKESKPkt {} -> + case pkesks of + [] -> pkt : refillPKESKSlots rest [] + (replacement:remaining) -> + replacement : refillPKESKSlots rest remaining + _ -> pkt : refillPKESKSlots rest pkesks + +isPrecedingESK :: Pkt -> Bool +isPrecedingESK (PKESKPkt _) = True +isPrecedingESK (SKESKPkt _) = True +isPrecedingESK _ = False + +messageVerificationFixtures :: [(String, FilePath, FilePath, [Fingerprint])] +messageVerificationFixtures = + [ ( "uncompressed-ops-dsa" + , "pubring.gpg" + , "uncompressed-ops-dsa.gpg" + , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) + , ( "uncompressed-ops-dsa-sha384" + , "pubring.gpg" + , "uncompressed-ops-dsa-sha384.txt.gpg" + , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) + , ( "uncompressed-ops-rsa" + , "pubring.gpg" + , "uncompressed-ops-rsa.gpg" + , [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"]) + , ( "compressedsig" + , "pubring.gpg" + , "compressedsig.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "compressedsig-zlib" + , "pubring.gpg" + , "compressedsig-zlib.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "compressedsig-bzip2" + , "pubring.gpg" + , "compressedsig-bzip2.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + ] + +certificateVerificationFixtures :: [(String, FilePath, FilePath, [Fingerprint])] +certificateVerificationFixtures = + [ ( "userid" + , "pubring.gpg" + , "minimized.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "subkey" + , "pubring.gpg" + , "subkey.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "primary key binding" + , "signing-subkey.gpg" + , "primary-binding.gpg" + , [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"]) + , ( "attribute" + , "pubring.gpg" + , "uat.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "primary key revocation" + , "pubring.gpg" + , "prikey-rev.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "subkey revocation" + , "pubring.gpg" + , "subkey-rev.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "6F87040E" + , "pubring.gpg" + , "6F87040E.pubkey" + , [ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" + , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + ]) + , ( "6F87040E-cr" + , "pubring.gpg" + , "6F87040E-cr.pubkey" + , [ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + , fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" + , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + ]) + , ( "simple RSA secret key" + , "pubring.gpg" + , "simple.seckey" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) + , ( "simple ECDSA public key" + , "ecdsa-key-without-ecdh.pubkey" + , "ecdsa-key-without-ecdh.pubkey" + , [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"]) + ] + +verificationFixtureGroup :: + String + -> (PublicKeyring -> BL.ByteString -> [Either String Verification]) + -> [(String, FilePath, FilePath, [Fingerprint])] + -> TestTree +verificationFixtureGroup groupName verifier fixtures = + testGroup + groupName + [ testCase name (assertMessageVerification verifier keyringFile messageFile issuers) + | (name, keyringFile, messageFile, issuers) <- fixtures + ] + +loadV6UnencryptedSecretKeyFixtureForProperty :: IO (Either String (SomePKPayload, SKAddendum, SKey)) +loadV6UnencryptedSecretKeyFixtureForProperty = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + pure $ do + armors <- first ("failed to decode v6 secret fixture: " ++) (AA.decodeLazy armored) + armor <- + case armors of + (a:_) -> Right a + [] -> Left "v6-secret.pgp.aa should contain one armored payload" + let packets = parsePkts (armorPayload armor) + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum:_) -> Right (pkpayload, skaddendum) + _ -> Left "v6-secret.pgp.aa should begin with a secret key packet" + skey <- + case ska of + SUUnencrypted x _ -> Right x + _ -> Left "v6-secret.pgp.aa should contain unencrypted secret key material" + Right (pkp, ska, skey) + +loadV4EncryptedSecretKeyFixtureForProperty :: + IO (Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString)) +loadV4EncryptedSecretKeyFixtureForProperty = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| + CL.consume + pure $ do + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum:_) -> Right (pkpayload, skaddendum) + _ -> Left "aes256-sha512.seckey should begin with a secret key packet" + skey <- + case decryptPrivateKey (pkp, ska) passphrase of + Right (SUUnencrypted x _) -> Right x + Right other -> + Left ("unexpected decrypted key shape for v4 fixture: " ++ show other) + Left err -> + Left ("failed to decrypt v4 fixture secret key: " ++ err) + Right (pkp, ska, skey, passphrase) + +reverseIf :: Bool -> [a] -> [a] +reverseIf shouldReverse xs + | shouldReverse = reverse xs + | otherwise = xs + +cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) () +cgp = conduitGet (get :: Get Pkt) + +fp :: Text -> Fingerprint +fp = either error id . parseFingerprint + +doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion +doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = + assertEqual + "RSA private key matches RSA public key" + rpub + (RSA.private_pub rpriv) +doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) = + assertEqual + "ECDSA private key curve matches ECDSA public key curve" + (ECDSA.public_curve ecpub) + (ECDSA.private_curve ecpriv) +doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" + +collectSecretKeyInfos :: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey] +collectSecretKeyInfos pkts passphrase = do + let keyInfoResults = map toKeyInfo pkts + keyInfos = catMaybes [mKeyInfo | Right mKeyInfo <- keyInfoResults] + unlockErrors = [err | Left err <- keyInfoResults] + unless (null unlockErrors) $ + assertFailure + ("one or more secret key packets failed to unlock (partial failures are surfaced to\ + \ prevent silent key-context gaps):\n" ++ + unlines unlockErrors) + pure keyInfos + where + toKeyInfo (SecretKeyPkt pkp ska) = decryptToRecipientKey "SecretKeyPkt" pkp ska + toKeyInfo (SecretSubkeyPkt pkp ska) = decryptToRecipientKey "SecretSubkeyPkt" pkp ska + toKeyInfo _ = Right Nothing + + decryptToRecipientKey contextLabel pkp ska = + case ska of + SUUnencrypted skey _ -> + Right + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = skey + })) + _ -> + case decryptPrivateKey (pkp, ska) passphrase of + Right (SUUnencrypted skey _) -> + Right + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = skey + })) + Right decryptedSKA -> + Left + (contextLabel ++ + " " ++ + show (fingerprint pkp) ++ + ": decryptPrivateKey returned unexpected protection: " ++ + show decryptedSKA) + Left err -> + Left + (contextLabel ++ + " " ++ + show (fingerprint pkp) ++ + ": decryptPrivateKey failed: " ++ err) + +signSubkeyRevocationWithRSAAt :: + SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> IO SignaturePayload +signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signSubkeyRevocationWithRSA signer subkey hashed unhashed signingKey of + Left err -> + assertFailure ("failed to sign subkey revocation: " ++ renderSignError err) >> + fail "expected subkey revocation signature" + Right sigPayload -> pure sigPayload + +signSubkeyBindingWithRSAAt :: + SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> IO SignaturePayload +signSubkeyBindingWithRSAAt signer subkey signingKey creationTime = do + signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime [] + +signDirectKeyWithRSAExtrasAt :: + SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signDirectKeyWithRSA SignatureDirectlyOnAKey signer (hashedExtras ++ hashed) unhashed signingKey of + Left err -> + assertFailure ("failed to sign direct key self-signature: " ++ renderSignError err) >> + fail "expected direct key self-signature" + Right sigPayload -> pure sigPayload + +signSubkeyBindingWithRSAExtrasAt :: + SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + let bindingPayload = + payloadForSig + SubkeyBindingSig + emptyPSC + { lastPrimaryKey = PublicKeyPkt signer + , lastSubkey = PublicSubkeyPkt subkey + } + case signDataWithRSA SubkeyBindingSig signingKey (hashedExtras ++ hashed) unhashed bindingPayload of + Left err -> + assertFailure ("failed to sign subkey binding: " ++ renderSignError err) >> + fail "expected subkey binding signature" + Right sigPayload -> pure sigPayload + +verifyTimelinePackets :: PublicKeyring -> BL.ByteString -> SignaturePayload -> [Either VerificationError Verification] +verifyTimelinePackets keyring payload sigPayload = + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationBatch + } + keyring + [LiteralDataPkt BinaryData BL.empty 0 payload, SignaturePkt sigPayload] + +assertSingleSignerFingerprint :: + String + -> Fingerprint + -> [Either VerificationError Verification] + -> Assertion +assertSingleSignerFingerprint label expected results = + case results of + [Right verification] -> + assertEqual label expected (fingerprint (_verificationSigner verification)) + other -> + assertFailure + (label ++ + ", expected one successful verification result, got " ++ + show (length other) ++ + " result(s)") + +assertSingleFailureContainsTimeline :: + String + -> String + -> [Either VerificationError Verification] + -> Assertion +assertSingleFailureContainsTimeline label needle results = + case results of + [Left err] -> + assertBool + label + (needle `isInfixOf` renderVerificationError err) + other -> + assertFailure + (label ++ + ", expected one verification failure result, got " ++ + show (length other) ++ + " result(s)") + +signCertificationWithEd25519At :: + SomePKPayload + -> SomePKPayload + -> Ed25519.SecretKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt certifierSigner creationTime + let state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt certifiedSigner + , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) + } + case signDataWithEd25519 + GenericCert + signingKey + (hashedExtras ++ hashed) + unhashed + (payloadForSig GenericCert state) of + Left err -> + assertFailure ("failed to sign Ed25519 certification: " ++ renderSignError err) >> + fail "expected Ed25519 certification signature" + Right sigPayload -> pure sigPayload + +signCertificationRevocationWithEd25519At :: + SomePKPayload + -> SomePKPayload + -> Ed25519.SecretKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationRevocationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt certifierSigner creationTime + let state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt certifiedSigner + , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) + } + case signDataWithEd25519 + CertRevocationSig + signingKey + (hashedExtras ++ hashed) + unhashed + (payloadForSig CertRevocationSig state) of + Left err -> + assertFailure ("failed to sign Ed25519 certification revocation: " ++ renderSignError err) >> + fail "expected Ed25519 certification revocation signature" + Right sigPayload -> pure sigPayload + +signKeyRevocationWithReasonAt :: + SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> RevocationCode + -> IO SignaturePayload +signKeyRevocationWithReasonAt signer signingKey creationTime reasonCode = + signKeyRevocationWithReasonAndExtrasAt + signer + signingKey + creationTime + reasonCode + [] + +signKeyRevocationWithReasonAndExtrasAt :: + SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> RevocationCode + -> [SigSubPacket] + -> IO SignaturePayload +signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signKeyRevocationWithRSA + signer + (SigSubPacket False (ReasonForRevocation reasonCode "") : hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure ("failed to sign key revocation: " ++ renderSignError err) >> + fail "expected key revocation signature" + Right sigPayload -> pure sigPayload + +signBinaryMessageWithRSAAt :: + SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> BL.ByteString + -> IO SignaturePayload +signBinaryMessageWithRSAAt signer signingKey creationTime payload = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signDataWithRSA BinarySig signingKey hashed unhashed payload of + Left err -> + assertFailure ("failed to sign RSA message payload: " ++ renderSignError err) >> + fail "expected RSA message signature" + Right sigPayload -> pure sigPayload + +signBinaryMessageWithEd25519At :: + SomePKPayload + -> Ed25519.SecretKey + -> ThirtyTwoBitTimeStamp + -> BL.ByteString + -> IO SignaturePayload +signBinaryMessageWithEd25519At signer signingKey creationTime payload = do + (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime + case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of + Left err -> + assertFailure ("failed to sign Ed25519 message payload: " ++ renderSignError err) >> + fail "expected Ed25519 message signature" + Right sigPayload -> pure sigPayload + + diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Encryption.hs @@ -0,0 +1,4918 @@ +-- Encryption.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Encryption (encryptionAndCompressionTests) where + +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..)) +import Codec.Encryption.OpenPGP.BlockCipher (keySize, withSymmetricCipher) +import Codec.Encryption.OpenPGP.CFB +import Codec.Encryption.OpenPGP.Compression (CompressionError(..), compressPkts, decompressPkt) +import Codec.Encryption.OpenPGP.Encrypt + ( PKESKEncryptError(InvalidRecipientIdentifier, InvalidRecipientKeyMaterial, PayloadBuildFailure, RecipientCapabilitySelectionFailure, RecipientKdfFailure, UnsupportedRecipientAlgorithm) + , RecipientCapabilityError(RecipientCapabilityMissingSEIPDv1Support, RecipientCapabilityNoCommonAEADAlgorithms, RecipientCapabilityNoCommonSymmetricAlgorithms, RecipientCapabilityNoEncryptableKeyMaterialInTK) + , RecipientCapabilityNegotiationMode(..) + , EncryptCompatibilityProfile(..) + , RecipientCapabilities(..) + , RecipientEncryptionTargetRejected(..) + , RecipientEncryptionTargetsReport(..) + , RecipientTargetRejectionReason(..) + , RecipientPKESKVersionStrategy(..) + , RecipientEncryptionTarget(..) + , RecipientPayloadShape(..) + , RecipientEncryptRequest(..) + , RecipientEncryptRequestOverrides(..) + , defaultRecipientPayloadShape + , RecipientEncryptResult(..) + , PKESKVersionPolicy(..) + , pkeskSessionAlgorithm + , pkeskV3SessionMaterial + , buildPKESKv3PayloadForRecipient + , buildPKESKPayloadForRecipient + , canonicalizePKESKRecipientId + , encryptSEIPDv2Payload + , encryptForRecipients + , encryptForRecipientsLegacy + , encryptForRecipientsWithCapabilityNegotiation + , recipientCapabilitiesFromSubpacketPayloads + , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetsFromTKAtTimestamp + , recipientEncryptionTargetsReportFromTKAtTimestamp + , recipientEncryptionTargetFromTK + , recipientEncryptionTargetsFromTK + , recipientEncryptionTarget + , recipientEncryptionTargetWithCapabilities + , recipientEncryptionTargetWithStrategy + , recipientVersionStrategyForProfile + ) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) +import Codec.Encryption.OpenPGP.Internal (point2MBS) +import Codec.Encryption.OpenPGP.Message + ( SessionMaterialExposure(..) + , encryptedPayloadBytes + , mkClearPayload + , mkPassphrase + ) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPPolicy(..) + , OpenPGPRFC(..) + , defaultDecryptPolicy + , defaultPolicy + , lenientDecryptPolicy + , policyForRFC + ) +import Codec.Encryption.OpenPGP.S2K + ( EncodedSessionKeyError(..) + , S2KError(..) + , decodeOpenPGPEncodedSessionKey + , renderS2KError + , skesk2SessionKey + , string2Key + ) +import Codec.Encryption.OpenPGP.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.SecretKey + ( decryptPrivateKey + , encryptPrivateKeyWithPolicyAndSaltAndIV + ) +import Codec.Encryption.OpenPGP.Types +import Control.Exception.Base (SomeException, catch, try) +import Control.Monad (void) +import Control.Monad.Trans.Resource (ResourceT) +import qualified Crypto.Error as CE +import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Generate as ECCGen +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import qualified Crypto.PubKey.RSA as RSA +import Data.Binary.Get + ( Get + ) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import qualified Data.ByteString.Base16.Lazy as B16L +import Data.Char (toUpper) +import qualified Data.Conduit as DC +import Data.Conduit (fuseBoth) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.OpenPGP.Compression (conduitCompress) +import Data.Conduit.OpenPGP.Decrypt + ( DecryptKeyResolution(..) + , DecryptOptions(..) + , DecryptOutcome(..) + , PKESKRecipientKey(..) + ) +import qualified Data.Conduit.OpenPGP.Decrypt as DCD +import Data.Conduit.OpenPGP.Keyring + ( conduitToTKsDropping + , conduitToTKsDroppingEither + , conduitToTKsEither + , conduitToUnknownTKs + ) +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.Binary (get, put) +import Data.Binary.Put (putWord16be, runPut) +import Data.Word (Word16) +import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Tests.Common + ( aesKeyWrapRFC3394ForTest + , armorPayload + , assertX25519EskShape + , assertX448EskShape + , buildCurve25519LegacyKdfParamForTest + , buildECDHKDFParamForTest + , cgp + , collectSecretKeyInfos + , conduitDecrypt + , conduitDecryptChecked + , conduitDecryptCheckedWithDecryptPolicy + , conduitDecryptWithCandidatesCallbackAndPolicy + , conduitDecryptWithDecryptPolicy + , conduitDecryptWithPKESKContext + , deriveECDHKekForTest + , deriveX25519KekForTest + , deriveX448KekForTest + , doPkeyAndSkeyMatch + , encodeChecksum16 + , encryptMessageDefault + , fixturePath + , forceVersionedRecipientIdentifier + , isPrecedingESK + , loadArmor + , loadDeterministicEd25519Signer + , loadSEIPDv2FixtureWithV4Secret + , loadUnencryptedRsaSigner + , mkPKESKSessionMaterialOrFail + , prependUnusableLatestPKESK + , readFixtureLazy + , readFixtureStrict + , readFixturePackets + , readPKIPassphrase + , reorderPrecedingPKESKs + , runGet + , selectRecipientKeyInfo + , selectRecipientKeyInfoByRawRecipientId + , setKeyTimestamp + , setKeyVersion + , signDirectKeyWithRSAExtrasAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , testEncodeOpenPGPSessionMaterial + , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testSEIPDv2ForV4KeyArmor + , testSEIPDv2TwoRecipientsArmor + , testSEIPDv2ThreeRecipientsArmor + ) + +mkLegacySymmetricCase :: (String, Bool, FilePath, FilePath, BL.ByteString) -> TestTree +mkLegacySymmetricCase (label, expectSEIPDv1, encFile, passFile, cleartext) = + testCase label (testLegacySymmetricEncryption expectSEIPDv1 encFile passFile cleartext) + +legacySymmetricCases :: [(String, Bool, FilePath, FilePath, BL.ByteString)] +legacySymmetricCases = + [ ("Symmetric Encryption simple S2K SHA1 3DES, no MDC", False, "encryption-sym-3des-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC", False, "encryption-sym-3des.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 3DES", True, "encryption-sym-3des-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 3DES", True, "encryption-sym-3des-mdc.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 CAST5, no MDC", False, "encryption-sym-cast5-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC", False, "encryption-sym-cast5.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 CAST5", True, "encryption-sym-cast5-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 CAST5", True, "encryption-sym-cast5-mdc.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 Blowfish, no MDC", False, "encryption-sym-blowfish-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC", False, "encryption-sym-blowfish.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 Blowfish", True, "encryption-sym-blowfish-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 Blowfish", True, "encryption-sym-blowfish-mdc.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 AES128", True, "encryption-sym-aes128-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 AES128", True, "encryption-sym-aes128.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 AES192", True, "encryption-sym-aes192-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 AES192", True, "encryption-sym-aes192.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 AES256", True, "encryption-sym-aes256-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 AES256", True, "encryption-sym-aes256.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA256 AES256", True, "encryption-sym-aes256-sha256.pgp", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple S2K SHA1 Twofish", True, "encryption-sym-twofish-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted S2K SHA1 Twofish", True, "encryption-sym-twofish.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption simple Camellia128", True, "encryption-sym-camellia128-s2k0.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted Camellia128", True, "encryption-sym-camellia128.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted Camellia192", True, "encryption-sym-camellia192.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption iterated-salted Camellia256", True, "encryption-sym-camellia256.gpg", "symmetric-password.txt", "test\n") + , ("Symmetric Encryption pgcrypto", True, "encryption-sym-pgcrypto.pgp", "pgcrypto-passphrase.txt", "{\"t\":\"plus\"}") + ] + +mkStrictSymmetricCase :: (String, FilePath, FilePath, BL.ByteString) -> TestTree +mkStrictSymmetricCase (label, encFile, passFile, cleartext) = + testCase label (testSymmetricEncryption encFile passFile cleartext) + +strictSymmetricCases :: [(String, FilePath, FilePath, BL.ByteString)] +strictSymmetricCases = + [ ("strict policy AES128 iterated-salted S2K SEIPDv1", "encryption-sym-aes128.gpg", "symmetric-password.txt", "test\n") + , ("strict policy AES192 iterated-salted S2K SEIPDv1", "encryption-sym-aes192.gpg", "symmetric-password.txt", "test\n") + , ("strict policy AES256 iterated-salted S2K SEIPDv1", "encryption-sym-aes256.gpg", "symmetric-password.txt", "test\n") + ] + +encryptionAndCompressionTests :: TestTree +encryptionAndCompressionTests = + testGroup + "Encryption and compression" + [ testGroup + "Compression group" + [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg") + , testCase + "compressedsig-zlib.gpg" + (testCompression "compressedsig-zlib.gpg") + , testCase + "compressedsig-bzip2.gpg" + (testCompression "compressedsig-bzip2.gpg") + , testCase + "decompressPkt classifies empty ZIP payload" + (assertEqual "empty ZIP" + (Left (EmptyCompressedPayload ZIP)) + (decompressPkt (CompressedDataPkt ZIP ""))) + , testCase + "decompressPkt classifies empty Uncompressed payload" + (assertEqual "empty Uncompressed" + (Left (EmptyCompressedPayload Uncompressed)) + (decompressPkt (CompressedDataPkt Uncompressed ""))) + , testCase + "decompressPkt classifies marker-only ZIP payload" + (let markerPkt = MarkerPkt "\x50\x47\x50" + compressed = compressPkts ZIP [markerPkt] + in assertEqual "marker-only" + (Left (MarkerOnlyPayload ZIP)) + (decompressPkt compressed)) + , testCase + "decompressPkt passes through non-compressed packets" + (let pkt = OtherPacketPkt 255 "" + in assertEqual "passthrough" + (Right [pkt]) + (decompressPkt pkt)) + ] + , testGroup + "Conduit length group" + [ testCase + "conduitCompress (ZIP)" + (testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress ZIP) + 1) + , testCase + "conduitCompress (Zlib)" + (testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress ZLIB) + 1) + , testCase + "conduitCompress (BZip2)" + (testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress BZip2) + 1) + , testCase + "conduitToUnknownTKs" + (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToUnknownTKs) 4) + , testCase + "conduitToTKsDropping" + (testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitToTKsDropping) + 4) + , testCase + "conduitToTKsEither reports parse failures" + testConduitToTKsEitherReportsParseFailure + , testCase + "conduitToTKsDroppingEither reports parse failures" + testConduitToTKsDroppingEitherReportsParseFailure + ] + , testGroup + "Encrypted data" + ( [ testCase + "Legacy symmetric encryption fixture shape" + testLegacyEncryptionFixtureShape + , testCase + "SEIPDv1 resync nonce/MDC roundtrip" + testSEIPDv1ResyncNonceMdcRoundTrip + ] + ++ map mkLegacySymmetricCase legacySymmetricCases + ++ map mkStrictSymmetricCase strictSymmetricCases + ++ [ + testCase + "strict policy rejects SED (no MDC)" + (testStrictPolicyRejectsEncryption + "encryption-sym-cast5.gpg" + "symmetric-password.txt" + "unauthenticated SED") + , testCase + "strict policy rejects Simple S2K" + (testStrictPolicyRejectsEncryption + "encryption-sym-aes128-s2k0.gpg" + "symmetric-password.txt" + "Simple S2K specifier") + , testCase + "strict policy rejects non-encrypted packet after ESK prelude" + testRejectsNonEncryptedAfterESKPrelude + , testCase + "strict policy rejects SEIPDv2 with only misaligned ESK versions" + testRejectsMisalignedESKVersionForSEIPDv2 + , testCase + "strict policy discards misaligned ESK when aligned ESK is present" + testDiscardsMisalignedESKWhenAlignedCandidateExists + , testCase + "strict policy rejects trailing data after SEIPD v2" + testTrailingDataRejectedStrictSEIPDv2 + , testCase + "lenient policy reports DecryptTrailingData for trailing packet after SEIPD v2" + testTrailingDataReportedLenientSEIPDv2 + , testCase + "conduitDecryptChecked reports DecryptClean for well-formed SEIPD v2" + testDecryptCleanSEIPDv2 + , testCase + "conduitDecrypt matches conduitDecryptChecked (default)" + testOptionsMatchesCheckedDefaultSEIPDv2 + , testCase + "conduitDecrypt matches legacy conduitDecrypt output (default)" + testOptionsMatchesLegacyDefaultOutputSEIPDv2 + , testCase + "conduitDecrypt matches checked lenient trailing behavior" + testOptionsMatchesCheckedLenientTrailingSEIPDv2 + ] ) + , testGroup + "Encrypted secret keys" + [ testCase + "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" + (testSecretKeyDecryption "simple.seckey" "pki-password.txt") + , testCase + "SUS16bit CAST5 IteratedSalted SHA1 RSA" + (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") + , testCase + "SUSSHA1 AES256 IteratedSalted SHA512 RSA" + (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") + , testCase + "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA" + (testSecretKeyDecryption + "nist_p-256_secretkey.gpg" + "pki-password.txt") + ] + , testGroup + "Encrypting secret keys" + [ testCase + "legacy secret key encryption rejects implicit SHA-1 protection" + (testLegacySecretKeyEncryptionRejected + "unencrypted.seckey" + "pki-password.txt") + , testCase + "SUSym secret key roundtrips" + testSUSymSecretKeyRoundTrip + , testCase + "v6 secret key encryption roundtrips with SUSAEAD" + testV6SecretKeyEncryptionRoundTrip + , testCase + "v4 AEAD OCB secret key compatibility roundtrip" + testV4SecretKeyAEADOCBRoundTripCompat + ] + , testGroup + "decrypt conduit stuff" + [ testCase + "conduitDecrypt supports PKESKv6 with raw session-key callback" + testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey + , testCase + "conduitDecrypt rejects invalid PKESKv6 raw session-key length" + testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength + , testCase + "conduitDecrypt unwraps PKESK RSA session keys in-library" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrap + , testCase + "conduitDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback + , testCase + "conduitDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey + , testCase + "parsed RSA secret key decrypts PKCS#1 v1.5 payload" + testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testCase + "conduitDecrypt unwraps PKESK ECDH session keys in-library" + testConduitDecryptSEIPDv2WithPKESKECDHUnwrap + , testCase + "conduitDecrypt rejects ECDH ephemeral points with wrong curve length" + testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength + , testCase + "conduitDecrypt unwraps PKESKv3 X25519 session keys in-library" + testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across callback order" + testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across long callback order" + testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1" + testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + , testCase + "unwrap callback decrypts wildcard PKESKv3 via candidates list" + testMkCandidateResolverDecryptsWildcardPKESKv3 + , testCase + "conduitDecrypt wildcard resolver receives typed previous-failure diagnostics" + testConduitDecryptWildcardResolverProvidesTypedPreviousFailures + , testCase + "conduitDecryptWithReport surfaces wildcard resolver diagnostics" + testConduitDecryptWithReportCapturesWildcardResolverDiagnostics + , testCase + "conduitDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length" + testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength + , testCase + "conduitDecrypt falls back from Argon2 SKESK to PKESKv3 X25519" + testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 + , testCase + "conduitDecrypt retries earlier Argon2 SKESKs when latest is unusable" + testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK + , testCase + "conduitDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30" + testConduitDecryptSEIPDv2RejectsECDHNonTable30Params + , testCase + "conduitDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters" + testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams + , testCase + "conduitDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI" + testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI + , testCase + "conduitDecrypt keeps v6 Curve25519Legacy ECDH strict" + testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params + , testCase + "conduitDecrypt unwraps PKESK X448 session keys in-library" + testConduitDecryptSEIPDv2WithPKESKX448Unwrap + , testCase + "conduitDecrypt rejects PKESKv6 X448 ephemeral values with wrong length" + testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength + , testCase + "encrypt-side session material encoding uses OpenPGP format" + testEncodeOpenPGPSessionMaterial + , testCase + "encrypt-side PKESK builder wraps RSA recipient session key" + testBuildPKESKPayloadForRecipientRSA + , testCase + "encrypt-side PKESKv3 builder supports RSA v4 interop" + testBuildPKESKv3PayloadForRecipientRSAInterop + , testCase + "encrypt-side PKESKv3 builder supports v6 recipients" + testBuildPKESKv3PayloadForRecipientSupportsV6Key + , testCase + "encrypt-side PKESKv3 builder supports RFC6637 ECDH recipients" + testBuildPKESKv3PayloadForRecipientECDHInterop + , testCase + "PKESKv3 ECDH serializer uses RFC 6637 wire format" + testPKESKv3ECDHWireFormat + , testCase + "encrypt-side PKESKv3 builder supports RFC6637 Curve25519Legacy recipients" + testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop + , testCase + "encrypt-side PKESKv3 builder rejects non-RFC6637 Curve448Legacy recipients" + testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy + , testCase + "RFC 9580 v6 X25519 PKESK uses raw-key semantics, not v3-encoded material" + testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics + , testCase + "RFC 9580 v6 X448 PKESK uses raw-key semantics, not v3-encoded material" + testBuildPKESKv6PayloadForRecipientX448RawKeySemantics + , testCase + "encrypt-side policy builder emits PKESK3 for ForceV3Interop" + testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop + , testCase + "encrypt-side profile helper honors recipient capability hints" + testRecipientVersionStrategyForProfileHonorsHints + , testCase + "encryptForRecipients auto-detects mixed recipient PKESK strategies" + testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies + , testCase + "encryptForRecipients negotiates symmetric algorithm from recipient capabilities when enabled" + testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled + , testCase + "encryptForRecipients negotiates recipient capabilities by default" + testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault + , testCase + "encryptForRecipientsLegacy preserves capability negotiation opt-out" + testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut + , testCase + "encryptForRecipients capability negotiation fails when recipients share no symmetric algorithm" + testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm + , testCase + "recipientCapabilitiesFromSubpacketPayloads extracts preferred AEAD algorithms" + testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms + , testCase + "encryptForRecipients negotiates AEAD algorithm from recipient capabilities when enabled" + testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled + , testCase + "encryptForRecipients capability negotiation fails when recipients share no AEAD algorithm" + testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm + , testCase + "encryptForRecipients falls back to SEIPDv1 when recipients do not advertise SEIPDv2 support" + testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 + , testCase + "encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support" + testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC + , testCase + "recipientEncryptionTargetsFromTK returns only encryption-capable candidates" + testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys + , testCase + "recipientEncryptionTargetFromTK prefers encryption-capable subkeys" + testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary + , testCase + "recipientEncryptionTargetFromTK rejects TKs without encryptable key material" + testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp reports sign-only subkey rejection reasons" + testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp reports unsupported algorithm rejections" + testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp rejects expired subkeys" + testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp rejects revoked subkeys" + testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey + , testCase + "recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities" + testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities + , testCase + "recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp" + testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering + , testCase + "recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags" + testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags + , testCase + "recipientEncryptionTargetsFromTK includes subkeys with no key flags advertised" + testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags + , testCase + "encryptForRecipients optionally emits one-pass signature packets" + testEncryptRecipientsWithRequestEmitsOnePassSignatures + , testCase + "encryptForRecipients one-pass mode requires issuer metadata" + testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing + , testCase + "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 + "conduitDecrypt decrypts seipdv2 fixture with matching v6 secret key" + testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey + , testCase + "seipdv2-for-v4-key fixture parses as PKESKv6+SEIPDv2" + testSEIPDv2ForV4KeyArmor + , testCase + "conduitDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key" + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt tries earlier PKESKs when latest is unusable" + testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK + , testCase + "conduitDecrypt matches valid recipient-id forms without caller retries" + testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations + , testCase + "conduitDecrypt fails PKESK exhaustion without manual session-key prompt" + testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial + , testCase + "seipdv2-two-recipients fixture parses as PKESKv6*2+SEIPDv2" + testSEIPDv2TwoRecipientsArmor + , testCase + "seipdv2-three-recipients fixture parses as PKESKv6*3+SEIPDv2" + testSEIPDv2ThreeRecipientsArmor + , testCase + "conduitDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key" + testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs" + testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs + , testCase + "conduitDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key" + testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs" + testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs + ] + , testGroup "ESK/SKESK/ArgonS2K" + [ testCase + "encoded session key rejects too-short payloads" + testDecodeOpenPGPEncodedSessionKeyRejectsTooShort + , testCase + "encoded session key rejects algorithm/key-length mismatches" + testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch + , testCase + "encoded session key rejects checksum mismatches" + testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch + , testCase "unknown SKESK version is rejected" testSKESKRejectsUnknownVersion + , testCase + "v4 SKESK encrypted session keys reject Simple S2K" + testSKESK4EncryptedSessionKeyRejectsSimpleS2K + , testCase + "v4 SKESK Argon2 encrypted ESK roundtrip across AES-128/192/256" + testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES + , testCase + "v4 SKESK Argon2 encrypted ESK rejects legacy checksum trailer" + testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum + , testCase "Argon2 S2K derivation vector" testArgon2S2KVector + , testCase "Argon2 S2K Ord instance is total" testArgon2S2KOrdTotal + ] + + ] + +testCompression :: FilePath -> Assertion +testCompression fpr = do + bs <- BL.readFile $ "tests/data/" ++ fpr + let firstpass = fmap (concatMap (either (const []) id . decompressPkt) . unBlock) . runGet get $ bs + case firstpass of + Left _ -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> + assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." + Right packs -> do + let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] + let secondpass = + fmap (concatMap (either (const []) id . decompressPkt) . unBlock) . runGet get $ roundtrip + if secondpass == Right [] + then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." + else assertEqual ("for " ++ fpr) firstpass secondpass + +counter :: Monad m => DC.ConduitT a DC.Void m Int +counter = CL.fold (const . (1 +)) 0 + +testConduitOutputLength :: + FilePath + -> DC.ConduitT B.ByteString b (ResourceT IO) () + -> Int + -> Assertion +testConduitOutputLength fpr c target = do + len <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter + assertEqual ("expected length " ++ show target) target len + +testConduitToTKsEitherReportsParseFailure :: Assertion +testConduitToTKsEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| + conduitGet get DC..| conduitToTKsEither DC..| CL.consume + assertBool + "conduitToTKsEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +testConduitToTKsDroppingEitherReportsParseFailure :: Assertion +testConduitToTKsDroppingEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| + conduitGet get DC..| conduitToTKsDroppingEither DC..| CL.consume + assertBool + "conduitToTKsDroppingEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +-- This needs a lot of work +-- | Decrypt a symmetric-encrypted fixture using 'defaultDecryptPolicy' and +-- assert the packet structure is SKESK + SEIPDv1 and the cleartext matches. +-- Only suitable for AES-128/192/256 fixtures with iterated-salted S2K. +testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion +testSymmetricEncryption encfile passfile cleartext = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + assertEqual "wrong number of packets" 2 (length pt) + skesk <- + case pt of + [] -> assertFailure ("expected SKESK packet in " ++ encfile ++ " but packet list was empty") >> fail "empty fixture packet list" + (firstPkt:_) -> + case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of + Left err -> assertFailure ("failed to coerce first packet to SKESK: " ++ err) >> fail err + Right x -> pure x + assertEqual "first packet should be SKESK" SKESKType (packetType skesk) + case last pt of + SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) -> pure () + other -> + assertFailure + ("second packet should be SEIPDv1 (tag 18, version 1), got: " ++ show other) + decrypted <- + catch + (DC.runConduitRes $ + CL.sourceList pt DC..| conduitDecrypt (fakeCallback passphrase) DC..| + CL.consume) + (\e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw exception: " ++ err)) + payload <- + case decrypted of + [] -> + assertFailure ("decryption produced no packets for " ++ encfile) >> + fail "expected decrypted literal packet" + (firstDecrypted:_) -> + case (fromPktEither firstDecrypted :: Either String LiteralData) of + Left err -> + assertFailure ("failed to coerce decrypted packet to literal data: " ++ err) >> + fail err + Right x -> pure (_literalDataPayload x) + assertEqual ("cleartext for " ++ encfile) cleartext payload + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +testSEIPDv1ResyncNonceMdcRoundTrip :: Assertion +testSEIPDv1ResyncNonceMdcRoundTrip = do + let sa = AES256 + keyBytes = B.pack [0..31] + iv = IV (B.pack [32..47]) + cleartext = B.pack [1..80] + cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext + ciphertext <- + either + (\e -> assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) >> pure mempty) + pure + (encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartextWithMDC keyBytes) + (nonce, decrypted) <- + either + (\e -> assertFailure ("decryptOpenPGPCfbWithNonce failed: " ++ show e) >> pure (mempty, mempty)) + pure + (decryptOpenPGPCfbWithNonce sa ciphertext keyBytes) + assertEqual + "SEIPDv1 nonce should match IV||IV[-2:]" + (seipdv1NonceFromIV iv) + nonce + assertEqual + "decrypted bytes should include payload+MDC" + cleartextWithMDC + decrypted + payloadOut <- + either + (\err -> assertFailure ("validateSEIPD1MDC failed: " ++ err) >> pure mempty) + pure + (validateSEIPD1MDC nonce decrypted) + assertEqual "MDC-verified payload should round-trip" cleartext payloadOut + +-- | Like 'testSymmetricEncryption' but uses 'lenientDecryptPolicy' to permit +-- legacy RFC4880/RFC2440 message formats (SED, deprecated S2K, old ciphers). +-- The 'Bool' indicates whether the fixture uses SEIPDv1 (True) or SED (False). +testLegacySymmetricEncryption :: Bool -> FilePath -> FilePath -> BL.ByteString -> Assertion +testLegacySymmetricEncryption expectSEIPDv1 encfile passfile cleartext = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + assertEqual "wrong number of packets" 2 (length pt) + skesk <- + case pt of + [] -> assertFailure ("expected SKESK packet in " ++ encfile ++ " but packet list was empty") >> fail "empty fixture packet list" + (firstPkt:_) -> + case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of + Left err -> assertFailure ("failed to coerce first packet to SKESK: " ++ err) >> fail err + Right x -> pure x + assertEqual "first packet should be SKESK" SKESKType (packetType skesk) + case last pt of + SymEncDataPkt {} + | not expectSEIPDv1 -> pure () + | otherwise -> + assertFailure "expected SEIPDv1 packet (tag 18) but got SED (tag 9)" + SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) + | expectSEIPDv1 -> pure () + | otherwise -> + assertFailure "expected SED packet (tag 9) but got SEIPDv1 (tag 18)" + other -> assertFailure ("unexpected second packet: " ++ show other) + decrypted <- + catch + (DC.runConduitRes $ + CL.sourceList pt DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) (fakeCallback passphrase) DC..| + CL.consume) + (\e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw exception: " ++ err)) + payload <- + case decrypted of + [] -> + assertFailure ("decryption produced no packets for " ++ encfile) >> + fail "expected decrypted literal packet" + (firstDecrypted:_) -> + case (fromPktEither firstDecrypted :: Either String LiteralData) of + Left err -> + assertFailure ("failed to coerce decrypted packet to literal data: " ++ err) >> + fail err + Right x -> pure (_literalDataPayload x) + assertEqual ("cleartext for " ++ encfile) cleartext payload + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +-- | Assert that decrypting with the strict 'defaultDecryptPolicy' throws an +-- exception whose message contains the given substring. +testStrictPolicyRejectsEncryption :: FilePath -> FilePath -> String -> Assertion +testStrictPolicyRejectsEncryption encfile passfile expectedFragment = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + result <- + try + (DC.runConduitRes $ + CL.sourceList pt DC..| + conduitDecrypt (fakeCallback passphrase) DC..| + CL.consume) :: IO (Either SomeException [Pkt]) + case result of + Right _ -> + assertFailure $ + "Expected strict policy to reject '" ++ encfile ++ + "' with error containing '" ++ expectedFragment ++ "', but decryption succeeded" + Left err -> + assertBool + ("Expected error containing '" ++ expectedFragment ++ + "', got: " ++ show err) + (expectedFragment `isInfixOf` show err) + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +-- | Decrypt a file and check the 'DecryptOutcome'. +testDecryptOutcome :: FilePath -> FilePath -> DecryptOutcome -> Assertion +testDecryptOutcome encfile passfile expectedOutcome = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + (outcome, _pkts) <- + catch + (DC.runConduitRes $ + CL.sourceList pt DC..| + fuseBoth (conduitDecryptChecked (fakeCallback passphrase)) CL.consume) + (\e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw unexpected exception: " ++ err) + fail "unreachable") + assertEqual + ("DecryptOutcome for " ++ encfile) + expectedOutcome + outcome + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +-- | Build a synthetic packet list with an appended trailing packet, decrypt +-- with lenient policy, and verify 'DecryptTrailingData' is reported. +testTrailingDataReportedLenient :: FilePath -> FilePath -> Assertion +testTrailingDataReportedLenient encfile passfile = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + let trailingPkt = OtherPacketPkt 0xFE "" + ptWithTrailing = pt ++ [trailingPkt] + (outcome, _pkts) <- + catch + (DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| + fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) (fakeCallback passphrase)) CL.consume) + (\e -> do + let err = show (e :: SomeException) + assertFailure ("lenient decrypt threw unexpected exception: " ++ err) + fail "unreachable") + assertEqual + ("DecryptTrailingData for " ++ encfile) + DecryptTrailingData + outcome + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +-- | Same as above but with strict policy: should throw "after message +-- integrity boundary". +testTrailingDataRejectedStrict :: FilePath -> FilePath -> Assertion +testTrailingDataRejectedStrict encfile passfile = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + let trailingPkt = OtherPacketPkt 0xFE "" + ptWithTrailing = pt ++ [trailingPkt] + result <- + try + (DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| + fuseBoth (conduitDecryptChecked (fakeCallback passphrase)) CL.consume + ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) + Right (DecryptMalformedStructure malformedReason, _) -> + assertBool + ("Expected 'after message integrity boundary', got: " ++ malformedReason) + ("after message integrity boundary" `isInfixOf` malformedReason) + Right (other, _) -> + assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +encryptedSEIPDv2Packets :: IO [Pkt] +encryptedSEIPDv2Packets = do + let passphrase = mkPassphrase (BL.pack (map (fromIntegral . fromEnum) ("test" :: String))) + payload = mkClearPayload (BL.pack (map (fromIntegral . fromEnum) ("hello" :: String))) + let result = encryptMessageDefault DoNotExposeSessionMaterial passphrase payload + case result of + Left err -> fail ("encryptedSEIPDv2Packets: encryptMessageDefault failed: " ++ show err) + Right (encPayload, _) -> + DC.runConduitRes $ + CB.sourceLbs (encryptedPayloadBytes encPayload) DC..| conduitGet get DC..| + CL.consume + +defaultOptionsForPassphrase :: BL.ByteString -> DecryptOptions +defaultOptionsForPassphrase passphrase = + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = const (pure passphrase) + } + +testDecryptCleanSEIPDv2 :: Assertion +testDecryptCleanSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + (DC.runConduitRes $ + CL.sourceList pt DC..| fuseBoth (conduitDecryptChecked cb) CL.consume) + (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") + assertEqual "clean SEIPD v2 should yield DecryptClean" DecryptClean outcome + +testOptionsMatchesCheckedDefaultSEIPDv2 :: Assertion +testOptionsMatchesCheckedDefaultSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = defaultOptionsForPassphrase passphrase + checkedResult <- + DC.runConduitRes $ + CL.sourceList pt DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + optionsResult <- + DC.runConduitRes $ + CL.sourceList pt DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual "options conduit should match checked conduit on clean decrypt" checkedResult optionsResult + +testOptionsMatchesLegacyDefaultOutputSEIPDv2 :: Assertion +testOptionsMatchesLegacyDefaultOutputSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = defaultOptionsForPassphrase passphrase + legacyOutput <- + DC.runConduitRes $ + CL.sourceList pt DC..| conduitDecrypt cb DC..| CL.consume + (optionsOutcome, optionsOutput) <- + DC.runConduitRes $ + CL.sourceList pt DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual + "options conduit should report DecryptClean for clean stream" + DecryptClean + optionsOutcome + assertEqual "legacy conduit output should match options conduit output" legacyOutput optionsOutput + +testTrailingDataRejectedStrictSEIPDv2 :: Assertion +testTrailingDataRejectedStrictSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + (DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected 'after message integrity boundary', got: " ++ reason) + ("after message integrity boundary" `isInfixOf` reason) + Right (other, _) -> + assertFailure ("Expected strict policy to reject trailing data but got: " ++ show other) + +testTrailingDataReportedLenientSEIPDv2 :: Assertion +testTrailingDataReportedLenientSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + (DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| + fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb) CL.consume) + (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") + assertEqual "trailing packet should yield DecryptTrailingData" DecryptTrailingData outcome + +testOptionsMatchesCheckedLenientTrailingSEIPDv2 :: Assertion +testOptionsMatchesCheckedLenientTrailingSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = lenientDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + checkedResult <- + DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| + fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb) CL.consume + optionsResult <- + DC.runConduitRes $ + CL.sourceList ptWithTrailing DC..| + fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual "options conduit should match checked lenient conduit with trailing data" checkedResult optionsResult + +testRejectsNonEncryptedAfterESKPrelude :: Assertion +testRejectsNonEncryptedAfterESKPrelude = do + pt <- encryptedSEIPDv2Packets + let malformed = + case pt of + [] -> [] + esk:_ -> + [ esk + , LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "not-encrypted" + ] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + (DC.runConduitRes $ + CL.sourceList malformed DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected ESK prelude shape failure, got: " ++ reason) + ("ESK packets must immediately precede encrypted data" `isInfixOf` reason) + Right (other, _) -> + assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) + +testRejectsMisalignedESKVersionForSEIPDv2 :: Assertion +testRejectsMisalignedESKVersionForSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let malformed = + case pt of + (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa _ s2k _ _ _)):rest) -> + SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) : rest + _ -> pt + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + (DC.runConduitRes $ + CL.sourceList malformed DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected payload/ESK alignment failure, got: " ++ reason) + ("version-aligned" `isInfixOf` reason) + Right (other, _) -> + assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) + +testDiscardsMisalignedESKWhenAlignedCandidateExists :: Assertion +testDiscardsMisalignedESKWhenAlignedCandidateExists = do + pt <- encryptedSEIPDv2Packets + let withMixedPrelude = + case pt of + (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)):rest) -> + SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) : SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) : rest + _ -> pt + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + (DC.runConduitRes $ + CL.sourceList withMixedPrelude DC..| fuseBoth (conduitDecryptChecked cb) CL.consume) + (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") + assertEqual + "misaligned ESKs should be discarded when an aligned ESK is present" + DecryptClean + outcome + +testSecretKeyDecryption :: FilePath -> FilePath -> Assertion +testSecretKeyDecryption keyfile passfile = do + passphrase <- readFixtureLazy passfile + kr <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| + CL.consume + SecretKey pkp ska <- + case kr of + [] -> + assertFailure ("no packets found in secret key fixture " ++ keyfile) >> + fail "empty secret key fixture" + (firstPkt:_) -> + case (fromPktEither firstPkt :: Either String SecretKey) of + Left err -> assertFailure ("failed to coerce key packet to SecretKey: " ++ err) >> fail err + Right x -> pure x + decrypted <- + case decryptPrivateKey (pkp, ska) passphrase of + Left err -> + assertFailure ("secret key decryption failed: " ++ err) >> + fail "secret key decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> doPkeyAndSkeyMatch (_pubkey pkp) skey + other -> + assertFailure + ("secret key decryption should produce an unencrypted secret key, got: " ++ + show other) + +testLegacySecretKeyEncryptionRejected :: FilePath -> FilePath -> Assertion +testLegacySecretKeyEncryptionRejected keyfile passfile = do + passphrase <- readFixtureLazy passfile + kr <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| + CL.consume + SecretKey pkp ska <- + case kr of + [] -> + assertFailure ("no packets found in secret key fixture " ++ keyfile) >> + fail "empty secret key fixture" + (firstPkt:_) -> + case (fromPktEither firstPkt :: Either String SecretKey) of + Left err -> assertFailure ("failed to coerce key packet to SecretKey: " ++ err) >> fail err + Right x -> pure x + case + encryptPrivateKeyWithPolicyAndSaltAndIV + defaultPolicy + pkp + (Salt "\226~\197\a\202#\"G") + (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") + ska + passphrase of + Left err | "explicit legacy override required" `isInfixOf` err -> pure () + Left err -> + assertFailure + ("legacy secret key encryption should be rejected with a policy error, got: " ++ + err) + Right _ -> + assertFailure "legacy secret key encryption should reject implicit SHA-1 protection" + +testV6SecretKeyEncryptionRoundTrip :: Assertion +testV6SecretKeyEncryptionRoundTrip = do + passphrase <- readPKIPassphrase + armors <- loadArmor "v6-secret.pgp.aa" + armor <- + case armors of + (a:_) -> pure a + [] -> + assertFailure "v6-secret.pgp.aa should contain one armored payload" >> + fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + SecretKey pkp ska <- + case [sk | pkt <- packets, Right sk <- [fromPktEither pkt :: Either String SecretKey]] of + (sk:_) -> pure sk + [] -> + assertFailure "v6-secret.pgp.aa should contain a secret key packet" >> + fail "expected secret key packet" + originalSKey <- + case ska of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure "v6-secret.pgp.aa should contain unencrypted secret key material" >> + fail "expected unencrypted secret key" + changed <- + case + encryptPrivateKeyWithPolicyAndSaltAndIV + defaultPolicy + pkp + (Salt "1234567890ABCDEF") + (IV "1234567890ABCDE") + ska + passphrase of + Left err -> + assertFailure ("v6 secret key encryption failed: " ++ err) >> + fail "v6 secret key encryption failed" + Right x -> pure x + case changed of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual + "v6 secret key encryption should use expected Argon2 t parameter" + 1 + t + assertEqual + "v6 secret key encryption should use expected Argon2 p parameter" + 4 + p + assertEqual + "v6 secret key encryption should use expected Argon2 encoded memory parameter" + 15 + em + assertBool + "v6 secret key encryption should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure "v6 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" + let serialized = runPut (put (toPkt (SecretKey pkp changed))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) + _ -> + assertFailure "re-serialized v6 secret key should parse back as a secret key packet" >> + fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure ("v6 secret key roundtrip decryption failed: " ++ err) >> + fail "v6 secret key roundtrip decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "v6 secret key roundtrip should preserve secret key material" + originalSKey + skey + _ -> assertFailure "v6 secret key roundtrip should decrypt to unencrypted secret material" + +testV4SecretKeyAEADOCBRoundTripCompat :: Assertion +testV4SecretKeyAEADOCBRoundTripCompat = do + (pkp, privateKey) <- loadUnencryptedRsaSigner + let skey = RSAPrivateKey (RSA_PrivateKey privateKey) + passphrase = "legacy-aead-passphrase" + compatPolicy = + (policyForRFC RFC4880) + { policySecretKeyProtection = policySecretKeyProtection defaultPolicy + } + salt = Salt (B.pack [0x00 .. 0x0f]) + iv = IV (B.pack [0x10 .. 0x1e]) + encrypted <- + case + encryptPrivateKeyWithPolicyAndSaltAndIV + compatPolicy + pkp + salt + iv + (SUUnencrypted skey 0) + passphrase of + Left err -> + assertFailure ("v4 AEAD secret key encryption failed: " ++ err) >> + fail "v4 AEAD secret key encryption failed" + Right x -> pure x + case encrypted of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual "v4 AEAD secret key encryption should use expected Argon2 t" 1 t + assertEqual "v4 AEAD secret key encryption should use expected Argon2 p" 4 p + assertEqual "v4 AEAD secret key encryption should use expected Argon2 encoded-memory" 15 em + assertBool + "v4 AEAD secret key encryption should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure "v4 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" + let serialized = runPut (put (toPkt (SecretKey pkp encrypted))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) + _ -> + assertFailure "re-serialized v4 AEAD secret key should parse back as a secret key packet" >> + fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure ("v4 AEAD secret key roundtrip decryption failed: " ++ err) >> + fail "v4 AEAD secret key roundtrip decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey' _ -> + assertEqual + "v4 AEAD secret key roundtrip should preserve secret key material" + skey + skey' + _ -> assertFailure "v4 AEAD secret key roundtrip should decrypt to unencrypted secret material" + +testSUSymSecretKeyRoundTrip :: Assertion +testSUSymSecretKeyRoundTrip = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| + CL.consume + (pkp, skey) <- + case packets of + (SecretKeyPkt pkpayload (SUUnencrypted sk _):_) -> pure (pkpayload, sk) + _ -> + assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" >> + fail "expected unencrypted secret key packet" + let cleartext = legacyRsaSecretKeyBytes skey + cleartextLBS = BL.fromStrict cleartext + clearWithChecksum = cleartextLBS <> runPut (putWord16be (legacyChecksum16 cleartext)) + iv = IV (B.pack [0..15]) + sa = AES128 + keyMaterial <- + case string2Key (Simple DeprecatedMD5) 16 passphrase of + Left err -> + assertFailure ("failed to derive SUSym key material: " ++ renderS2KError err) >> + fail "failed to derive SUSym key material" + Right km -> pure km + encrypted <- + case encryptNoNonce sa (Simple DeprecatedMD5) iv (BL.toStrict clearWithChecksum) keyMaterial of + Left err -> + assertFailure ("failed to encrypt legacy SUSym secret key: " ++ show err) >> + fail "failed to encrypt legacy SUSym secret key" + Right bs -> pure bs + let legacySka = SUSym sa iv (BL.fromStrict encrypted) + serialized = runPut (put (toPkt (SecretKey pkp legacySka))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) + _ -> + assertFailure "serialized SUSym secret key should parse back as a secret key packet" >> + fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure ("SUSym secret key decryption failed: " ++ err) >> + fail "SUSym secret key decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted parsedSKey _ -> + assertEqual + "SUSym secret key roundtrip should preserve secret key material" + skey + parsedSKey + _ -> assertFailure "SUSym secret key roundtrip should decrypt to unencrypted secret material" + +legacyRsaSecretKeyBytes :: SKey -> B.ByteString +legacyRsaSecretKeyBytes (RSAPrivateKey (RSA_PrivateKey (RSA.PrivateKey _ d p q _ _ _))) = + BL.toStrict $ + runPut $ + case inverse q p of + Just u -> do + put (MPI d) + put (MPI p) + put (MPI q) + put (MPI u) + Nothing -> error "invalid RSA key in legacy secret key test" +legacyRsaSecretKeyBytes _ = error "legacyRsaSecretKeyBytes requires an RSA secret key" + +legacyChecksum16 :: B.ByteString -> Word16 +legacyChecksum16 = + fromIntegral . + B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 + +testLegacyEncryptionFixtureShape :: Assertion +testLegacyEncryptionFixtureShape = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/encryption.gpg" DC..| conduitGet get DC..| CL.consume + let hasKeyEncapsulation = any isKeyEncapsulation packets + hasEncryptedData = any isEncryptedData packets + assertBool + "encryption.gpg should contain PKESK or SKESK key-encapsulation" + hasKeyEncapsulation + assertBool "encryption.gpg should contain encrypted data" hasEncryptedData + where + isKeyEncapsulation (SKESKPkt _) = True + isKeyEncapsulation (PKESKPkt _) = True + isKeyEncapsulation _ = False + isEncryptedData SymEncDataPkt {} = True + isEncryptedData SymEncIntegrityProtectedDataPkt {} = True + isEncryptedData _ = False + +testBuildPKESKPayloadForRecipientRSA :: Assertion +testBuildPKESKPayloadForRecipientRSA = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x2e) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk builder rsa payload" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + }) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKPayloadForRecipient failed: " ++ show err) >> + fail "buildPKESKPayloadForRecipient failed" + Right p -> pure p + case pkeskPayload of + PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do + let eskBytes = BL.toStrict 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) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK builder RSA decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientRSAInterop :: Assertion +testBuildPKESKv3PayloadForRecipientRSAInterop = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V4 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x2d) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk builder rsa v3 interop payload" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyCallback _ = pure (Just (RSAPrivateKey (RSA_PrivateKey privateKey))) + keyContextCallback pkt = do + msk <- keyCallback pkt + pure $ + fmap + (\sk -> + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = sk + }) + msk + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> + fail "buildPKESKv3PayloadForRecipient failed" + Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure p + Right other -> + assertFailure ("Expected PKESK3 RSA payload, got " ++ show other) >> + fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 RSA interop decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientSupportsV6Key :: Assertion +testBuildPKESKv3PayloadForRecipientSupportsV6Key = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x11) + let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint recipient))) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + case result of + Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyId RSA _)) -> + assertEqual + "PKESKv3 builder should derive v6 key ID from the high-order 64 bits of the fingerprint" + expectedKeyId + keyId + Right payload -> + assertFailure ("Expected PKESK3 RSA payload for v6 recipient, got " ++ show payload) + Left err -> + assertFailure ("Expected PKESK3 RSA payload for v6 recipient, got error " ++ show err) + +testBuildPKESKv3PayloadForRecipientECDHInterop :: Assertion +testBuildPKESKv3PayloadForRecipientECDHInterop = do + (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) + sessionKey = SessionKey (B.replicate 32 0x21) + salt = Salt (B.pack [0x20 .. 0x3f]) + payload = "pkesk builder ecdh v3 interop payload" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = recipientSKey + })) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> + fail "buildPKESKv3PayloadForRecipient failed" + Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH _)) -> pure p + Right other -> + assertFailure ("Expected PKESK3 ECDH payload, got " ++ show other) >> + fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 ECDH interop decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +-- | Verify that the PKESKv3 ECDH serializer writes the wrapped-key field using the +-- RFC 6637 §8 wire format (MPI(ephemeral) || 1-octet-count || C) rather than the +-- old double-MPI encoding that caused interoperability failures. +testPKESKv3ECDHWireFormat :: Assertion +testPKESKv3ECDHWireFormat = do + (recipientPub, _) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES256) + -- Use a session key whose first byte is 0x00 so leading-zero stripping + -- is observable if i2osp truncates the wrapped key. + sessionKey = SessionKey (B.cons 0x00 (B.replicate 31 0xAB)) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + case pkeskResult of + Left err -> assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) + Right p -> do + -- Serialise the packet to wire bytes then parse the PKESK body manually. + let wire = BL.toStrict (runPut (put (PKESKPkt p))) + -- Skip new-format tag byte (0xC1), then parse the packet length. + -- For the test we just round-trip through parsePkts and check the body layout. + case parsePkts (BL.fromStrict wire) of + [PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH (ephMPI NE.:| [wrappedMPI])))] -> do + -- The ephemeral MPI should be non-trivially large (EC point). + assertBool "ephemeral MPI should be non-empty" (unMPI ephMPI > 0) + -- The wrapped MPI stores the raw i2osp bytes; for AES-256 the RFC 3394 + -- ciphertext is 48 bytes. i2osp strips leading zeros so the stored + -- integer may represent fewer bytes, but candidateWrappedRFC3394Ciphertexts + -- handles that. What we're checking here is the WIRE format: + -- after the ephemeral MPI there must be exactly 1-byte-len + C bytes, + -- not a second MPI header. + -- + -- Re-serialise and inspect the bytes after the ephemeral MPI manually. + let ephBytes = BL.toStrict (runPut (put ephMPI)) + pktBody = + -- wire: 0xC1 | varlen | version(1) | keyid(8) | pka(1) | body + -- skip tag(1) + len(variable) + version(1) + keyid(8) + pka(1) + -- We just serialise the body directly via putPKESKv3SessionKeyMaterial equivalent: + BL.toStrict (runPut (put (PKESKPkt (PKESKPayloadV3Packet + (PKESKPayloadV3 3 (EightOctetKeyId (BL.replicate 8 0)) ECDH + (ephMPI NE.:| [wrappedMPI])))))) + -- Find the position of the body after tag+len+version+keyid+pka. + -- Tag: 1 byte; new-format len: 1 or 2 bytes; version: 1; keyid: 8; pka: 1 = 12 or 13 bytes + -- Instead of parsing the header, just verify the body doesn't start with + -- the two-byte MPI bit-count of the wrapped key. + -- After ephBytes in the body, the next byte should be the 1-byte count (24-48), + -- not the high byte of an MPI bit-count (which would be 0x01 for 383-bit keys). + -- We search for ephBytes in pktBody and check what follows. + let stripped = dropPKESKv3Header pktBody + afterEph = B.drop (B.length ephBytes) stripped + assertBool + "PKESKv3 ECDH wire body: after ephemeral MPI there must be at least 1 byte for wrapped-key length" + (not (B.null afterEph)) + let wrappedLenByte = fromIntegral (B.head afterEph) :: Int + assertBool + ("PKESKv3 ECDH wire: wrapped-key length byte " ++ + show wrappedLenByte ++ + " should be a valid RFC 3394 wrapped-key length (24, 32, 40, or 48)") + (wrappedLenByte `elem` [24, 32, 40, 48]) + assertEqual + "PKESKv3 ECDH wire: bytes after length field must equal length" + wrappedLenByte + (B.length (B.tail afterEph)) + other -> + assertFailure ("Expected single PKESKv3 ECDH packet after round-trip, got " ++ show other) + where + -- Drop the new-format packet header (tag byte + variable-length field + + -- version byte + 8-byte key-id + pka byte) to reach the session-key material. + dropPKESKv3Header bs + | B.length bs < 3 = bs + | otherwise = + let lenByte = B.index bs 1 + headerLen + | lenByte < 192 = 2 -- 1-byte length + | lenByte < 224 = 3 -- 2-byte length + | otherwise = 6 -- 5-byte length (rare) + in B.drop (headerLen + 1 + 8 + 1) bs +testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop :: Assertion +testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop = do + let recipientSecretRaw = B.pack [1 .. 32] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) + SHA256 + AES256) + recipientSKey = + ECDHPrivateKey + (ECDSA_PrivateKey + (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) + sessionKey = SessionKey (B.replicate 32 0x22) + salt = Salt (B.pack [0x40 .. 0x5f]) + payload = "pkesk builder curve25519legacy v3 interop payload" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = recipientSKey + })) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> + fail "buildPKESKv3PayloadForRecipient failed" + Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH (ephemeralMPI NE.:| _))) -> do + let ephemeralBytes = i2osp (unMPI ephemeralMPI) + assertEqual + "PKESKv3 Curve25519Legacy ephemeral point should be 0x40-prefixed 33-octet value" + 33 + (B.length ephemeralBytes) + assertEqual + "PKESKv3 Curve25519Legacy ephemeral point should use RFC6637 0x40 prefix" + 0x40 + (B.head ephemeralBytes) + pure p + Right other -> + assertFailure ("Expected PKESK3 ECDH payload, got " ++ show other) >> + fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 Curve25519Legacy interop decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy :: Assertion +testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy = do + let recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey + (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint 1))) + SHA512 + AES256) + sessionKey = SessionKey (B.replicate 32 0x23) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) + case result of + Left (InvalidRecipientKeyMaterial ECDH err) + | "RFC6637-compatible" `isInfixOf` err -> pure () + | otherwise -> + assertFailure + ("Expected RFC6637 compatibility rejection, got: " ++ err) + Left err -> + assertFailure ("Expected InvalidRecipientKeyMaterial ECDH, got " ++ show err) + Right payload -> + assertFailure ("Expected RFC6637 compatibility rejection, got payload: " ++ show payload) + +-- | Conformance test: v6 X25519 PKESK uses raw session key, not v3-encoded material. +-- RFC 9580 specifies that v6 X25519 wraps the raw session key directly (no algorithm byte or checksum). +-- When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes. +-- If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped), +-- the wrapped result would be ~48 bytes, so we verify wrapped size is 40. +testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics :: Assertion +testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics = do + let recipientSecretRaw = B.pack [1 .. 32] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + v4Recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipient = setKeyVersion V6 v4Recipient + sessionKey = SessionKey (B.replicate 32 0x24) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKPayloadForRecipient failed for v6 X25519: " ++ show err) + Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do + let eskBytes = BL.toStrict eskBytesLazy + assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes + let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int + assertEqual + "v6 X25519 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes" + 40 + wrappedLen + Right other -> + assertFailure ("Expected PKESKPayloadV6 with X25519, got " ++ show other) + +-- | Conformance test: v6 X448 PKESK uses raw session key, not v3-encoded material. +-- RFC 9580 specifies that v6 X448 wraps the raw session key directly (no algorithm byte or checksum). +-- When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes. +-- If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped), +-- the wrapped result would be ~48 bytes, so we verify wrapped size is 40. +testBuildPKESKv6PayloadForRecipientX448RawKeySemantics :: Assertion +testBuildPKESKv6PayloadForRecipientX448RawKeySemantics = do + let recipientSecretRaw = B.pack [1 .. 56] + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + v4Recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipient = setKeyVersion V6 v4Recipient + sessionKey = SessionKey (B.replicate 32 0x25) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case pkeskPayloadResult of + Left err -> + assertFailure ("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err) + Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do + let eskBytes = BL.toStrict 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) + +testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop :: Assertion +testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V4 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x16) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKPayloadForRecipient ForceV3Interop recipient sessionMaterial + case result of + Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure () + Right payload -> + assertFailure ("Expected PKESK3 RSA for ForceV3Interop, got " ++ show payload) + Left err -> + assertFailure ("Expected PKESK3 RSA for ForceV3Interop, got error " ++ show err) + +testRecipientVersionStrategyForProfileHonorsHints :: Assertion +testRecipientVersionStrategyForProfileHonorsHints = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure ("Expected explicit recipient hint to win, got " ++ show other) + case recipientVersionStrategyForProfile EncryptInteropLegacy (recipientEncryptionTarget recipient) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure ("Expected legacy profile fallback to force v3, got " ++ show other) + let v4Recipient = setKeyVersion V4 recipient + case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTarget recipient) of + Right RecipientPreferV6 -> pure () + other -> + assertFailure ("Expected strict profile auto-detect to prefer v6 for v6 recipients, got " ++ show other) + case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTarget v4Recipient) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure ("Expected strict profile auto-detect to force v3 for legacy recipients, got " ++ show other) + +testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies :: Assertion +testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTarget v6Recipient + , recipientEncryptionTarget v4Recipient + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient autodetect" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x77)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure ("Expected mixed-recipient request to encrypt successfully, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptPackets = packets } -> do + let pkesks = [p | PKESKPkt p <- packets] + assertBool + "strict profile auto-detect should emit PKESKv6 for v6 recipients" + (any isPKESK6 pkesks) + assertBool + "strict profile auto-detect should emit PKESKv3 for v4 recipients" + (any isPKESK3 pkesks) + where + isPKESK6 PKESKPayloadV6Packet {} = True + isPKESK6 _ = False + isPKESK3 PKESKPayloadV3Packet {} = True + isPKESK3 _ = False + +testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled :: Assertion +testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x22)) + } + } + result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request + case result of + Left err -> + assertFailure ("Expected recipient capability negotiation to succeed, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> + assertEqual + "capability negotiation should pick common preferred symmetric algorithm" + AES128 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault :: Assertion +testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "default recipient capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x24)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure ("Expected default encryptForRecipients negotiation to succeed, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> + assertEqual + "encryptForRecipients should negotiate recipient capabilities by default" + AES128 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut :: Assertion +testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "legacy recipient capability opt-out payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x25)) + } + } + result <- encryptForRecipientsLegacy request + case result of + Left err -> + assertFailure ("Expected legacy encryptForRecipients opt-out to succeed, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> + assertEqual + "encryptForRecipientsLegacy should preserve policy-default symmetric selection" + AES256 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm :: Assertion +testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient capability mismatch payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x23)) + } + } + result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request + case result of + Left (RecipientCapabilitySelectionFailure (RecipientCapabilityNoCommonSymmetricAlgorithms _)) -> pure () + Left other -> + assertFailure ("Expected RecipientCapabilityNoCommonSymmetricAlgorithms, got " ++ show other) + Right _ -> + assertFailure "Expected recipient capability negotiation to fail without common symmetric algorithm" + +testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms :: Assertion +testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms = do + (recipient, _privateKey) <- loadUnencryptedRsaSigner + let caps = + recipientCapabilitiesFromSubpacketPayloads + recipient + [OtherSigSub 39 (BL.pack [9, 2, 7, 3, 9, 2])] + assertEqual + "preferred AEAD ciphersuites subpacket should extract unique AEAD preferences in declaration order" + [OCB, GCM] + (recipientCapabilityPreferredAEADAlgorithms caps) + +testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled :: Assertion +testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [GCM, OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [GCM] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient AEAD capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x26)) + } + } + result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request + case result of + Left err -> + assertFailure ("Expected AEAD capability negotiation to succeed, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptPackets = packets + , recipientEncryptSessionMaterial = material + } -> do + assertEqual + "AEAD capability negotiation should preserve symmetric negotiation" + AES128 + (pkeskSessionAlgorithm material) + case [aa | SymEncIntegrityProtectedDataPkt (SEIPD2 _ aa _ _ _) <- packets] of + [selectedAEAD] -> + assertEqual + "AEAD capability negotiation should pick common preferred AEAD algorithm" + GCM + selectedAEAD + other -> + assertFailure ("Expected one SEIPDv2 packet, got " ++ show other) + +testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm :: Assertion +testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [GCM] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient AEAD mismatch payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x27)) + } + } + result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request + case result of + Left (RecipientCapabilitySelectionFailure (RecipientCapabilityNoCommonAEADAlgorithms _)) -> pure () + Left other -> + assertFailure ("Expected RecipientCapabilityNoCommonAEADAlgorithms, got " ++ show other) + Right _ -> + assertFailure "Expected recipient capability negotiation to fail without common AEAD algorithm" + +testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 :: Assertion +testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + sharedCaps keyVersion recipient = + RecipientCapabilities + { recipientCapabilityKeyVersion = keyVersion + , recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1 + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient (sharedCaps V6 v6Recipient) + , recipientEncryptionTargetWithCapabilities v4Recipient (sharedCaps V4 v4Recipient) + ] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient seipd fallback payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x28)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure ("Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got " ++ show err) + Right RecipientEncryptResult { recipientEncryptPackets = packets } -> do + let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] + case seipdPkts of + [SEIPD1 1 _] -> pure () + [SEIPD2 {}] -> assertFailure "Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support" + other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) + +testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC :: Assertion +testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv2 + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [recipientEncryptionTargetWithCapabilities v4Recipient caps] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient seipd v1 capability failure payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = Nothing + } + } + result <- encryptForRecipients request + case result of + Left (RecipientCapabilitySelectionFailure (RecipientCapabilityMissingSEIPDv1Support _)) -> pure () + Left other -> + assertFailure ("Expected RecipientCapabilityMissingSEIPDv1Support, got " ++ show other) + Right _ -> + assertFailure "Expected SEIPDv1 encryption to fail when recipients do not advertise MDC support" + +testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys :: Assertion +testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + (baseEncryptingSubkey, _privateKey) <- loadUnencryptedRsaSigner + let tkUnknown = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = + [ ( PublicSubkeyPkt (setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey) + , [] + ) + ] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> error "expected public TK for recipient target test" + Left err -> error err + encryptingSubkey = setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey + targets = recipientEncryptionTargetsFromTK tk + assertEqual "TKUnknown-derived targets should include only encryption-capable keys" 1 (length targets) + case targets of + [target] -> + assertEqual + "TKUnknown-derived target should preserve selected encryption key" + (fingerprint encryptingSubkey) + (fingerprint (recipientEncryptionTargetKey target)) + _ -> + assertFailure "Expected exactly one encryption-capable target" + +testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary :: Assertion +testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let primary = setKeyVersion V4 baseRecipient + subkey = setKeyVersion V6 baseRecipient + tkUnknown = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [])] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> error "expected public TK for recipient target selection test" + Left err -> error err + case recipientEncryptionTargetFromTK tk of + Right target -> + assertEqual + "TKUnknown-derived single target should prioritize encryption subkeys" + (fingerprint subkey) + (fingerprint (recipientEncryptionTargetKey target)) + Left err -> + assertFailure ("Expected TKUnknown-derived target selection to succeed, got " ++ show err) + +testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys :: Assertion +testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + let tkUnknown = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> error "expected public TK for recipient rejection test" + Left err -> error err + case recipientEncryptionTargetFromTK tk of + Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure () + Left other -> + assertFailure ("Expected RecipientCapabilityNoEncryptableKeyMaterialInTK, got " ++ show other) + Right _ -> + assertFailure "Expected TKUnknown-derived target selection to reject non-encryptable TKs" + +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + report = recipientEncryptionTargetsReportFromTKAtTimestamp signatureTime tk + acceptedFps = + map (fingerprint . recipientEncryptionTargetKey) (recipientEncryptionTargetsAccepted report) + rejectedReasons = + map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) + assertBool + "report should keep encryption-eligible primary key as accepted" + (fingerprint primary `elem` acceptedFps) + assertEqual + "report should explain sign-only subkey rejection" + [RecipientTargetMissingEncryptionFlags subkey (Set.fromList [SignDataKey])] + rejectedReasons + +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + let tk = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [] + } + report = + recipientEncryptionTargetsReportFromTKAtTimestamp + (_timestamp signingPrimary) + tk + assertEqual + "unsupported key algorithms should be surfaced in report rejections" + [RecipientTargetUnsupportedAlgorithm (_pkalgo signingPrimary)] + (map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report)) + +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + targetTime = ThirtyTwoBitTimeStamp 1700000020 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + , SigSubPacket False (KeyExpirationTime (ThirtyTwoBitDuration 5)) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + report = recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk + rejectedReasons = map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) + assertBool + "expired subkey should be rejected from recipient targets" + (RecipientTargetNotValidAtTimestamp subkey targetTime `elem` rejectedReasons) + +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let bindingTime = ThirtyTwoBitTimeStamp 1700000000 + revocationTime = ThirtyTwoBitTimeStamp 1700000005 + targetTime = ThirtyTwoBitTimeStamp 1700000010 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + bindingTime + [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] + subkeyRevocationSig <- + signSubkeyRevocationWithRSAAt + primary + subkey + signingKey + revocationTime + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig, subkeyRevocationSig])] + } + report = recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk + rejectedReasons = map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) + assertBool + "revoked subkey should be rejected from recipient targets" + (RecipientTargetRevoked subkey `elem` rejectedReasons) + +testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities :: Assertion +testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities = do + (primary, signingKey) <- loadUnencryptedRsaSigner + (subkey, _privateKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + directKeySig <- + signDirectKeyWithRSAExtrasAt + primary + signingKey + signatureTime + [ SigSubPacket False (PreferredSymmetricAlgorithms [AES128]) + , SigSubPacket False (OtherSigSub 39 (BL.pack [9, 2, 7, 3])) + ] + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [directKeySig] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + case targets of + (target:_) -> + case recipientEncryptionTargetCapabilities target of + Nothing -> + assertFailure "Expected TKUnknown-derived target to include extracted capabilities" + Just caps -> do + assertEqual + "self-signature capability extraction should include primary-key symmetric preferences" + [AES128] + (recipientCapabilityPreferredSymmetricAlgorithms caps) + assertEqual + "self-signature capability extraction should include primary-key preferred AEAD algorithms" + [OCB, GCM] + (recipientCapabilityPreferredAEADAlgorithms caps) + assertEqual + "self-signature capability extraction should include subkey key flags" + (Set.fromList [EncryptCommunicationsKey]) + (recipientCapabilityKeyFlags caps) + [] -> + assertFailure "Expected at least one TKUnknown-derived target" + +testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering = do + (primary, signingKey) <- loadUnencryptedRsaSigner + (subkey, _privateKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000100 + beforeSignature = ThirtyTwoBitTimeStamp 1699999999 + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of + Left err -> + assertFailure ("Expected timestamp-scoped TKUnknown target selection to succeed, got " ++ show err) + Right target -> + case recipientEncryptionTargetCapabilities target of + Nothing -> + assertFailure "Expected TKUnknown-derived target to include capabilities when timestamp-scoped" + Just caps -> + assertEqual + "subkey binding created after target timestamp should not contribute key flags" + Set.empty + (recipientCapabilityKeyFlags caps) + +testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags :: Assertion +testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + let subkeyFp = fingerprint subkey + primaryFp = fingerprint primary + targetFps = map (fingerprint . recipientEncryptionTargetKey) targets + assertBool + "subkey with sign-only key flags should be excluded from encryption targets" + (subkeyFp `notElem` targetFps) + assertBool + "primary key (no explicit flags) should still be included as encryption target" + (primaryFp `elem` targetFps) + +testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags :: Assertion +testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + let subkeyFp = fingerprint subkey + targetFps = map (fingerprint . recipientEncryptionTargetKey) targets + assertBool + "subkey with no key flags should be included as encryption target (legacy-compatible)" + (subkeyFp `elem` targetFps) + +testEncryptRecipientsWithRequestEmitsOnePassSignatures :: Assertion +testEncryptRecipientsWithRequestEmitsOnePassSignatures = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + signature = + SigV4 + BinarySig + RSA + SHA256 + [] + [SigSubPacket False (Issuer (EightOctetKeyId (BL.pack [0x01 .. 0x08])))] + 0 + (MPI 1 :| []) + payload = "recipient one-pass signature payload" + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + { recipientPayloadUseOnePassSignatures = True + , recipientPayloadSignatures = [signature] + } + , recipientEncryptRequestPayload = payload + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x55)) + } + } + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + })) + passphraseCallback _ = pure BL.empty + result <- encryptForRecipients request + packets <- + case result of + Left err -> + assertFailure ("Expected one-pass encryption request to succeed, got " ++ show err) >> + fail "encryptForRecipients failed" + Right RecipientEncryptResult { recipientEncryptPackets = encryptedPackets } -> pure encryptedPackets + decrypted <- + DC.runConduitRes $ + CL.sourceList packets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False)), LiteralDataPkt _ _ _ gotPayload, SignaturePkt _] -> + assertEqual "decrypted payload matches original plaintext" (BL.fromStrict payload) gotPayload + other -> + assertFailure ("Expected decrypted [OPS3, LiteralData, Signature], got " ++ show other) + +testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing :: Assertion +testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + signature = SigV4 BinarySig RSA SHA256 [] [] 0 (MPI 1 :| []) + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + { recipientPayloadUseOnePassSignatures = True + , recipientPayloadSignatures = [signature] + } + , recipientEncryptRequestPayload = "recipient one-pass missing issuer metadata payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x56)) + } + } + result <- encryptForRecipients request + case result of + Left (PayloadBuildFailure err) -> + assertBool + "missing issuer metadata should surface as payload build failure" + ("without issuer metadata" `isInfixOf` err) + Left err -> + assertFailure ("Expected PayloadBuildFailure for missing OPS issuer metadata, got " ++ show err) + Right _ -> + assertFailure "Expected one-pass request without issuer metadata to fail" + +testEncryptInteropLegacyProducesSEIPDv1 :: Assertion +testEncryptInteropLegacyProducesSEIPDv1 = do + (recipient, privateKey) <- loadUnencryptedRsaSigner + let iv = IV (B.replicate 16 0xAB) + payload = "legacy interop payload" + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape + , recipientEncryptRequestPayload = payload + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = Just iv + } + } + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + })) + passphraseCallback _ = pure BL.empty + result <- encryptForRecipients request + packets <- + case result of + Left err -> + assertFailure + ("Expected EncryptInteropLegacy request to succeed, got " ++ show err) >> + fail "encryptForRecipients failed" + Right RecipientEncryptResult { recipientEncryptPackets = ps } -> pure ps + let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] + case seipdPkts of + [SEIPD1 1 _] -> pure () + [SEIPD2 {}] -> assertFailure "Expected SEIPDv1 but got SEIPDv2" + other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) + let pkeskPkts = [p | PKESKPkt p <- packets] + assertBool "EncryptInteropLegacy should emit PKESKv3 packets" $ + all (\p -> case p of { PKESKPayloadV3Packet {} -> True; _ -> False }) pkeskPkts + decrypted <- + DC.runConduitRes $ + CL.sourceList packets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "decrypted legacy interop payload matches original" + (BL.fromStrict payload) + gotPayload + other -> + assertFailure ("Expected [LiteralData] from legacy decrypt, got " ++ show other) + +testCanonicalizePKESKRecipientIdHelper :: Assertion +testCanonicalizePKESKRecipientIdHelper = do + let rid = BL.pack (0x04 : replicate 20 0x11) + payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") + case canonicalizePKESKRecipientId payload of + Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) + | BL.length normalized == 20 -> pure () + | otherwise -> + assertFailure ("Expected canonicalized recipient id length 20, got " ++ show (BL.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 (BL.replicate 19 0x22) RSA "esk")) of + Left (InvalidRecipientIdentifier _) -> pure () + other -> + assertFailure ("Expected InvalidRecipientIdentifier for malformed rid, got " ++ show other) + case canonicalizePKESKRecipientId (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.pack (0x06 : replicate 32 0x33)) RSA "esk")) of + Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) + | BL.length normalized == 32 -> pure () + | otherwise -> + assertFailure ("Expected canonicalized v6 recipient id length 32, got " ++ show (BL.length normalized)) + other -> + assertFailure ("Expected 0x06-prefixed v6 recipient id to canonicalize, got " ++ show other) + case canonicalizePKESKRecipientId (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.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 = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) + sessionKey = SessionKey (B.replicate 32 0x19) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case result of + Left (UnsupportedRecipientAlgorithm EdDSA) -> pure () + Left err -> + assertFailure ("Expected UnsupportedRecipientAlgorithm EdDSA, got " ++ show err) + Right payload -> + assertFailure ("Expected UnsupportedRecipientAlgorithm, got payload: " ++ show payload) + +testBuildPKESKPayloadRejectsECDHSHA1 :: Assertion +testBuildPKESKPayloadRejectsECDHSHA1 = do + (recipientPub, _) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA1 AES256) + sessionKey = SessionKey (B.replicate 32 0x19) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case result of + Left (RecipientKdfFailure ECDH err) + | "SHA1 is disallowed by policy" `isInfixOf` err -> pure () + | otherwise -> + assertFailure + ("Expected SHA1 policy rejection in RecipientKdfFailure, got: " ++ err) + Left err -> + assertFailure ("Expected RecipientKdfFailure ECDH for SHA1, got " ++ show err) + Right payload -> + assertFailure ("Expected SHA1 policy rejection, got payload: " ++ show payload) + +testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey :: Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey = do + armoredMessage <- readFixtureStrict "seipdv2.pgp.aa" + armoredEncryptedSecret <- readFixtureStrict "v6-encrypted-secret.pgp.aa" + armoredPlainSecret <- readFixtureStrict "v6-secret.pgp.aa" + passphrase <- readPKIPassphrase + messageArmors <- + case (AA.decode armoredMessage :: Either String [Armor]) of + Left err -> assertFailure ("failed to decode seipdv2 armor: " ++ err) >> pure [] + Right as -> pure as + encryptedSecretArmors <- + case (AA.decode armoredEncryptedSecret :: Either String [Armor]) of + Left err -> + assertFailure ("failed to decode v6 encrypted secret armor: " ++ err) >> pure [] + Right as -> pure as + plainSecretArmors <- + case (AA.decode armoredPlainSecret :: Either String [Armor]) of + Left err -> + assertFailure ("failed to decode v6 plain secret armor: " ++ err) >> pure [] + Right as -> pure as + messageBody <- + case messageArmors of + (a:_) -> pure (armorPayload a) + [] -> assertFailure "seipdv2 armor file contained no armor blocks" >> pure mempty + encryptedSecretBody <- + case encryptedSecretArmors of + (a:_) -> pure (armorPayload a) + [] -> + assertFailure "v6-encrypted-secret armor file contained no armor blocks" >> + pure mempty + plainSecretBody <- + case plainSecretArmors of + (a:_) -> pure (armorPayload a) + [] -> + assertFailure "v6-secret armor file contained no armor blocks" >> + pure mempty + let messagePackets = parsePkts messageBody + encryptedSecretPackets = parsePkts encryptedSecretBody + plainSecretPackets = parsePkts plainSecretBody + passphraseCallback _ = pure BL.empty + encryptedKeyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + plainKeyInfos <- collectSecretKeyInfos plainSecretPackets passphrase + let allKeyInfos = encryptedKeyInfos ++ plainKeyInfos + keyContextCallback pkt = pure (selectRecipientKeyInfo pkt allKeyInfos) + recipientKeyInfo = + case [pkt | pkt@(PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) <- messagePackets] of + (pkt:_) -> selectRecipientKeyInfo pkt allKeyInfos + [] -> listToMaybe allKeyInfos + case recipientKeyInfo of + Nothing -> + assertFailure + ("no usable secret key material found in v6-encrypted-secret fixture: " ++ + show + ([(_pkalgo pkp, ska) | SecretKeyPkt pkp ska <- encryptedSecretPackets] ++ + [(_pkalgo pkp, ska) | SecretSubkeyPkt pkp ska <- encryptedSecretPackets])) + Just _ -> do + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload:_) -> + if BL.null payload + then assertFailure "fixture decrypt produced empty literal payload" + else pure () + [] -> + assertFailure + ("expected decrypted literal payload from seipdv2 fixture, got: " ++ + show decrypted) + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey :: Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey = do + (messagePackets, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let + passphraseCallback _ = pure BL.empty + keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload:_) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ("unexpected decrypted payload for seipdv2-for-v4-key fixture: " ++ + show payload) + [] -> + assertFailure + ("expected decrypted literal payload from seipdv2-for-v4-key fixture, got: " ++ + show decrypted) + +testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK :: Assertion +testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK = do + (messagePackets, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let + bogusRid = BL.pack (0x06 : replicate 32 0x99) + bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) + (eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets + packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix + passphraseCallback _ = pure BL.empty + keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList packetsWithBogusLatestPKESK DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload:_) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ("unexpected decrypted payload for seipdv2-for-v4-key fixture with bogus latest PKESK: " ++ + show payload) + [] -> + assertFailure + ("expected decrypted literal payload with bogus latest PKESK, got: " ++ + show decrypted) + + +testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations :: Assertion +testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations = do + (messagePacketsRaw, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw + passphraseCallback _ = pure BL.empty + keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload:_) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ("unexpected decrypted payload for recipient-id normalization fixture: " ++ + show payload) + [] -> + assertFailure + ("expected decrypted literal payload for recipient-id normalization fixture, got: " ++ + show decrypted) + +testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial :: Assertion +testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial = do + armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" + armor <- + case armors of + (a:_) -> pure a + [] -> + assertFailure "seipdv2-for-v4-key.pgp.aa should contain one armored payload" >> + fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + keyContextCallback _ = pure Nothing + passphraseCallback prompt = + fail ("unexpected manual PKESK session key prompt: " ++ prompt) + result <- + catch + (Right <$> (DC.runConduitRes $ CL.sourceList packets DC..| conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> do + assertBool + "failure should report PKESK candidate exhaustion" + ("no matching key context" `isInfixOf` err) + assertBool + "failure should not request manual PKESK session material" + (not ("unexpected manual PKESK session key prompt" `isInfixOf` err)) + Right decrypted -> + assertFailure + ("expected decryption failure when no PKESK key context is available, got: " ++ + show decrypted) + +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey :: Assertion +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-two-recipients.pgp.aa" + id + +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey :: Assertion +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-three-recipients.pgp.aa" + id + +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs :: Assertion +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-two-recipients.pgp.aa" + (prependUnusableLatestPKESK . reorderPrecedingPKESKs) + +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs :: Assertion +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-three-recipients.pgp.aa" + (prependUnusableLatestPKESK . reorderPrecedingPKESKs) + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile :: FilePath -> Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile fixture = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + fixture + id + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform :: + FilePath + -> ([Pkt] -> [Pkt]) + -> Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform fixture transformPackets = do + (messagePacketsRaw, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret fixture + let messagePackets = transformPackets messagePacketsRaw + passphraseCallback _ = pure BL.empty + keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload:_) -> + if BL.null payload + then assertFailure (fixture ++ " decrypt produced empty literal payload") + else pure () + [] -> + assertFailure + ("expected decrypted literal payload from " ++ fixture ++ ", got: " ++ + show decrypted) + +testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey :: Assertion +testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey = do + let sessionKey = B.replicate 32 0x2a + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "v6 pkesk session key decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + packets ct = + [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 "\x01\x02\x03\x04\x05\x06\x07\x08" RSA "\x99\x88\x77")) + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + callback _ = pure (BL.fromStrict sessionKey) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList (packets ciphertext) DC..| conduitDecrypt callback DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv6 raw session-key decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength :: Assertion +testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength = do + let sessionKey = B.replicate 32 0x2a + badSessionKey = B.replicate 31 0x2a + salt = Salt (B.pack [0x00 .. 0x1f]) + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "payload"] + packets ct = + [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 "\x10\x11\x12\x13\x14\x15\x16\x17" RSA "\x01\x02\x03")) + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + callback _ = pure (BL.fromStrict badSessionKey) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + (DC.runConduitRes $ + CL.sourceList (packets ciphertext) DC..| conduitDecrypt callback DC..| CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + if "PKESK raw session key length does not match payload algorithm" `isInfixOf` err + then return () + else + assertFailure + ("Expected PKESKv6 raw session-key length validation failure, got: " ++ err) + Right got -> + assertFailure + ("Expected PKESKv6 raw session-key length failure, got packets: " ++ show got) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrap = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + publicKey <- + case _pubkey baseRecipient of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ("unencrypted.seckey did not contain an RSA recipient, got " ++ show other) >> + fail "expected RSA recipient" + let sessionKey = B.replicate 32 0x2b + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = do + let msk = Just (RSAPrivateKey (RSA_PrivateKey privateKey)) + pure $ + fmap + (\sk -> + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = sk + }) + msk + encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []))) + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK RSA unwrap decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + publicKey <- + case _pubkey baseRecipient of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ("unencrypted.seckey did not contain an RSA recipient, got " ++ show other) >> + fail "expected RSA recipient" + let sessionKey = B.replicate 32 0x2e + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap decrypt path via wildcard callback fallback" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback pkt = + case pkt of + PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) + | BL.length rid == 8 && BL.all (== 0) rid -> + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = + RSAPrivateKey (RSA_PrivateKey privateKey) + })) + _ -> pure Nothing + encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\xaa\xbb\xcc\xdd\xee\xff\x00\x11") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []))) + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK RSA unwrap via wildcard callback fallback payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey = do + passphrase <- readPKIPassphrase + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| + CL.consume + keyInfos <- collectSecretKeyInfos secretPackets passphrase + keyInfo <- + case keyInfos of + (ki:_) -> pure ki + [] -> + assertFailure + "aes256-sha512.seckey should yield at least one RSA key context" >> + fail "expected key info" + publicKey <- + case pkeskRecipientPKPayload keyInfo of + Nothing -> + assertFailure "key info from file should include a public key payload" >> + fail "expected public key payload" + Just pkp -> + case _pubkey pkp of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ("expected RSA public key from aes256-sha512.seckey, got " ++ show other) >> + fail "expected RSA public key" + let sessionKey = B.replicate 32 0x42 + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap via sha1-cfb protected key loaded from file" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> + assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []))) + decrypted <- + DC.runConduitRes $ + CL.sourceList + [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK RSA unwrap with SHA1-CFB protected key from file" + payload + gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKECDHUnwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKECDHUnwrap = do + (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + sharedSecret = + BA.convert + (ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub)) :: B.ByteString + kdfParam = + buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES128 + kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh unwrap decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK ECDH unwrap decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength :: Assertion +testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength = do + (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + sharedSecret = + BA.convert + (ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub)) :: B.ByteString + kdfParam = + buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES128 + kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + truncatedEphemeral = B.take (B.length ephPointBytes - 1) ephPointBytes + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip truncatedEphemeral) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh wrong ephemeral point length" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + DC.runConduitRes + (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "ECDH unwrap should reject wrong uncompressed point length for recipient curve" + ("invalid length for recipient curve" `isInfixOf` err) + Right packets -> + assertFailure ("Expected ECDH point-length validation failure, got: " ++ show packets) + +testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6a) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 unwrap decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK X25519 v3 unwrap decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + + +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder :: Assertion +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongRecipientSecretRaw = B.pack [0x61 .. 0x80] + wrongRecipientSecret = + case CE.eitherCryptoError (C25519.secretKey wrongRecipientSecretRaw) of + Left err -> error ("failed to initialize wrong X25519 recipient secret key: " ++ show err) + Right sk -> sk + wrongRecipientPublicRaw = BA.convert (C25519.toPublic wrongRecipientSecret) :: B.ByteString + wrongRecipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongRecipientPublicRaw)))) + wrongRecipientSKey = X25519PrivateKey wrongRecipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6b) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wildcard key-id retry path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just wrongRecipientPKP + , pkeskRecipientSKey = wrongRecipientSKey + } + correctKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + keyContextCallback _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 wildcard-keyid retries across recipient key order" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + + +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder :: Assertion +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6c) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wildcard key-id long retry path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + mkSecretBytes offset = + B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] + mkX25519RecipientKeyInfo label secretRaw = + let sk = + case CE.eitherCryptoError (C25519.secretKey secretRaw) of + Left err -> error ("failed to initialize " ++ label ++ " X25519 secret key: " ++ show err) + Right secretKey -> secretKey + publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString + in PKESKRecipientKey + { pkeskRecipientPKPayload = + Just + (PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicRaw))))) + , pkeskRecipientSKey = X25519PrivateKey secretRaw + } + wrongKeyInfos = + [ mkX25519RecipientKeyInfo ("wrong-" ++ show n) (mkSecretBytes (96 + n * 7)) + | n <- [1 .. 20 :: Int] + ] + correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw + keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 wildcard-keyid retries long recipient key order" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + + +testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder :: Assertion +testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6d) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + payload = "pkesk x25519 v3 wildcard key-id long retry legacy seipd1 path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + cleartext = BL.toStrict (runPut (put literalBlock)) + iv = IV (B.pack [0x33 .. 0x42]) + cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext + passphraseCallback _ = pure BL.empty + mkSecretBytes offset = + B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] + mkX25519RecipientKeyInfo label secretRaw = + let sk = + case CE.eitherCryptoError (C25519.secretKey secretRaw) of + Left err -> error ("failed to initialize " ++ label ++ " X25519 secret key: " ++ show err) + Right secretKey -> secretKey + publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString + in PKESKRecipientKey + { pkeskRecipientPKPayload = + Just + (PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicRaw))))) + , pkeskRecipientSKey = X25519PrivateKey secretRaw + } + wrongKeyInfos = + [ mkX25519RecipientKeyInfo ("wrong-" ++ show n) (mkSecretBytes (96 + n * 7)) + | n <- [1 .. 20 :: Int] + ] + correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw + keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) + ciphertext <- + either + (\e -> assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) >> pure mempty) + pure + (encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW AES256 iv cleartextWithMDC (unSessionKey sessionKey)) + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESKv3 wildcard-keyid retries long recipient key order for SEIPDv1" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + + +testMkCandidateResolverDecryptsWildcardPKESKv3 :: Assertion +testMkCandidateResolverDecryptsWildcardPKESKv3 = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6d) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "unwrap callback wildcard path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} + correctKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + (void $ + DCD.conduitDecrypt + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + }) DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "unwrap callback should decrypt wildcard PKESK via candidate list" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + + +testConduitDecryptWildcardResolverProvidesTypedPreviousFailures :: Assertion +testConduitDecryptWildcardResolverProvidesTypedPreviousFailures = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6e) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "typed previous failures for wildcard retries" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} + correctKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + (void $ + DCD.conduitDecrypt + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + }) DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "wildcard retries with typed previous failures should still decrypt" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + pure () + + +testConduitDecryptWithReportCapturesWildcardResolverDiagnostics :: Assertion +testConduitDecryptWithReportCapturesWildcardResolverDiagnostics = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6f) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "conduitDecryptWithReport wildcard diagnostics" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} + correctKeyInfo = + PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + (report, decrypted) <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + DC.fuseBoth + (DCD.conduitDecryptWithReport + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + }) + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "wildcard retries with report diagnostics should decrypt" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + assertEqual "decrypt report should preserve outcome" DCD.DecryptClean (DCD.decryptReportOutcome report) + case DCD.decryptReportSessionKeyResolutions report of + [resolution] -> do + assertEqual "resolution path should be PKESK for wildcard key retries" DCD.DecryptResolvedViaPKESK (DCD.decryptSessionResolutionPath resolution) + let attempts = DCD.decryptSessionResolutionResolverAttempts resolution + assertBool + "report should contain wildcard resolver attempts" + (length attempts >= 2) + assertBool + "report should record typed previous failures in resolver attempt context" + (any + (\attempt -> + any + (\failure -> + DCD.pkeskAttemptFailureKind failure == DCD.PKESKAttemptUnwrapFailed && + DCD.pkeskAttemptFailureKeyContext failure == Just (V4, X25519)) + (DCD.pkeskResolverAttemptPreviousFailures attempt)) + attempts) + assertBool + "report should capture ResolveWith key context for X25519" + (any + (\attempt -> + DCD.pkeskResolverAttemptAction attempt == + DCD.ResolverAttemptResolveWith (Just (V4, X25519))) + attempts) + other -> + assertFailure + ("Expected exactly one session-key resolution report, got " ++ show (length other)) + +testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength :: Assertion +testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6a) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + overlongEphemeral = ephPublicRaw <> "\x00\x01" + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip overlongEphemeral) :| [MPI (os2ip eskWithAlgo)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wrong ephemeral length" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + DC.runConduitRes + (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "PKESKv3 X25519 unwrap should reject non-32-byte ephemeral values" + ("invalid X25519 ephemeral public key length/prefix" `isInfixOf` err) + Right packets -> + assertFailure + ("Expected X25519 ephemeral-length validation failure, got: " ++ show packets) + +testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 :: Assertion +testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret + sessionKeyBytes = B.replicate 32 0x6a + sessionKey = SessionKey sessionKeyBytes + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek sessionKeyBytes + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) + skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 21 + skeskPassphrase = "correct horse battery staple" + wrongPassphrase = "wrong passphrase" + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "skesk->pkesk fallback decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + passphraseCallback _ = pure wrongPassphrase + keyLen <- + case keySize AES256 of + Left err -> assertFailure ("keySize failed for AES256: " ++ show err) >> fail "keySize failed" + Right n -> pure n + skeskKek <- + case string2Key skeskS2K keyLen skeskPassphrase of + Left err -> assertFailure ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) >> fail "string2Key failed" + Right x -> pure x + skeskEncryptedEsk <- + case withSymmetricCipher AES256 skeskKek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + (B.singleton (fromFVal AES256) <> sessionKeyBytes) of + Left err -> assertFailure ("encrypting Argon2 SKESK ESK failed: " ++ show err) >> fail "encrypting SKESK ESK failed" + Right x -> pure x + let skesk = + SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict skeskEncryptedEsk)))) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ skesk + , pkesk + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "conduitDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519" + payload + gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK :: Assertion +testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK = do + let skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 21 + passphrase = "password" + sessionKeyBytes = B.replicate 32 0x7b + sessionKey = SessionKey sessionKeyBytes + badLatestEsk = BL.fromStrict (B.pack [0x00]) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "earlier argon2 skesk fallback decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure passphrase + keyLen <- + case keySize AES256 of + Left err -> assertFailure ("keySize failed for AES256: " ++ show err) >> fail "keySize failed" + Right n -> pure n + skeskKek <- + case string2Key skeskS2K keyLen passphrase of + Left err -> assertFailure ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) >> fail "string2Key failed" + Right x -> pure x + validEsk <- + case withSymmetricCipher AES256 skeskKek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + (B.singleton (fromFVal AES256) <> sessionKeyBytes) of + Left err -> assertFailure ("encrypting Argon2 SKESK ESK failed: " ++ show err) >> fail "encrypting SKESK ESK failed" + Right x -> pure x + let earlierValidSKESK = + SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict validEsk)))) + latestUnusableSKESK = + SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 AES256 skeskS2K (Just badLatestEsk))) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ earlierValidSKESK + , latestUnusableSKESK + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "conduitDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable" + payload + gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsECDHNonTable30Params :: Assertion +testConduitDecryptSEIPDv2RejectsECDHNonTable30Params = do + (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1) + let recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES256) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + sharedSecret = + BA.convert + (ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub)) :: B.ByteString + kdfParam = + buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh unwrap policy failure path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + DC.runConduitRes + (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "ECDH unwrap should reject non-Table-30 parameters" + ("Table 30 policy violation" `isInfixOf` err) + Right packets -> + assertFailure + ("Expected Table 30 policy failure, got decrypted packets: " ++ show packets) + +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams :: Assertion +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) + SHA256 + AES256) + recipientSKey = + ECDHPrivateKey + (ECDSA_PrivateKey + (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) + sessionKey = B.replicate 32 0x3d + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString + kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA256 AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v4 curve25519legacy accepted-combo path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "v4 Curve25519Legacy ECDH should allow RFC6637-accepted parameters" + payload + gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI :: Assertion +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) + SHA256 + AES256) + recipientSKey = + ECDHPrivateKey + (ECDSA_PrivateKey + (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) + sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString + kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA256 AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + candidate = + find + (\(_, wrappedSession) -> not (B.null wrappedSession) && B.head wrappedSession == 0x00) + [ let sessionKeyBytes = + B.pack + [ fromIntegral ((seed + offset) `mod` 256) + | offset <- [0 .. 31] + ] + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKeyBytes <> + encodeChecksum16 sessionKeyBytes <> + B.replicate 5 0 + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + in (SessionKey sessionKeyBytes, wrappedSession) + | seed <- [0 .. 4095 :: Int] + ] + case candidate of + Nothing -> + assertFailure + "failed to find deterministic Curve25519Legacy wrapped session key with leading zero" + Just (sessionKey, wrappedSession) -> do + let pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v4 curve25519legacy truncated wrapped-mpi path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "v4 Curve25519Legacy ECDH should unwrap after wrapped-MPI leading-zero truncation" + payload + gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params :: Assertion +testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + (ECDHPubKey + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + SHA512 + AES256) + recipientSKey = + ECDHPrivateKey + (ECDSA_PrivateKey + (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) + sessionKey = B.replicate 32 0x3d + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString + kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA512 AES256 + kek = deriveECDHKekForTest SHA512 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + pkesk = + PKESKPkt + (PKESKPayloadV3Packet + (PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v6 curve25519legacy strict path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + })) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + DC.runConduitRes + (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| + CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "v6 Curve25519Legacy ECDH should remain strict" + ("Table 30 policy violation" `isInfixOf` err) + Right packets -> + assertFailure + ("Expected Table 30 policy failure, got decrypted packets: " ++ show packets) + +testConduitDecryptSEIPDv2WithPKESKX448Unwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKX448Unwrap = do + let recipientSecretRaw = B.pack [1 .. 56] + ephSecretRaw = B.pack [57 .. 112] + sessionKey = B.replicate 32 0x4d + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X448 ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString + kek = deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + esk = + ephPublicRaw <> + B.singleton (fromIntegral (B.length wrappedSession)) <> + wrappedSession + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientRid = unFingerprint (fingerprint recipientPKP) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x448 unwrap decrypt path" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw + })) + pkesk = + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK X448 unwrap decrypt payload" payload gotPayload + other -> + assertFailure ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength :: Assertion +testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength = do + let recipientSecretRaw = B.pack [1 .. 56] + ephSecretRaw = B.pack [57 .. 112] + sessionKey = B.replicate 32 0x4d + encodedSession = + B.singleton (fromFVal AES256) <> + sessionKey <> + encodeChecksum16 sessionKey <> + B.replicate 5 0 + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of + Left err -> error ("failed to initialize X448 ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString + shortEphemeral = B.tail ephPublicRaw + sharedSecret = BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString + kek = deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + esk = + shortEphemeral <> + B.singleton (fromIntegral (B.length wrappedSession)) <> + wrappedSession + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) + recipientRid = unFingerprint (fingerprint recipientPKP) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x448 wrong ephemeral length" + literalBlock = + Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + (Just + (PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw + })) + pkesk = + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))) + ciphertext <- + case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of + Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty + Right ct -> pure ct + result <- + catch + (Right <$> + DC.runConduitRes + (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume)) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "PKESKv6 X448 unwrap should reject non-56-byte ephemeral values" + ("expected 56-octet ephemeral value" `isInfixOf` err) + Right packets -> + assertFailure + ("Expected X448 ephemeral-length validation failure, got: " ++ show packets) + +testDecodeOpenPGPEncodedSessionKeyRejectsTooShort :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsTooShort = + assertEqual + "encoded session key should reject too-short payloads" + (Left EncodedSessionKeyTooShort) + (decodeOpenPGPEncodedSessionKey (B.pack [0x09, 0x01])) + +testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch = + assertEqual + "encoded session key should reject algorithm/key-length mismatches" + (Left (EncodedSessionKeyLengthMismatch AES128 16 3)) + (decodeOpenPGPEncodedSessionKey (B.pack [fromFVal AES128, 0x01, 0x02, 0x03])) + +testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch = + assertEqual + "encoded session key should reject checksum mismatches" + (Left EncodedSessionKeyChecksumMismatch) + (decodeOpenPGPEncodedSessionKey (B.pack ([fromFVal AES128] <> replicate 16 0x00 <> [0x00, 0x01]))) + +testSKESKRejectsUnknownVersion :: Assertion +testSKESKRejectsUnknownVersion = do + let s2k = Simple SHA256 + pkt = SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing)) + encoded = BL.toStrict (runPut (put pkt)) + malformed = BL.fromStrict (B.take 2 encoded <> B.singleton 5 <> B.drop 3 encoded) + case runGet (get :: Get Pkt) malformed of + Right (BrokenPacketPkt errReason 3 _) -> + assertBool + ("expected unsupported SKESK version error, got: " ++ errReason) + ("unsupported SKESK packet version" `isInfixOf` errReason) + Right other -> + assertFailure ("unknown SKESK version should not parse successfully: " ++ show other) + Left err -> + assertFailure ("unknown SKESK version should be reported as a broken packet: " ++ err) + +testSKESK4EncryptedSessionKeyRejectsSimpleS2K :: Assertion +testSKESK4EncryptedSessionKeyRejectsSimpleS2K = do + let pkt = + SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 AES128 (Simple SHA256) (Just (BL.pack [0x01, 0x02, 0x03])))) + encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right (BrokenPacketPkt errReason 3 _) -> + assertBool + ("expected Simple S2K rejection, got: " ++ errReason) + ("must not use Simple S2K" `isInfixOf` errReason) + Right other -> + assertFailure + ("Simple-S2K v4 SKESK with encrypted session key should not parse successfully: " ++ + show other) + Left err -> + assertFailure + ("Simple-S2K v4 SKESK with encrypted session key should be reported as a broken packet: " ++ + err) + +testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES :: Assertion +testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES = + mapM_ assertRoundTrip [AES128, AES192, AES256] + where + passphrase = "password" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 21 + assertRoundTrip sa = do + keyLen <- + case keySize sa of + Left err -> assertFailure ("keySize failed for " ++ show sa ++ ": " ++ show err) >> fail "keySize failed" + Right n -> pure n + kek <- + case string2Key s2k keyLen passphrase of + Left err -> + assertFailure ("string2Key failed for " ++ show sa ++ ": " ++ renderS2KError err) >> + fail "string2Key failed" + Right x -> pure x + let sessionKey = B.pack (take keyLen (cycle [0x11, 0x22, 0x33, 0x44])) + encodedSessionKey = B.singleton (fromFVal sa) <> sessionKey + encryptedEsk <- + case withSymmetricCipher sa kek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + encodedSessionKey of + Left err -> + assertFailure ("encrypting SKESK v4 ESK failed for " ++ show sa ++ ": " ++ show err) >> + fail "encrypting SKESK v4 ESK failed" + Right x -> pure x + let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) + case skesk2SessionKey skesk passphrase of + Right (decodedAlgo, decodedSessionKey) -> do + assertEqual ("decoded SKESK v4 encrypted ESK algorithm for " ++ show sa) sa decodedAlgo + assertEqual ("decoded SKESK v4 encrypted ESK session key for " ++ show sa) sessionKey decodedSessionKey + Left err -> + assertFailure + ("decoding SKESK v4 encrypted ESK failed for " ++ + show sa ++ ": " ++ renderS2KError err) + +testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum :: Assertion +testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum = do + let sa = AES128 + passphrase = "password" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 21 + sessionKey = B.pack (take 16 (cycle [0xaa, 0xbb, 0xcc, 0xdd])) + keyLen <- + case keySize sa of + Left err -> assertFailure ("keySize failed: " ++ show err) >> fail "keySize failed" + Right n -> pure n + kek <- + case string2Key s2k keyLen passphrase of + Left err -> assertFailure ("string2Key failed: " ++ renderS2KError err) >> fail "string2Key failed" + Right x -> pure x + let encodedWithChecksum = + B.singleton (fromFVal sa) <> sessionKey <> encodeChecksum16 sessionKey + encryptedEsk <- + case withSymmetricCipher sa kek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + encodedWithChecksum of + Left err -> + assertFailure ("encrypting malformed SKESK v4 ESK failed: " ++ show err) >> + fail "encrypting malformed SKESK v4 ESK failed" + Right x -> pure x + let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) + case skesk2SessionKey skesk passphrase of + Left (S2KEncryptedSessionKeyDecodeError (EncodedSessionKeyLengthMismatch AES128 16 18)) -> pure () + Left err -> + assertFailure + ("expected SKESK v4 trailing-checksum rejection, got: " ++ + renderS2KError err) + Right _ -> + assertFailure "expected SKESK v4 trailing-checksum rejection, but decode succeeded" + +testArgon2S2KVector :: Assertion +testArgon2S2KVector = do + let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + pass = BLC8.pack "password" + derivedKeyResult = string2Key s2k 16 pass + derivedKey <- + case derivedKeyResult of + Left err -> + assertFailure ("Argon2 S2K key derivation failed: " ++ renderS2KError err) >> + fail "Argon2 key derivation failed" + Right x -> pure x + let + hex = map toUpper . BLC8.unpack . B16L.encode . BL.fromStrict $ derivedKey + assertEqual + "Argon2 S2K key derivation vector" + "A3BDFE3814D790F1F366ABA6954EB386" + hex + +testArgon2S2KOrdTotal :: Assertion +testArgon2S2KOrdTotal = do + let argon2A = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + argon2B = Argon2 (Salt16 (B.pack [0x01 .. 0x10])) 1 4 15 + assertEqual + "Argon2 S2K compares after simple S2K" + GT + (compare argon2A (Simple SHA256)) + assertEqual + "Argon2 S2K compares before unknown S2K types" + LT + (compare argon2A (OtherS2K 101 BL.empty)) + assertEqual + "Argon2 S2K constructor compares lexicographically by fields" + LT + (compare argon2A argon2B) diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Keys.hs @@ -0,0 +1,1677 @@ +-- Keys.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.Keys (keyAndVerificationTests) where + +import Codec.Encryption.OpenPGP.Expirations + ( effectiveKeyPreferencesAtTimestamp + , effectiveUIDPreferencesAtTimestamp + , isTKTimeValid + ) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal + ( emptyPSC + , lastPrimaryKey + , lastSubkey + ) +import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize) +import Codec.Encryption.OpenPGP.Message + ( asV6PKPayload + , mkEd25519SignerV6 + , mkRSASignerV6 + ) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPRFC(..) + , isAllowedPrimaryKeySig + , isAllowedSubkeySig + , isAllowedUIDSig + ) +import Codec.Encryption.OpenPGP.SecretKey + ( changePrivateKeyPassphrase + , decryptPrivateKey + ) +import Codec.Encryption.OpenPGP.Serialize + ( getSecretKey + , parsePkts + ) +import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) +import Codec.Encryption.OpenPGP.Signatures +import Codec.Encryption.OpenPGP.Subpackets + ( sigBuilderInit + , sigBuilderInitRuntime + , sigBuilderInitV6 + , sigBuilderInitV6Runtime + , addHashedSubs + , addUnhashedSubs + , LegalSubpacket(..) + , listToHashedSubs + , listToUnhashedSubs + , listToLegalSubs + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Control.Error.Util (isRight) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Data.Bifunctor (first) +import Data.Binary (get, put) +import Data.Binary.Get (Get, runGetOrFail) +import Data.Binary.Put (runPut) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Keyring (conduitToUnknownTKs) +import Data.Conduit.OpenPGP.Verify (conduitVerify) +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.IxSet.Typed ((@=), getOne, size) +import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (isJust) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Prettyprinter (pretty) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Tests.Common + ( assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , loadAndDecompressPkts + , messageIssuerSubpacketsAt + , addTimestampSeconds + , armorPayload + , assertFalse + , assertTrue + , certificateVerificationFixtures + , fixturePath + , loadArmor + , loadDeterministicEd25519Signer + , loadKeyring + , loadUnencryptedRsaSigner + , messageVerificationFixtures + , mkTestKeyring + , readFixturePayload + , readPKIPassphrase + , runGet + , setKeyVersion + , signBinaryMessageWithRSAAt + , signCertificationAt + , signCertificationRevocationAt + , signCertificationRevocationWithEd25519At + , signCertificationWithEd25519At + , signSubkeyBindingWithRSAExtrasAt + , timestampToUTCTime + , verificationFixtureGroup + , verifyMessageFromBytestring + , verifyMessageFromBytestringBatch + , verifyMessageFromPackets + , verifyMessageFromPacketsBatch + , verifyTimelinePackets + ) + + +keyAndVerificationTests :: TestTree +keyAndVerificationTests = + testGroup + "Keys and verification" + [ testGroup + "PKA/Size/KeyID/fingerprint group" + [ testCase + "v3 key" + (testPKAandSizeAndKeyIDandFingerprint + "v3.key" + "rsa/1024:6DC580F5C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") + , testCase + "v4 key" + (testPKAandSizeAndKeyIDandFingerprint + "000001-006.public_key" + "rsa/1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") + , testCase + "ECDSA key" + (testPKAandSizeAndKeyIDandFingerprint + "nist_p-256_key.gpg" + "ecd/256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224") + , testCase + "EdDSA key" + (testPKAandSizeAndKeyIDandFingerprint + "sample-eddsa.pubkey" + "edd/256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A") + , testCase + "EdDSA secret key (projected to public key packet)" + (testPKAandSizeAndKeyIDandFingerprint + "ed25519.secretkey" + "edd/256:B05F9287601D5914/B6FE 0C23 12EB D832 0238 C252 B05F 9287 601D 5914") + , testCase + "v6 secret key (projected to public key packet)" + (testPKAandSizeAndKeyIDandFingerprint + "v6-secret.pgp.aa" + "e25/256:7106CB6DB27E4FC9/7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19") + ] + , testGroup + "Keyring group" + [ testCase + "pubring 7732CF988A63EA86" + (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) + , testCase + "pubring 123456789ABCDEF0" + (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False) + , testCase + "pubsub AD992E9C24399832" + (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) + , testCase + "secring 7732CF988A63EA86" + (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) + , testCase + "secring 123456789ABCDEF0" + (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) + , testCase + "secsub AD992E9C24399832" + (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) + , testCase "pubring.gpg has 4 keys" (testKeyringSize "pubring.gpg" 4) + , testCase "secring.gpg has 4 keys" (testKeyringSize "secring.gpg" 4) + ] + , verificationFixtureGroup + "Message verification group (packet-based)" + verifyMessageFromPackets + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (packet-based, batch)" + verifyMessageFromPacketsBatch + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (bytestring-based)" + verifyMessageFromBytestring + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (bytestring-based, batch)" + verifyMessageFromBytestringBatch + messageVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (packet-based)" + verifyMessageFromPackets + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (packet-based, batch)" + verifyMessageFromPacketsBatch + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (bytestring-based)" + verifyMessageFromBytestring + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (bytestring-based, batch)" + verifyMessageFromBytestringBatch + certificateVerificationFixtures + , testGroup + "Key verification group" + [ testCase + "6F87040E pubkey" + (testKeysSelfVerification True "6F87040E.pubkey") + , testCase + "revoked pubkey" + (testKeysSelfVerification False "revoked.pubkey") + , testCase + "expired pubkey" + (testKeysSelfVerification True "expired.pubkey") + , testCase + "nist_p-256 pubkey" + (testKeysSelfVerification True "nist_p-256_key.gpg") + , testCase + "ed25519 pubkey" + (testKeysSelfVerification True "ed25519.pubkey") + ] + , testGroup + "Verification error messaging group" + [ testCase + "missing signing key in keyring" + (testMissingSigningKeyMessage + "ecdsa-key-without-ecdh.pubkey" + "uncompressed-ops-rsa.gpg") + , testCase + "tampered message signature mismatch" + (testTamperedSignatureMessage "pubring.gpg" "uncompressed-ops-rsa.gpg") + , testCase + "revoked certificate reports revocation" + (testRevokedCertificateMessage "revoked.pubkey") + ] + , testGroup + "Key expiration group" + [ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey") + , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey") + , testCase + "nist_p-256 pubkey" + (testKeysExpiration True "nist_p-256_key.gpg") + , testCase + "ed25519-without-curve25519.pubkey" + (testKeysExpiration True "ed25519-without-curve25519.pubkey") + , testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey") + ] + , testGroup + "misc group" + [ testCase "conduitVerify processes SigV6 packets" testConduitVerifyProcessesSigV6 + , testCase "signature builder API (Phase 2)" testSignatureBuilders + , testCase "typed legal subpacket builder API (P2.1)" testLegalSubpacketBuilders + , testCase + "legacy secret key passphrase changes preserve protection" + testChangePrivateKeyPassphraseLegacy + , testCase "change private key passphrase" testChangePrivateKeyPassphraseV6 + , testCase + "getSecretKey parses v4 X25519 ECDH key material" + testGetSecretKeyHandlesV4X25519ECDHPubkey + , testCase + "v4 Ed25519 secret-key roundtrip preserves leading zero byte" + testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte + , testCase + "v4 Ed448 secret-key roundtrip preserves leading zero byte" + testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte + , testCase "policy signature context validation (RFC9580)" testPolicySignatureContextValidation + , testCase + "temporary validity uses latest effective self-signature window" + testTemporaryKeyValidityRespectsLatestSelfSignature + , testCase + "temporary validity rejects gaps with no effective self-signature" + testTemporaryKeyValidityRejectsSelfSignatureGaps + , testCase + "temporary validity rejects the gap before the first self-signature" + testTemporaryKeyValidityRejectsPreCertificationGap + , testCase + "temporary validity follows temporary self-revocations" + testTemporaryKeyValidityFollowsTemporarySelfRevocation + , testCase + "temporary validity does not revive older self-signatures after newer expiry" + testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures + , testCase + "uid-retired revocation is historical until effective" + testUidRetiredRevocationIsHistorical + , testCase + "third-party certifications do not affect primary key validity windows" + testThirdPartyCertificationDoesNotAffectKeyValidityWindow + , testCase + "certification revocations only remove matching signer certifications" + testCertificationRevocationOnlyRemovesMatchingSigner + , testCase + "preference resolution tracks active self-certification timeline" + testPreferencesAtTimestamp + , testCase + "verifySigWith rejects v6 revocation Issuer key-id subpackets" + testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID + , testCase + "verifySigWith rejects v6 revocation unhashed Issuer key-id subpackets" + testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed + , testCase + "verifySigWith accepts matching v6 revocation IssuerFingerprint" + testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint + , testCase "v6 signer constructor rejects v4 key" testV6SignerConstructorRejectsV4Key + , testCase + "primary key binding rejects unsupported critical hashed subpackets" + testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket + , testCase + "subkey binding missing back-signature is surfaced as a warning" + testSubkeyBindingMissingBackSignatureProducesWarning + , testCase + "subkey binding rejects unsupported critical hashed subpackets" + testSubkeyBindingRejectsUnsupportedCriticalSubpacket + ] + ] + +testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion +testPKAandSizeAndKeyIDandFingerprint fpr kf = do + bs <- readFixturePayload fpr + case runGet (get :: Get Pkt) bs of + Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." + Right pkt -> + case publicKeyPacketOf pkt of + PublicKeyPkt pkp -> do + let pref = + concat + [ pkalgoAbbrev (_pkalgo pkp) + , "/" + , either (const "unknown") show (pubkeySize (_pubkey pkp)) + , ":" + , either (const "unknown") (show . pretty) (eightOctetKeyID pkp) + , "/" + ] + assertEqual + ("for " ++ fpr ++ " (spaceless)") + (spaceless kf) + (pref ++ show (pretty (fingerprint pkp))) + assertEqual + ("for " ++ fpr ++ " (spaced)") + kf + (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) + _ -> assertFailure "Expected (possibly secret) key packet, got something else." + where + spaceless = filter (/= ' ') + +testKeyringLookup :: FilePath -> String -> Bool -> Assertion +testKeyringLookup fpr eok expected = do + kr <- loadKeyring fpr + let foundKey = getOne (kr @= (read eok :: EightOctetKeyId)) + assertEqual (eok ++ " in " ++ fpr) expected (isJust foundKey) + +testKeyringSize :: FilePath -> Int -> Assertion +testKeyringSize fpr expected = do + kr <- loadKeyring fpr + assertEqual ("key count in " ++ fpr) expected (size kr) + +assertLeftContains :: String -> Either VerificationError a -> Assertion +assertLeftContains needle result = + case result of + Left err -> + let rendered = renderVerificationError err + in + if needle `isInfixOf` rendered + then pure () + else + assertFailure + ("Expected error containing '" ++ needle ++ "', got '" ++ rendered ++ "'.") + Right _ -> assertFailure ("Expected Left containing '" ++ needle ++ "', got Right.") + +testMissingSigningKeyMessage :: FilePath -> FilePath -> Assertion +testMissingSigningKeyMessage keyring message = do + kr <- loadKeyring keyring + verification <- + DC.runConduitRes $ + CB.sourceFile (fixturePath message) DC..| conduitGet get DC..| conduitDecompress DC..| + conduitVerify kr Nothing DC..| + CL.consume + case verification of + [] -> assertFailure "Expected at least one verification result." + (firstResult:_) -> + assertLeftContains "signing key not found in keyring" firstResult + +testTamperedSignatureMessage :: FilePath -> FilePath -> Assertion +testTamperedSignatureMessage keyring message = do + kr <- loadKeyring keyring + packets <- loadAndDecompressPkts message + let tamperedPackets = map tamperLiteral packets + verification <- + DC.runConduitRes $ + CL.sourceList tamperedPackets DC..| conduitVerify kr Nothing DC..| CL.consume + case verification of + [] -> assertFailure "Expected at least one verification result." + (firstResult:_) -> + assertLeftContains "signature mismatch" firstResult + where + tamperLiteral (LiteralDataPkt dt fn ts payload) = + LiteralDataPkt dt fn ts (BL.snoc payload 0) + tamperLiteral pkt = pkt + +testRevokedCertificateMessage :: FilePath -> Assertion +testRevokedCertificateMessage keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| conduitToUnknownTKs DC..| + CL.consume + assertLeftContains + "signing key is revoked" + (mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) + +testKeysSelfVerification :: Bool -> FilePath -> Assertion +testKeysSelfVerification expectsuccess keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| + conduitToUnknownTKs DC..| + CL.consume + let verifieds = + mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks + assertEqual + (keyfile ++ " self-verification") + expectsuccess + (isRight verifieds) + +testKeysExpiration :: Bool -> FilePath -> Assertion +testKeysExpiration expectsuccess keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| + conduitToUnknownTKs DC..| + CL.consume + case mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks of + Left err -> + assertFailure + (keyfile ++ " key self-verification failed before expiration check: " ++ + renderVerificationError err) + Right verifieds -> do + let tvalid = + all + (isTKTimeValid + (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) + verifieds + assertEqual (keyfile ++ " key expiration") expectsuccess tvalid + +testConduitVerifyProcessesSigV6 :: Assertion +testConduitVerifyProcessesSigV6 = do + kr <- loadKeyring "pubring.gpg" + let sigPayload = + SigV6 + BinarySig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [] + [] + 0 + (MPI 0 :| []) + packets = + [ LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "payload" + , SignaturePkt sigPayload + ] + verification <- + DC.runConduitRes $ + CL.sourceList packets DC..| conduitVerify kr Nothing DC..| CL.consume + case verification of + [Left _] -> return () + other -> + assertFailure + ("Expected one v6 verification result (failure is fine), got " ++ + show (length other) ++ " results") + +testSubkeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion +testSubkeyBindingRejectsUnsupportedCriticalSubpacket = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySigner, _) <- loadDeterministicEd25519Signer + let creationTime = addTimestampSeconds (_timestamp primarySigner) 10 + (hashed, unhashed) <- messageIssuerSubpacketsAt primarySigner creationTime + let bindingPayload = + payloadForSig + SubkeyBindingSig + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + hashedWithUnsupportedCritical = + SigSubPacket True (OtherSigSub 111 "unsupported-critical") : hashed + keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + sigPayload <- + case signDataWithRSA + SubkeyBindingSig + primarySigningKey + hashedWithUnsupportedCritical + unhashed + bindingPayload of + Left err -> + assertFailure ("failed to sign subkey binding with unsupported critical subpacket: " ++ renderSignError err) >> + fail "expected subkey binding signature" + Right sig -> pure sig + case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of + Left (UnsupportedCriticalSubpacket SubkeyBindingSig) -> pure () + Left err -> + assertFailure + ("Expected unsupported critical subpacket rejection for subkey binding signature, got: " ++ + renderVerificationError err) + Right _ -> + assertFailure + "Expected unsupported critical subpacket rejection for subkey binding signature, but verification succeeded" + +testSubkeyBindingMissingBackSignatureProducesWarning :: Assertion +testSubkeyBindingMissingBackSignatureProducesWarning = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySignerRaw, _) <- loadDeterministicEd25519Signer + let subkeySigner = setKeyVersion V6 subkeySignerRaw + creationTime = addTimestampSeconds (_timestamp primarySigner) 10 + keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + sigPayload <- + signSubkeyBindingWithRSAExtrasAt + primarySigner + subkeySigner + primarySigningKey + creationTime + [SigSubPacket False (KeyFlags (Set.singleton SignDataKey))] + case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of + Left err -> + assertFailure + ("Expected successful verification with warning for missing back-signature, got: " ++ + renderVerificationError err) + Right verification -> + assertBool + "v6 signing-capable subkey binding without embedded back-signature should emit warning" + (MissingSubkeyBackSignatureWarning `elem` _verificationWarnings verification) + +testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion +testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket = do + (signer, _) <- loadUnencryptedRsaSigner + let sigPayload = + SigV4 + PrimaryKeyBindingSig + RSA + SHA256 + [SigSubPacket True (OtherSigSub 111 "unsupported-critical")] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt signer + , lastSubkey = PublicSubkeyPkt signer + } + case verifySigWith verifyFn (SignaturePkt sigPayload) state Nothing of + Left (UnsupportedCriticalSubpacket PrimaryKeyBindingSig) -> pure () + Left err -> + assertFailure + ("Expected unsupported critical subpacket rejection for primary key binding signature, got: " ++ + renderVerificationError err) + Right _ -> + assertFailure + "Expected unsupported critical subpacket rejection for primary key binding signature, but verification succeeded" + +testSignatureBuilders :: Assertion +testSignatureBuilders = do + (_, signingKey) <- loadUnencryptedRsaSigner + -- Test RSA builder API with empty subpackets + let builderRsa = sigBuilderInit @'PKA.RSA BinarySig SHA512 + let builderRsaWithHashed = addHashedSubs (listToHashedSubs []) builderRsa + let builderRsaFinal = addUnhashedSubs (listToUnhashedSubs []) builderRsaWithHashed + case signDataWithRSABuilder builderRsaFinal signingKey "test payload" of + Left err -> assertFailure ("RSA builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure ("RSA builder API should generate BinarySig RSA SHA512, got " ++ show other) + + -- Test RSA builder API with non-default hash algorithm + let builderRsaSha256 = sigBuilderInit @'PKA.RSA BinarySig SHA256 + builderRsaSha256WithHashed = + addHashedSubs (listToHashedSubs []) builderRsaSha256 + builderRsaSha256Final = + addUnhashedSubs (listToUnhashedSubs []) builderRsaSha256WithHashed + case signDataWithRSABuilder builderRsaSha256Final signingKey "test payload" of + Left err -> + assertFailure ("RSA SHA256 builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig RSA SHA256 _ _ _ _) -> + pure () + Right other -> + assertFailure ("RSA builder API should generate BinarySig RSA SHA256, got " ++ show other) + + -- Unsupported hash algorithms should be rejected by RSA PKCS#1 v1.5 backend + let builderRsaUnsupported = sigBuilderInit @'PKA.RSA BinarySig (OtherHA 99) + builderRsaUnsupportedWithHashed = + addHashedSubs (listToHashedSubs []) builderRsaUnsupported + builderRsaUnsupportedFinal = + addUnhashedSubs (listToUnhashedSubs []) builderRsaUnsupportedWithHashed + case signDataWithRSABuilder builderRsaUnsupportedFinal signingKey "test payload" of + Left (SignBackendError _) -> pure () + Left err -> + assertFailure + ("RSA builder API should reject unsupported hash with backend error, got " ++ + renderSignError err) + Right sig -> + assertFailure + ("RSA builder API should reject unsupported hash algorithm, got " ++ show sig) + + -- Runtime hash witness promotion should build RFC9580-compatible builders. + let runtimeRsa = + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA512 of + Left err -> Left err + Right builder -> + let withHashed = addHashedSubs (listToHashedSubs []) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed + in first renderSignError (signDataWithRSABuilder withUnhashed signingKey "test payload") + case runtimeRsa of + Left err -> + assertFailure + ("runtime RFC9580 SHA512 builder initialization should succeed, got " ++ err) + Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ("runtime RFC9580 SHA512 builder should produce BinarySig RSA SHA512, got " ++ + show other) + + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA1 of + Left _ -> pure () + Right _ -> + assertFailure + "runtime RFC9580 builder initialization should reject deprecated SHA1" + + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig (OtherHA 99) of + Left _ -> pure () + Right _ -> + assertFailure + "runtime builder initialization should reject non-witness-backed hash algorithms" + + -- Test Ed25519 builder API with empty subpackets + (_, edSigningKey) <- loadDeterministicEd25519Signer + let builderEd25519 = sigBuilderInit @'PKA.Ed25519 BinarySig SHA512 + let builderEd25519WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519 + let builderEd25519Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519WithHashed + case signDataWithEd25519Builder builderEd25519Final edSigningKey "test payload" of + Left err -> assertFailure ("Ed25519 builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure ("Ed25519 builder API should generate BinarySig Ed25519 SHA512, got " ++ show other) + + -- Test Ed25519 v6 builder API + let v6Salt = SignatureSalt (BL.replicate 32 0x42) + let builderEd25519V6 = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt + let builderEd25519V6WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519V6 + let builderEd25519V6Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519V6WithHashed + case signDataWithEd25519V6Builder builderEd25519V6Final edSigningKey "test payload" of + Left err -> assertFailure ("Ed25519 v6 builder API failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> + assertEqual "Ed25519 v6 builder API should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure ("Ed25519 v6 builder API should generate BinarySig Ed25519 SHA512 SigV6, got " ++ show other) + + -- Runtime v6 builder initialization should support SHA3 witness-backed hashes. + let v6Sha3Salt = SignatureSalt (BL.replicate 16 0x33) + runtimeEd25519V6Sha3 = + case sigBuilderInitV6Runtime @'PKA.Ed25519 RFC9580 BinarySig SHA3_256 v6Sha3Salt of + Left err -> Left err + Right builder -> + let withHashed = addHashedSubs (listToHashedSubs []) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed + in first + renderSignError + (signDataWithEd25519V6Builder withUnhashed edSigningKey "test payload") + case runtimeEd25519V6Sha3 of + Left err -> + assertFailure + ("runtime RFC9580 SHA3-256 v6 builder should succeed, got " ++ err) + Right (SigV6 BinarySig PKA.Ed25519 SHA3_256 salt _ _ _ _) -> + assertEqual + "runtime RFC9580 SHA3-256 v6 builder should preserve 16-byte salt" + 16 + (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure + ("runtime RFC9580 SHA3-256 v6 builder should produce Ed25519 SigV6 SHA3_256, got " ++ + show other) + +testLegalSubpacketBuilders :: Assertion +testLegalSubpacketBuilders = do + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id for legal-subpacket builder test: " ++ err) >> + fail "expected issuer key id" + Right i -> pure i + + let signerFp = fingerprint signer + creation = ThirtyTwoBitTimeStamp 1 + v4Builder = sigBuilderInit @'PKA.RSA BinarySig SHA512 + v4WithHashed = + addHashedSubs + (listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV4 signerFp]) + v4Builder + v4Final = addUnhashedSubs (listToLegalSubs [LegalIssuerV4 issuerKeyId]) v4WithHashed + + case signDataWithRSABuilder v4Final signingKey "typed legal subpacket payload" of + Left err -> + assertFailure ("v4 legal-subpacket builder failed: " ++ renderSignError err) + Right (SigV4 _ _ _ hashed unhashed _ _) -> do + assertBool + "v4 legal-subpacket builder should include creation time in hashed subpackets" + (SigSubPacket False (SigCreationTime creation) `elem` hashed) + assertBool + "v4 legal-subpacket builder should include v4 issuer fingerprint in hashed subpackets" + (SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 signerFp) `elem` hashed) + assertBool + "v4 legal-subpacket builder should include issuer key ID only in unhashed subpackets" + (SigSubPacket False (Issuer issuerKeyId) `elem` unhashed) + Right other -> + assertFailure ("v4 legal-subpacket builder should generate SigV4, got " ++ show other) + + (_, edSigningKey) <- loadDeterministicEd25519Signer + let v6Salt = SignatureSalt (BL.replicate 32 0x17) + v6Builder = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt + v6WithHashed = + addHashedSubs + (listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV6 signerFp]) + v6Builder + v6Final = addUnhashedSubs (listToLegalSubs []) v6WithHashed + + case signDataWithEd25519V6Builder v6Final edSigningKey "typed legal subpacket payload" of + Left err -> + assertFailure ("v6 legal-subpacket builder failed: " ++ renderSignError err) + Right (SigV6 _ _ _ _ hashed unhashed _ _) -> do + assertBool + "v6 legal-subpacket builder should include creation time in hashed subpackets" + (SigSubPacket False (SigCreationTime creation) `elem` hashed) + assertBool + "v6 legal-subpacket builder should include v6 issuer fingerprint in hashed subpackets" + (SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 signerFp) `elem` hashed) + assertEqual + "v6 legal-subpacket builder should keep unhashed set empty for typed legal set used here" + [] + unhashed + Right other -> + assertFailure ("v6 legal-subpacket builder should generate SigV6, got " ++ show other) + +testTemporaryKeyValidityRespectsLatestSelfSignature :: Assertion +testTemporaryKeyValidityRespectsLatestSelfSignature = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + longValidityCertTime = addTimestampSeconds keyCreated 10 + temporaryValidityCertTime = addTimestampSeconds keyCreated 20 + validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + expiredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) + preExpirySignatureTime = addTimestampSeconds keyCreated 25 + postExpirySignatureTime = addTimestampSeconds keyCreated 40 + payload = "temporary validity signer timeline payload" + longValidityCert <- + signCertificationAt + signer + signingKey + uid + longValidityCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + temporaryValidityCert <- + signCertificationAt + signer + signingKey + uid + temporaryValidityCertTime + [SigSubPacket False (KeyExpirationTime 30)] + preExpirySignature <- + signBinaryMessageWithRSAAt signer signingKey preExpirySignatureTime payload + postExpirySignature <- + signBinaryMessageWithRSAAt signer signingKey postExpirySignatureTime payload + let tk = TKUnknown (signer, Nothing) [] [(uidText, [longValidityCert, temporaryValidityCert])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "latest effective self-signature should keep key valid before temporary expiration" + (isTKTimeValid validCheckTime tk) + assertBool + "latest effective self-signature should expire key at the temporary validity boundary" + (not (isTKTimeValid expiredCheckTime tk)) + assertSingleSignerFingerprint + "pre-expiry signatures should still verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload preExpirySignature) + assertSingleFailureContainsTimeline + "post-expiry signatures should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload postExpirySignature) + +testTemporaryKeyValidityRejectsSelfSignatureGaps :: Assertion +testTemporaryKeyValidityRejectsSelfSignatureGaps = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-gap@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + firstCertTime = addTimestampSeconds keyCreated 10 + secondCertTime = addTimestampSeconds keyCreated 30 + gapCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + renewedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) + gapSignatureTime = addTimestampSeconds keyCreated 25 + renewedSignatureTime = addTimestampSeconds keyCreated 35 + payload = "temporary validity gap signer timeline payload" + firstCertification <- + signCertificationAt + signer + signingKey + uid + firstCertTime + [ SigSubPacket False (KeyExpirationTime 1000) + , SigSubPacket False (SigExpirationTime 10) + ] + secondCertification <- + signCertificationAt + signer + signingKey + uid + secondCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + gapSignature <- + signBinaryMessageWithRSAAt signer signingKey gapSignatureTime payload + renewedSignature <- + signBinaryMessageWithRSAAt signer signingKey renewedSignatureTime payload + let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "a gap with no effective self-signature should make the key temporarily invalid" + (not (isTKTimeValid gapCheckTime tk)) + assertBool + "a later self-signature should restore validity once it becomes effective" + (isTKTimeValid renewedCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made during a self-signature gap should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload gapSignature) + assertSingleSignerFingerprint + "signatures made after a later self-signature becomes effective should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload renewedSignature) + +testTemporaryKeyValidityRejectsPreCertificationGap :: Assertion +testTemporaryKeyValidityRejectsPreCertificationGap = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-pre-cert-gap@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 20 + invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 10) + validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + invalidSignatureTime = addTimestampSeconds keyCreated 10 + validSignatureTime = addTimestampSeconds keyCreated 25 + payload = "temporary validity pre-certification gap signer timeline payload" + certification <- + signCertificationAt + signer + signingKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 1000)] + invalidSignature <- + signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload + validSignature <- + signBinaryMessageWithRSAAt signer signingKey validSignatureTime payload + let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "a key should be invalid before its first self-signature becomes effective" + (not (isTKTimeValid invalidCheckTime tk)) + assertBool + "a key should become valid once its first self-signature becomes effective" + (isTKTimeValid validCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made before the first self-signature should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload invalidSignature) + assertSingleSignerFingerprint + "signatures made after the first self-signature becomes effective should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload validSignature) + +testTemporaryKeyValidityFollowsTemporarySelfRevocation :: Assertion +testTemporaryKeyValidityFollowsTemporarySelfRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-self-revocation@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + revokedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + restoredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) + revokedSignatureTime = addTimestampSeconds keyCreated 25 + restoredSignatureTime = addTimestampSeconds keyCreated 35 + payload = "temporary validity self-revocation signer timeline payload" + certification <- + signCertificationAt + signer + signingKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 1000)] + temporaryRevocation <- + signCertificationRevocationAt + signer + signingKey + uid + revocationTime + [SigSubPacket False (SigExpirationTime 10)] + revokedSignature <- + signBinaryMessageWithRSAAt signer signingKey revokedSignatureTime payload + restoredSignature <- + signBinaryMessageWithRSAAt signer signingKey restoredSignatureTime payload + let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, temporaryRevocation])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "a temporary self-revocation should disable signing while it is effective" + (not (isTKTimeValid revokedCheckTime tk)) + assertBool + "a self-certification should become valid again once its temporary revocation expires" + (isTKTimeValid restoredCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made during a temporary self-revocation should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload revokedSignature) + assertSingleSignerFingerprint + "signatures made after a temporary self-revocation expires should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload restoredSignature) + +testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures :: Assertion +testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-no-revival@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + firstCertTime = addTimestampSeconds keyCreated 10 + secondCertTime = addTimestampSeconds keyCreated 20 + invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 30) + invalidSignatureTime = addTimestampSeconds keyCreated 30 + payload = "temporary validity no revival signer timeline payload" + firstCertification <- + signCertificationAt + signer + signingKey + uid + firstCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + secondCertification <- + signCertificationAt + signer + signingKey + uid + secondCertTime + [ SigSubPacket False (KeyExpirationTime 1000) + , SigSubPacket False (SigExpirationTime 5) + ] + invalidSignature <- + signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload + let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "an expired newer self-signature should not revive an older certification" + (not (isTKTimeValid invalidCheckTime tk)) + assertSingleFailureContainsTimeline + "signatures after a newer self-signature expires should be rejected until re-certified" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload invalidSignature) + +testUidRetiredRevocationIsHistorical :: Assertion +testUidRetiredRevocationIsHistorical = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "retired-uid@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + certification <- + signCertificationAt signer signingKey uid certificationTime [] + retirementRevocation <- + signCertificationRevocationAt + signer + signingKey + uid + revocationTime + [SigSubPacket False (ReasonForRevocation UserIdInfoNoLongerValid "")] + let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, retirementRevocation])] [] [] + verifyAt ts = + verifyUnknownTKWith + (verifySigWith (verifyAgainstKeys [tk])) + (Just (timestampToUTCTime ts)) + tk + beforeRetirement <- + case verifyAt (addTimestampSeconds keyCreated 15) of + Left err -> + assertFailure + ("uid-retired pre-revocation verification failed: " ++ renderVerificationError err) >> + fail "expected verified transferable key before uid retirement" + Right verifiedTK -> pure verifiedTK + afterRetirement <- + case verifyAt (addTimestampSeconds keyCreated 25) of + Left err -> + assertFailure + ("uid-retired post-revocation verification failed: " ++ renderVerificationError err) >> + fail "expected verified transferable key after uid retirement" + Right verifiedTK -> pure verifiedTK + assertEqual + "uid-retired revocation should preserve the UID before it becomes effective" + 1 + (length (_tkuUIDs beforeRetirement)) + assertEqual + "uid-retired revocation should retire the UID once effective" + 0 + (length (_tkuUIDs afterRetirement)) + +testThirdPartyCertificationDoesNotAffectKeyValidityWindow :: Assertion +testThirdPartyCertificationDoesNotAffectKeyValidityWindow = do + (targetSigner, _) <- loadUnencryptedRsaSigner + (thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer + let uidText = "third-party-validity@example.org" + uid = UserId uidText + keyCreated = _timestamp targetSigner + certificationTime = addTimestampSeconds keyCreated 10 + validityCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) + thirdPartyCertification <- + signCertificationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 30)] + let targetTK = TKUnknown (targetSigner, Nothing) [] [(uidText, [thirdPartyCertification])] [] [] + certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] + verifyAt = + verifyUnknownTKWith + (verifySigWith (verifyAgainstKeys [targetTK, certifierTK])) + (Just validityCheckTime) + targetTK + verifiedTK <- + case verifyAt of + Left err -> + assertFailure + ("third-party certification verification failed: " ++ renderVerificationError err) >> + fail "expected verified transferable key" + Right tk -> pure tk + assertBool + "third-party certifications must not define the primary key validity window" + (isTKTimeValid validityCheckTime verifiedTK) + +testCertificationRevocationOnlyRemovesMatchingSigner :: Assertion +testCertificationRevocationOnlyRemovesMatchingSigner = do + (targetSigner, targetSigningKey) <- loadUnencryptedRsaSigner + (thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer + let uidText = "cert-revocation-scope@example.org" + uid = UserId uidText + keyCreated = _timestamp targetSigner + selfCertificationTime = addTimestampSeconds keyCreated 10 + thirdPartyCertificationTime = addTimestampSeconds keyCreated 12 + thirdPartyRevocationTime = addTimestampSeconds keyCreated 20 + beforeRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 15) + afterRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + selfCertification <- + signCertificationAt targetSigner targetSigningKey uid selfCertificationTime [] + thirdPartyCertification <- + signCertificationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + thirdPartyCertificationTime + [] + thirdPartyRevocation <- + signCertificationRevocationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + thirdPartyRevocationTime + [] + let targetTK = + TKUnknown + (targetSigner, Nothing) + [] + [(uidText, [selfCertification, thirdPartyCertification, thirdPartyRevocation])] + [] + [] + certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] + verifyAt ts = + verifyUnknownTKWith + (verifySigWith (verifyAgainstKeys [targetTK, certifierTK])) + (Just ts) + targetTK + beforeRevocation <- + case verifyAt beforeRevocationTime of + Left err -> + assertFailure + ("pre-revocation certification verification failed: " ++ renderVerificationError err) >> + fail "expected verified transferable key before certification revocation" + Right tk -> pure tk + afterRevocation <- + case verifyAt afterRevocationTime of + Left err -> + assertFailure + ("post-revocation certification verification failed: " ++ renderVerificationError err) >> + fail "expected verified transferable key after certification revocation" + Right tk -> pure tk + let beforeSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs beforeRevocation)) + afterSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs afterRevocation)) + assertEqual + "certification revocations should not apply before they become effective" + [selfCertification, thirdPartyCertification] + beforeSigs + assertEqual + "a certification revocation should remove only certifications from the same signer" + [selfCertification] + afterSigs + +testPreferencesAtTimestamp :: Assertion +testPreferencesAtTimestamp = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uid = UserId "prefs@example.org" + UserId uidText = uid + t1 = addTimestampSeconds (_timestamp signer) 1 + t2 = addTimestampSeconds t1 100 + t3 = addTimestampSeconds t2 100 + queryDuring = addTimestampSeconds t2 1 + queryAfterRevocation = addTimestampSeconds t3 1 + + initialCertification <- + signCertificationAt + signer + signingKey + uid + t1 + [SigSubPacket False (PreferredHashAlgorithms [SHA256])] + updatedCertification <- + signCertificationAt + signer + signingKey + uid + t2 + [SigSubPacket False (PreferredHashAlgorithms [SHA512])] + certificationRevocation <- + signCertificationRevocationAt signer signingKey uid t3 [] + + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [initialCertification, updatedCertification, certificationRevocation])] + [] + [] + + assertEqual + "key preferences at timestamp should use the latest active self-certification" + (Just [PreferredHashAlgorithms [SHA512]]) + (effectiveKeyPreferencesAtTimestamp queryDuring tk) + assertEqual + "UID preferences at timestamp should use the latest active self-certification" + (Just [PreferredHashAlgorithms [SHA512]]) + (effectiveUIDPreferencesAtTimestamp queryDuring uidText tk) + assertEqual + "revoked UID certifications should not provide effective UID preferences" + Nothing + (effectiveUIDPreferencesAtTimestamp queryAfterRevocation uidText tk) + assertEqual + "key preferences should become unavailable when no active self-certification remains" + Nothing + (effectiveKeyPreferencesAtTimestamp queryAfterRevocation tk) + +testChangePrivateKeyPassphraseLegacy :: Assertion +testChangePrivateKeyPassphraseLegacy = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| + CL.consume + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) + _ -> + assertFailure "aes256-sha512.seckey did not begin with a secret key packet" >> + fail "expected secret key packet" + originalDecrypted <- + case decryptPrivateKey (pkp, ska) passphrase of + Left err -> + assertFailure ("decrypting original legacy key failed: " ++ err) >> + fail "decrypting original legacy key failed" + Right x -> pure x + originalSKey <- + case originalDecrypted of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure "original legacy key should decrypt to unencrypted secret material" >> + fail "expected unencrypted secret key" + changed <- + case + changePrivateKeyPassphrase + (pkp, ska) + passphrase + (Salt "12345678") + (IV "1234567890ABCDEF") + "changed-pki-password" of + Left err -> + assertFailure + ("legacy passphrase change should preserve the existing protection envelope, got: " ++ + err) >> + fail "legacy passphrase change failed" + Right skaddendum -> pure skaddendum + originalIterCount <- + case ska of + SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter + _ -> + assertFailure + "legacy key fixture should use SUSSHA1/AES256/IteratedSalted SHA512" >> + fail "expected legacy key fixture" + case changed of + SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do + assertEqual + "legacy passphrase change should preserve the S2K iteration count" + originalIterCount + iter + assertBool + "legacy passphrase change should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure + "legacy passphrase change should preserve the SUSSHA1/AES256 envelope" + decrypted <- + case decryptPrivateKey (pkp, changed) "changed-pki-password" of + Left err -> + assertFailure ("re-decrypting changed legacy key failed: " ++ err) >> + fail "re-decrypting changed legacy key failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "legacy passphrase change should preserve secret key material" + originalSKey + skey + _ -> + assertFailure + "legacy passphrase change should decrypt back to unencrypted secret material" + +testChangePrivateKeyPassphraseV6 :: Assertion +testChangePrivateKeyPassphraseV6 = do + oldPassphrase <- readPKIPassphrase + armors <- loadArmor "v6-encrypted-secret.pgp.aa" + armor <- + case armors of + (a:_) -> pure a + [] -> + assertFailure "v6-encrypted-secret.pgp.aa should contain one armored payload" >> + fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) + _ -> + assertFailure "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >> + fail "expected secret key packet" + let newPassphrase = "changed-pki-password" + originalDecrypted <- + case decryptPrivateKey (pkp, ska) oldPassphrase of + Left err -> + assertFailure ("decrypting original v6 key failed: " ++ err) >> + fail "decrypting original v6 key failed" + Right x -> pure x + originalSKey <- + case originalDecrypted of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure "original v6 key should decrypt to unencrypted secret material" >> + fail "expected unencrypted secret key" + let changedResult = + changePrivateKeyPassphrase + (pkp, ska) + oldPassphrase + (Salt "1234567890ABCDEF") + (IV "1234567890ABCDE") + newPassphrase + changed <- + case changedResult of + Left err -> + assertFailure ("changing v6 key passphrase failed: " ++ err) >> pure ska + Right skaddendum -> pure skaddendum + case changed of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual + "changed v6 key addendum should use expected Argon2 t parameter" + 1 + t + assertEqual + "changed v6 key addendum should use expected Argon2 p parameter" + 4 + p + assertEqual + "changed v6 key addendum should use expected Argon2 encoded memory parameter" + 15 + em + assertBool + "changed v6 key addendum should contain encrypted key material" + (not (BL.null encryptedPayload)) + _ -> assertFailure "changed v6 key addendum should be encrypted with SUSAEAD" + let decryptedResult = decryptPrivateKey (pkp, changed) newPassphrase + decrypted <- + case decryptedResult of + Left err -> + assertFailure ("decryption with changed v6 passphrase failed: " ++ err) >> + fail "decryption with changed v6 passphrase failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "changing a v6 key passphrase should preserve secret key material" + originalSKey + skey + _ -> assertFailure "changed v6 key should decrypt with the new passphrase" + +testPolicySignatureContextValidation :: Assertion +testPolicySignatureContextValidation = do + let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV6PK = + SigV6 + KeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x11)) + [] + [] + 0 + (MPI 0 :| []) + pkSigV6Direct = + SigV6 + SignatureDirectlyOnAKey + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x12)) + [] + [] + 0 + (MPI 0 :| []) + pkSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x13)) + [] + [] + 0 + (MPI 0 :| []) + skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x14)) + [] + [] + 0 + (MPI 0 :| []) + skSigV6Revocation = + SigV6 + SubkeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x15)) + [] + [] + 0 + (MPI 0 :| []) + skSigV6Direct = + SigV6 + SignatureDirectlyOnAKey + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x16)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV4Generic = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Persona = SigV4 PersonaCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Casual = SigV4 CasualCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Positive = SigV4 PositiveCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4CertRev = SigV4 CertRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV6Generic = + SigV6 + GenericCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x17)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Persona = + SigV6 + PersonaCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x18)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Casual = + SigV6 + CasualCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x19)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Positive = + SigV6 + PositiveCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1a)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6CertRev = + SigV6 + CertRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1b)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1c)) + [] + [] + 0 + (MPI 0 :| []) + assertTrue "KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV4PK) + assertTrue "SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Direct) + assertFalse "SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Binding) + assertTrue "v6 KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV6PK) + assertTrue "v6 SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Direct) + assertFalse "v6 SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Binding) + assertTrue "SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV4Binding) + assertTrue "SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV4Revocation) + assertFalse "SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV4Direct) + assertTrue "v6 SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV6Binding) + assertTrue "v6 SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV6Revocation) + assertFalse "v6 SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV6Direct) + assertTrue "GenericCert allowed on UID" (isAllowedUIDSig uidSigV4Generic) + assertTrue "PersonaCert allowed on UID" (isAllowedUIDSig uidSigV4Persona) + assertTrue "CasualCert allowed on UID" (isAllowedUIDSig uidSigV4Casual) + assertTrue "PositiveCert allowed on UID" (isAllowedUIDSig uidSigV4Positive) + assertTrue "CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV4CertRev) + assertFalse "SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV4Binding) + assertTrue "v6 GenericCert allowed on UID" (isAllowedUIDSig uidSigV6Generic) + assertTrue "v6 PersonaCert allowed on UID" (isAllowedUIDSig uidSigV6Persona) + assertTrue "v6 CasualCert allowed on UID" (isAllowedUIDSig uidSigV6Casual) + assertTrue "v6 PositiveCert allowed on UID" (isAllowedUIDSig uidSigV6Positive) + assertTrue "v6 CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV6CertRev) + assertFalse "v6 SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV6Binding) + +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID :: Assertion +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID = do + (signer, _) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive RSA issuer key id: " ++ err) >> + fail "expected issuer key id" + Right i -> pure i + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [SigSubPacket False (Issuer issuerKeyId)] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertBool + "v6 revocation verification should reject legacy Issuer key-id subpackets" + ("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf` + renderVerificationError err) + Right _ -> + assertFailure + "Expected v6 revocation verification to reject legacy Issuer key-id subpacket" + +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed :: Assertion +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed = do + (signer, _) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive RSA issuer key id: " ++ err) >> + fail "expected issuer key id" + Right i -> pure i + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [] + [SigSubPacket False (Issuer issuerKeyId)] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertBool + "v6 revocation verification should reject legacy Issuer key-id subpackets in unhashed area" + ("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf` + renderVerificationError err) + Right _ -> + assertFailure + "Expected v6 revocation verification to reject legacy Issuer key-id subpacket in unhashed area" + +testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint :: Assertion +testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint = do + (signer, _) <- loadUnencryptedRsaSigner + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint signer))] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertFailure + ("Expected matching IssuerFingerprint to verify for v6 revocation signature, got: " ++ + renderVerificationError err) + Right _ -> pure () + +testV6SignerConstructorRejectsV4Key :: Assertion +testV6SignerConstructorRejectsV4Key = do + (signer, signingKey) <- loadDeterministicEd25519Signer + case asV6PKPayload signer of + Left _ -> pure () + Right signerV6 -> + seq (mkEd25519SignerV6 signerV6 signingKey) $ + assertFailure "asV6PKPayload should reject v4 Ed25519 key payloads" + (rsaSigner, rsaSigningKey) <- loadUnencryptedRsaSigner + case asV6PKPayload rsaSigner of + Left _ -> pure () + Right signerV6 -> + seq (mkRSASignerV6 signerV6 rsaSigningKey) $ + assertFailure "asV6PKPayload should reject v4 RSA key payloads" + +testGetSecretKeyHandlesV4X25519ECDHPubkey :: Assertion +testGetSecretKeyHandlesV4X25519ECDHPubkey = do + let pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + (ECDHPubKey + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) + SHA256 + AES128) + encodedSecret = runPut (put (MPI 42)) + case runGetOrFail (getSecretKey pkp) encodedSecret of + Left (_, _, err) -> + assertFailure ("getSecretKey should parse v4 X25519 secret key material: " ++ err) + Right (_, _, ECDHPrivateKey (ECDSA_PrivateKey prv)) -> + assertEqual + "getSecretKey should preserve X25519 private scalar" + 42 + (ECDSA.private_d prv) + Right (_, _, other) -> + assertFailure ("unexpected parsed secret key type: " ++ show other) + +testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion +testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte = do + let secretBytes = B.pack (0 : replicate 31 1) + pkt = + SecretKeyPkt + (PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01))))))) + (SUUnencrypted (EdDSAPrivateKey Ed25519 secretBytes) 0) + case runGetOrFail (get :: Get Pkt) (runPut (put pkt)) of + Left (_, _, err) -> + assertFailure ("v4 Ed25519 secret key should round-trip: " ++ err) + Right (_, _, parsedPkt) -> + case parsedPkt of + SecretKeyPkt _ (SUUnencrypted (EdDSAPrivateKey Ed25519 parsedBytes) _) -> + assertEqual + "v4 Ed25519 secret-key round-trip should preserve MPI-encoded bytes" + secretBytes + parsedBytes + _ -> + assertFailure ("unexpected parsed packet shape: " ++ show parsedPkt) + +testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion +testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte = do + let secretBytes = B.pack (0 : replicate 56 2) + pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 57 0x02)))))) + encodedSecret = runPut (put (MPI (os2ip secretBytes))) + case runGetOrFail (getSecretKey pkp) encodedSecret of + Left (_, _, err) -> + assertFailure ("v4 Ed448 secret key should parse with preserved padding: " ++ err) + Right (_, _, parsedSecret) -> + assertEqual + "v4 Ed448 secret-key parsing should restore the curve-width byte string" + (EdDSAPrivateKey Ed448 secretBytes) + parsedSecret + diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/MessageAndArmor.hs @@ -0,0 +1,1847 @@ +-- MessageAndArmor.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.MessageAndArmor (messageAndArmorTests) where + +import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) +import Codec.Encryption.OpenPGP.BlockCipher (keySize) +import Codec.Encryption.OpenPGP.CFB (decryptPreservingNonce, validateSEIPD1MDC) +import Codec.Encryption.OpenPGP.Encrypt (encryptSEIPDv2WithSKESKBlock) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD) +import Codec.Encryption.OpenPGP.KeyringParser (parseUnknownTKs) +import Codec.Encryption.OpenPGP.Message +import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) +import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) +import Codec.Encryption.OpenPGP.Serialize (parsePkts, parsePktsEither) +import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig, payloadForSigWith) +import Codec.Encryption.OpenPGP.Signatures + ( renderSignError + , renderVerificationError + , signCertRevocationWithRSA + , signCertificationWithRSA + , signDataWithEd25519 + , signDataWithEd25519V6 + , signDataWithEd448 + , signDataWithEd448V6 + , signDataWithRSA + , signDataWithRSABuilder + , signDataWithEd25519Builder + , signDataWithEd25519V6Builder + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + , signSubkeyRevocationWithRSA + , SignError(..) + , verifyAgainstKeyring + , verifyAgainstKeys + , verifySigWith + , VerificationError(..) + ) +import Codec.Encryption.OpenPGP.Subpackets + ( addHashedSubs + , addUnhashedSubs + , listToHashedSubs + , listToUnhashedSubs + , sbTextNormMode + , sigBuilderInit + , TextNormalizationMode(..) + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import Data.Binary (get, put) +import Data.Binary.Get (Get, runGetOrFail) +import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord8, runPut) +import Data.Bits (xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Conduit.OpenPGP.Message (verifyMessage, verifyMessagePackets) +import Data.Conduit.OpenPGP.Verify (VerificationMode(..)) +import Data.Either (isRight) +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Tests.Common + ( addTimestampSeconds + , assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , encryptMessageDefault + , expectV4PKPayload + , expectV6PKPayload + , extractV4SignatureAlgorithmFields + , fp + , loadAndDecompressPkts + , loadArmor + , loadKeyring + , loadDeterministicEd25519Signer + , loadDeterministicEd25519SignerV6 + , loadDeterministicEd448Signer + , loadDeterministicEd448SignerV6 + , loadUnencryptedRsaSigner + , loadUnencryptedRsaSignerV6 + , messageIssuerSubpacketsAt + , mkTestKeyring + , readFixtureLazy + , setPKAlgorithm + , signBinaryMessageWithRSAAt + , signBinaryMessageWithEd25519At + , signKeyRevocationWithReasonAt + , signKeyRevocationWithReasonAndExtrasAt + , signSubkeyBindingWithRSAAt + , signSubkeyRevocationWithRSAAt + , verifyTimelinePackets + ) + +messageAndArmorTests :: TestTree +messageAndArmorTests = + testGroup + "Message API and armor fixtures" + [ testGroup + "Message API group" + [ testCase "default encrypt/decrypt message" testDefaultedEncryptDecrypt + , testCase "specific encrypt/decrypt message" testExplicitEncryptDecrypt + , testCase + "specific encrypt can expose effective session material" + testExplicitEncryptExposesEffectiveSessionMaterial + , testCase + "default encrypt does not expose session material" + testDefaultEncryptDoesNotExposeSessionMaterial + , testCase "AES-128 EAX encrypt/decrypt message" testExplicitAES128EAXEncryptDecrypt + , testCase "AES-128 GCM encrypt/decrypt message" testExplicitAES128GCMEncryptDecrypt + , testCase + "specific encrypt rejects deprecated S2K hash in modern mode" + testExplicitEncryptRejectsDeprecatedS2KHash + , testCase "legacy fallback encrypt/decrypt message" testLegacyFallbackEncryptDecrypt + , testCase + "RFC4880 encryptMessage SEIPDv1 cleartext parses without trailing junk" + testRFC4880EncryptMessageSEIPDv1ParsesCleanly + , testCase "decryptMessage returns typed parse failures" testDecryptMessageTypedParseFailure + , testCase + "decryptMessage rejects unknown critical packets" + testDecryptMessageRejectsUnknownCriticalPacket + , testCase "decryptMessage returns typed decrypt failures" testDecryptMessageTypedDecryptFailure + , testCase + "decryptMessage rejects SEIPDv1 MDC tampering" + testDecryptMessageSEIPDv1MDCTampering + , testCase "sign message shape" testSignMessageShape + , testCase "sign message shape (RSA SigV6)" testSignMessageRSAV6 + , testCase "sign message shape (Ed25519)" testSignMessageEd25519 + , testCase "sign message shape (Ed25519 SigV6)" testSignMessageEd25519V6 + , testCase "sign message shape (Ed448)" testSignMessageEd448 + , testCase "sign message shape (Ed448 SigV6)" testSignMessageEd448V6 + , testCase + "v4 Ed25519/Ed448 signatures use native fixed-width encoding" + testV4EdSignaturesUseNativeFixedWidthEncoding + , testCase + "v4 Ed25519Legacy key parsing rejects missing 0x40 prefix" + testV4Ed25519LegacyKeyRejectsMissingPrefix + , testCase + "detached v4 Ed25519 verification tolerates missing issuer hints" + testVerifyDetachedEd25519WithoutIssuerHints + , testCase + "detached v4 Ed25519 verification tolerates fake issuer hints" + testVerifyDetachedEd25519WithFakeIssuerHint + , testCase + "detached v4 Ed25519 verifyAgainstKeys tolerates missing issuer hints" + testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys + , testCase + "detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints" + testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys + , testCase + "v4 EdDSA signatures verify with Ed25519 key algorithm identifier" + testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm + , testCase "sign message convenience API" testSignMessageConvenience + , testCase "typed verify surface matches legacy results" testTypedVerifySurfaceMatchesLegacy + , testCase "strict typed verify rejects tamper" testVerifyMessageStrictRejectsTamper + , testCase "verifySignedMessage convenience API" testVerifySignedMessageConvenience + , testCase "signature generation primitives" testSignaturePrimitives + , testCase + "typed signature payload coercions" + testSignatureDataKindsCoercions + , testCase + "canonical text signature payload normalization" + testCanonicalTextSigPayloadNormalization + , testCase + "canonical text signatures normalize during signing" + testCanonicalTextSignatureSigningPaths + , testCase + "text normalization modes (RFC9580Strict vs CleartextCompat)" + testTextNormalizationModes + ] + , testGroup + "ASCII armor fixture group" + [ testCase + "v4-encrypted-secret.pgp.aa decodes as an encrypted v4 secret key" + testV4EncryptedSecretArmor + , testCase + "v4-encrypted.rev.aa decodes as a v4 revocation certificate" + testV4EncryptedRevocationArmor + , testCase + "v4-encrypted.rev.aa SigV4 key-revocation semantics" + testV4RevocationSignatureSemantics + , testCase + "v4-encrypted.rev.aa parses as single revocation TKUnknown" + (testRevocationArmorParsesAsSingleTransferableKey "v4-encrypted.rev.aa" True) + , testCase + "v6.rev.aa decodes as a v6 revocation certificate" + (testV6RevocationArmor "v6.rev.aa") + , testCase + "v6.rev.aa SigV6 salt semantics" + (testV6RevocationSignatureSaltSemantics "v6.rev.aa") + , testCase + "v6.rev.aa forbids legacy Issuer key-id subpackets" + (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6.rev.aa") + , testCase + "v6.rev.aa parses as single revocation TKUnknown" + (testRevocationArmorParsesAsSingleTransferableKey "v6.rev.aa" True) + , testCase + "v6-encrypted.rev.aa decodes as a v6 revocation certificate" + (testV6RevocationArmor "v6-encrypted.rev.aa") + , testCase + "v6-encrypted.rev.aa SigV6 salt semantics" + (testV6RevocationSignatureSaltSemantics "v6-encrypted.rev.aa") + , testCase + "v6-encrypted.rev.aa forbids legacy Issuer key-id subpackets" + (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6-encrypted.rev.aa") + , testCase + "v6-encrypted.rev.aa parses as single revocation TKUnknown" + (testRevocationArmorParsesAsSingleTransferableKey "v6-encrypted.rev.aa" True) + , testCase + "msg1.asc decodes as a parseable armored message" + testMsg1ArmorFixture + ] + , testGroup + "timeline-aware group" + [ testCase + "timeline-aware primary soft revocation keeps pre-revocation signatures" + testSignerTimelineSoftPrimaryRevocation + , testCase + "timeline-aware primary hard revocation rejects historical signatures" + testSignerTimelineHardPrimaryRevocation + , testCase + "timeline-aware no-reason primary revocation rejects historical signatures" + testSignerTimelineNoReasonPrimaryRevocation + , testCase + "timeline-aware unknown-reason primary revocation rejects historical signatures" + testSignerTimelineUnknownReasonPrimaryRevocation + , testCase + "timeline-aware non-compromise primary revocation stays historical until effective" + testSignerTimelineNonCompromisePrimaryRevocationIsHistorical + , testCase + "timeline-aware temporary primary revocation expires and restores validity" + testSignerTimelineTemporaryPrimaryRevocationExpires + , testCase + "timeline-aware subkey revocation distinguishes pre/post signatures" + testSignerTimelineSubkeyRevocation + ] + ] + +testV4EncryptedSecretArmor :: Assertion +testV4EncryptedSecretArmor = do + armors <- loadArmor "v4-encrypted-secret.pgp.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure "v4 encrypted secret fixture should contain one armored payload" >> + fail "expected one armored payload" + (headers, payload) <- + case armor of + Armor ArmorPrivateKeyBlock hs p -> pure (hs, p) + Armor atype _ _ -> + assertFailure + ("v4 encrypted secret fixture should decode as a private key block, got " ++ + show atype) >> + fail "expected private key block" + _ -> + assertFailure "v4 encrypted secret fixture should decode as an armored payload" >> + fail "expected armored payload" + assertEqual + "v4 encrypted secret fixture should keep identifying comments" + [ ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + , ("Comment", "") + , ("Comment", "v4 Test User") + ] + headers + let packets = parsePkts payload + userIds = [u | UserIdPkt u <- packets] + primarySecretKeys = [(pkp, ska) | SecretKeyPkt pkp ska <- packets] + secretSubkeys = [(pkp, ska) | SecretSubkeyPkt pkp ska <- packets] + assertEqual + "v4 encrypted secret fixture should include expected user IDs" + ["", "v4 Test User"] + userIds + assertEqual + "v4 encrypted secret fixture should contain one primary secret key packet" + 1 + (length primarySecretKeys) + assertEqual + "v4 encrypted secret fixture should contain three encrypted secret subkeys" + 3 + (length secretSubkeys) + case packets of + (SecretKeyPkt pkp ska:_) -> do + assertEqual + "v4 encrypted secret fixture should contain a v4 primary key" + V4 + (_keyVersion pkp) + assertEqual + "v4 encrypted secret fixture should have the expected primary-key fingerprint" + (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + (fingerprint pkp) + assertEqual + "v4 encrypted secret fixture should use EdDSA for its primary key" + EdDSA + (_pkalgo pkp) + assertEncryptedS2K "primary key" ska + mapM_ (assertEncryptedS2K "subkey" . snd) secretSubkeys + assertEqual + "v4 encrypted secret fixture should contain two EdDSA subkeys and one ECDH subkey" + [EdDSA, EdDSA, ECDH] + (map (_pkalgo . fst) secretSubkeys) + _ -> assertFailure "v4 encrypted secret fixture should start with a secret key packet" + where + assertEncryptedS2K :: String -> SKAddendum -> Assertion + assertEncryptedS2K testLabel ska = + case ska of + SUSSHA1 AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do + assertEqual + (testLabel ++ " should use expected S2K iteration count") + (IterationCount 65011712) + iter + if BL.null encryptedPayload + then assertFailure (testLabel ++ " should have non-empty encrypted key material") + else pure () + SUUnencrypted _ _ -> + assertFailure (testLabel ++ " should be encrypted, got unencrypted secret material") + _ -> + assertFailure + (testLabel ++ " should be encrypted with SUSSHA1/AES256/IteratedSalted SHA256") + +testV4EncryptedRevocationArmor :: Assertion +testV4EncryptedRevocationArmor = do + armors <- loadArmor "v4-encrypted.rev.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure "v4 encrypted revocation fixture should contain one armored payload" >> + fail "expected one armored payload" + (headers, payload) <- + case armor of + Armor ArmorPublicKeyBlock hs p -> pure (hs, p) + Armor atype _ _ -> + assertFailure + ("v4 encrypted revocation fixture should decode as a public key block, got " ++ + show atype) >> + fail "expected public key block" + _ -> + assertFailure + "v4 encrypted revocation fixture should decode as an armored payload" >> + fail "expected armored payload" + assertEqual + "v4 encrypted revocation fixture should keep identifying comments" + [ ("Comment", "Revocation certificate for") + , ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + , ("Comment", "") + , ("Comment", "v4 Test User") + ] + headers + let packets = parsePkts payload + case packets of + [PublicKeyPkt pkp, SignaturePkt _] -> do + assertEqual + "v4 encrypted revocation fixture should contain a v4 public key" + V4 + (_keyVersion pkp) + assertEqual + "v4 encrypted revocation fixture should contain the expected public key fingerprint" + (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + (fingerprint pkp) + assertEqual + "v4 encrypted revocation fixture should use EdDSA for its public key" + EdDSA + (_pkalgo pkp) + _ -> + assertFailure + ("v4 encrypted revocation fixture should contain [PublicKeyPkt, SignaturePkt], got: " ++ + show packets) + +testV6RevocationArmor :: FilePath -> Assertion +testV6RevocationArmor fixture = do + armors <- loadArmor fixture + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure (fixture ++ " fixture should contain one armored payload") >> + fail "expected one armored payload" + payload <- + case armor of + Armor ArmorPublicKeyBlock _ p -> pure p + Armor atype _ _ -> + assertFailure + (fixture ++ " fixture should decode as a public key block, got " ++ show atype) >> + fail "expected public key block" + _ -> + assertFailure (fixture ++ " fixture should decode as an armored payload") >> + fail "expected armored payload" + let packets = parsePkts payload + case packets of + [PublicKeyPkt pkp, SignaturePkt sig] -> do + assertEqual + (fixture ++ " should contain a v6 public key") + V6 + (_keyVersion pkp) + case sig of + SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _ -> do + let issuerFps = + [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed + ] + if fingerprint pkp `elem` issuerFps + then pure () + else + assertFailure + (fixture ++ " should include an IssuerFingerprint v6 matching the public key") + _ -> + assertFailure + (fixture ++ " should contain a SigV6 key-revocation signature") + _ -> + assertFailure + (fixture ++ " should contain [PublicKeyPkt, SignaturePkt], got: " ++ + show packets) + +testV6RevocationSignatureSaltSemantics :: FilePath -> Assertion +testV6RevocationSignatureSaltSemantics fixture = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") >> + fail "expected one armored payload" + let packets = parsePkts payload + (pkp, sig) <- + case packets of + [PublicKeyPkt pk, SignaturePkt sigV6@(SigV6 _ _ _ _ _ _ _ _)] -> pure (pk, sigV6) + _ -> + assertFailure + (fixture ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6], got " ++ show packets) >> + fail "unexpected revocation fixture packet shape" + case sig of + SigV6 _ _ ha salt _ _ _ _ -> + case expectedV6SaltSizeForTest ha of + Nothing -> + assertFailure + (fixture ++ " uses unsupported v6 signature salt hash algorithm: " ++ show ha) + Just expected -> + assertEqual + (fixture ++ " SigV6 salt size should match hash algorithm") + expected + (fromIntegral (BL.length (unSignatureSalt salt))) + other -> + assertFailure + (fixture ++ " expected SigV6 revocation signature payload, got: " ++ show other) + assertBool + (fixture ++ " should include IssuerFingerprint v6 for the revoked key") + (signatureHasIssuerFingerprintV6 (fingerprint pkp) sig) + +testV4RevocationSignatureSemantics :: Assertion +testV4RevocationSignatureSemantics = do + armors <- loadArmor "v4-encrypted.rev.aa" + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + "v4-encrypted.rev.aa should contain one armored public-key payload" >> + fail "expected one armored payload" + let packets = parsePkts payload + case packets of + [PublicKeyPkt _, SignaturePkt (SigV4 KeyRevocationSig _ _ hashed unhashed _ _)] -> do + assertBool + "v4-encrypted.rev.aa key-revocation signature should include an Issuer key-id subpacket" + (any isIssuerSubpacket (hashed ++ unhashed)) + _ -> + assertFailure + ("v4-encrypted.rev.aa should parse as [PublicKeyPkt, SignaturePkt SigV4 KeyRevocationSig], got " ++ + show packets) + where + isIssuerSubpacket (SigSubPacket _ Issuer {}) = True + isIssuerSubpacket _ = False + +testV6RevocationSignatureRejectsLegacyIssuerKeyID :: FilePath -> Assertion +testV6RevocationSignatureRejectsLegacyIssuerKeyID fixture = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") >> + fail "expected one armored payload" + let packets = parsePkts payload + case packets of + [PublicKeyPkt _, SignaturePkt (SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _)] -> + assertBool + (fixture ++ " SigV6 key-revocation signature must not include Issuer key-id subpackets") + (all (not . isIssuerSubpacket) (hashed ++ unhashed)) + _ -> + assertFailure + (fixture ++ + " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]") + where + isIssuerSubpacket (SigSubPacket _ Issuer {}) = True + isIssuerSubpacket _ = False + +testRevocationArmorParsesAsSingleTransferableKey :: FilePath -> Bool -> Assertion +testRevocationArmorParsesAsSingleTransferableKey fixture expectDirectRevs = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") >> + fail "expected one armored payload" + let tks = parseUnknownTKs True (parsePkts payload) + case tks of + [tk] -> do + if expectDirectRevs + then + assertBool + (fixture ++ " transferable key should contain at least one direct-key revocation signature") + (not (null (_tkuRevs tk))) + else pure () + assertEqual + (fixture ++ " revocation certificate should not carry user IDs") + [] + (_tkuUIDs tk) + assertEqual + (fixture ++ " revocation certificate should not carry user attributes") + [] + (_tkuUAts tk) + assertEqual + (fixture ++ " revocation certificate should not carry subkeys") + [] + (_tkuSubs tk) + _ -> + assertFailure + (fixture ++ " should parse into exactly one transferable key") + +testMsg1ArmorFixture :: Assertion +testMsg1ArmorFixture = do + armors <- loadArmor "msg1.asc" + assertBool "msg1.asc should decode to at least one armor block" (not (null armors)) + let packetBlocks = + [ parsePkts payload + | Armor _ _ payload <- armors + ] + assertBool + "msg1.asc should contain at least one parseable packet block" + (any (not . null) packetBlocks) + +expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int +expectedV6SaltSizeForTest = + fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm + +signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool +signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = + expectedFp `elem` + [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed + ] +signatureHasIssuerFingerprintV6 _ _ = False + +testDefaultedEncryptDecrypt :: Assertion +testDefaultedEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip1" + payload = mkClearPayload "hello from a balloon farm on Mars" + encryptedResult = encryptMessageDefault DoNotExposeSessionMaterial passphrase payload + encrypted <- + case encryptedResult of + Left err -> + assertFailure ("encryptMessageDefault failed: " ++ show err) >> + fail "encryptMessageDefault failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES256 OCB _ iv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 _ _)] -> do + assertBool "default SKESK v6 IV should be present" (not (BL.null iv)) + assertBool "default SKESK v6 wrapped session key should be present" (not (BL.null esk)) + assertEqual "default SKESK v6 tag length" 16 (BL.length tag) + other -> + assertFailure + ("default encryption should emit SKESK v6 + SEIPD v2 packets, got " ++ + show other) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryptMessage failed: " ++ show err) >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual "default encrypt/decrypt payload roundtrip" payload decrypted + +testExplicitEncryptDecrypt :: Assertion +testExplicitEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip2" + payload = mkClearPayload "hello from nonsenseville" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + iv = IV "1234567890ABCDEF" + encrypted <- + case + encryptMessage + (RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = AES128 + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + }) + passphrase + payload of + Left err -> + assertFailure ("micro-managed encryption failed: " ++ show err) >> + fail "encryptMessage failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES128 OCB _ packetIv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 OCB 6 _ _)] -> do + assertBool "explicit SKESK v6 IV should be present" (not (BL.null packetIv)) + assertBool "explicit SKESK v6 wrapped session key should be present" (not (BL.null esk)) + assertEqual "explicit SKESK v6 tag length" 16 (BL.length tag) + other -> + assertFailure + ("explicit AES encryption should default to SKESK v6 + SEIPD v2 packets, got " ++ + show other) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryption failed: " ++ show err) >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual "specific encrypt/decrypt payload roundtrip" payload decrypted + +testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion +testExplicitEncryptExposesEffectiveSessionMaterial = do + let passphraseBytes = "roundtrip2-session-material" + passphrase = mkPassphrase passphraseBytes + payload = mkClearPayload "hello from session material town" + sa = AES128 + s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15 + iv = IV "ABCDEF1234567890" + (encrypted, recovered) <- + case + encryptMessage + (RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = ExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = sa + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + }) + passphrase + payload of + Left err -> + assertFailure ("explicit encryption with session material failed: " ++ show err) >> + fail "encryptMessage failed" + Right x -> pure x + expectedSessionKey <- + case keySize sa of + Left err -> + assertFailure ("failed to derive expected key size: " ++ show err) >> + fail "keySize failed" + Right keyLen -> + case string2Key s2k keyLen passphraseBytes of + Left err -> + assertFailure ("failed to derive expected session key: " ++ renderS2KError err) >> + fail "string2Key failed" + Right bs -> pure bs + case recovered of + Just recoveredSessionMaterial -> do + assertEqual "recovered session material algorithm" sa (recoveredSessionAlgorithm recoveredSessionMaterial) + assertEqual + "recovered session material key" + (SessionKey expectedSessionKey) + (recoveredSessionKey recoveredSessionMaterial) + Nothing -> + assertFailure "expected exposed session material" + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryption failed: " ++ show err) >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual "session-material exposing encrypt/decrypt payload roundtrip" payload decrypted + +testDefaultEncryptDoesNotExposeSessionMaterial :: Assertion +testDefaultEncryptDoesNotExposeSessionMaterial = do + let passphrase = mkPassphrase "roundtrip-default-no-session-material" + payload = mkClearPayload "hello from hidden-session-material town" + (_, recovered) <- + do + let encryptedResult = + encryptMessageDefault DoNotExposeSessionMaterial passphrase payload + case encryptedResult of + Left err -> + assertFailure ("default encryption with exposure mode failed: " ++ show err) >> + fail "encryptMessageDefault failed" + Right x -> pure x + case recovered of + Nothing -> pure () + Just _ -> assertFailure "default exposure mode should not return session material" + +testExplicitAES128AEADEncryptDecrypt :: AEADAlgorithm -> Int -> String -> Assertion +testExplicitAES128AEADEncryptDecrypt aead expectedIvLen label = do + let passphraseBytes = "roundtrip-" <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label)) + passphrase = mkPassphrase passphraseBytes + payload = mkClearPayload ("hello from " <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))) + s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 + salt = Salt (B.pack [0x20 .. 0x3f]) + block = Block [LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload)] + packets <- + case encryptSEIPDv2WithSKESKBlock AES128 aead 6 salt s2k passphraseBytes block of + Left err -> + assertFailure ("AES-128 " ++ label ++ " encryption failed: " ++ err) >> + fail "encryptSEIPDv2WithSKESKBlock failed" + Right ps -> pure ps + let encrypted = mkEncryptedPayload (runPut (put (Block packets))) + case parsePkts (encryptedPayloadBytes encrypted) of + [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES128 parsedAead _ iv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 payloadAead 6 _ _)] -> do + assertEqual ("AES-128 " ++ label ++ " SKESK AEAD") aead parsedAead + assertEqual ("AES-128 " ++ label ++ " payload AEAD") aead payloadAead + assertEqual + ("AES-128 " ++ label ++ " SKESK v6 IV length") + (fromIntegral expectedIvLen) + (BL.length iv) + assertBool ("AES-128 " ++ label ++ " wrapped session key should be present") (not (BL.null esk)) + assertEqual ("AES-128 " ++ label ++ " SKESK tag length") 16 (BL.length tag) + other -> + assertFailure + ("AES-128 " ++ label ++ " encryption should emit matching SKESK v6 + SEIPD v2 packets, got " ++ + show other) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("AES-128 " ++ label ++ " decryption failed: " ++ show err) >> + fail "decryptMessage failed" + Right bs -> pure bs + assertEqual ("AES-128 " ++ label ++ " payload roundtrip") payload decrypted + +testExplicitAES128EAXEncryptDecrypt :: Assertion +testExplicitAES128EAXEncryptDecrypt = do + let passphraseBytes = "roundtrip-EAX" + s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 + salt = Salt (B.pack [0x20 .. 0x3f]) + block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"] + case encryptSEIPDv2WithSKESKBlock AES128 EAX 6 salt s2k passphraseBytes block of + Left err + | "EAX is currently unsupported by the crypton AEAD backend" `isInfixOf` err -> + pure () + | otherwise -> + assertFailure ("expected explicit EAX backend limitation, got: " ++ err) + Right packets -> + assertFailure + ("expected AES-128 EAX encryption to fail explicitly, got packets: " ++ show packets) + +testExplicitAES128GCMEncryptDecrypt :: Assertion +testExplicitAES128GCMEncryptDecrypt = + testExplicitAES128AEADEncryptDecrypt GCM 12 "GCM" + +testExplicitEncryptRejectsDeprecatedS2KHash :: Assertion +testExplicitEncryptRejectsDeprecatedS2KHash = do + let passphrase = mkPassphrase "roundtrip2b" + payload = mkClearPayload "modern-path deprecated s2k hash rejection" + s2k = Salted SHA1 (Salt8 "12345678") + iv = IV "1234567890ABCDEF" + case + encryptMessage + (RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = AES128 + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + }) + passphrase + payload of + Left (MessageEncryptError err) + | "deprecated hash algorithm disallowed for modern message generation" `isInfixOf` err -> + pure () + | otherwise -> + assertFailure ("Expected deprecated modern S2K hash rejection, got: " ++ err) + Left err -> + assertFailure ("Expected MessageEncryptError for deprecated modern S2K hash, got " ++ show err) + Right _ -> + assertFailure "Expected encryptMessage AES128 to reject deprecated SHA1 S2K" + +testLegacyFallbackEncryptDecrypt :: Assertion +testLegacyFallbackEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip3" + payload = mkClearPayload "hello from legacy town" + s2k = Salted SHA1 (Salt8 "12345678") + iv = IV mempty + encrypted <- + case + encryptMessage + (RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = Plaintext + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + }) + passphrase + payload of + Left err -> + assertFailure ("legacy fallback encryption failed: " ++ show err) >> + fail "encryptMessage fallback failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 Plaintext _ Nothing)), SymEncIntegrityProtectedDataPkt (SEIPD1 1 _)] -> pure () + other -> + assertFailure + ("non-AES explicit encryption should use RFC4880 SKESKv4 + SEIPDv1 packets, got " ++ + show other) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("legacy fallback decryption failed: " ++ show err) >> + fail "decryptMessage fallback failed" + Right bs -> pure bs + assertEqual "legacy fallback encrypt/decrypt payload roundtrip" payload decrypted + +testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion +testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do + let passphraseBytes = "legacy-clean-parse" :: BL.ByteString + passphrase = mkPassphrase passphraseBytes + payload = mkClearPayload "hello from clean legacy town" + s2k = IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) + iv = IV "1234567890ABCDEF" + encrypted <- + case + encryptMessage + (RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = AES128 + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + }) + passphrase + payload of + Left err -> + assertFailure ("RFC4880 encryption failed: " ++ show err) >> + fail "encryptMessage failed" + Right (bs, _) -> pure bs + packets <- + case parsePktsEither (encryptedPayloadBytes encrypted) of + Left err -> + assertFailure ("encrypted packet parse failed: " ++ show err) >> + fail "parsePktsEither failed" + Right ps -> pure ps + ciphertext <- + case packets of + [SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 parsedSA parsedS2K Nothing)), SymEncIntegrityProtectedDataPkt (SEIPD1 1 payloadBytes)] -> do + assertEqual "RFC4880 encrypted SKESK algorithm" AES128 parsedSA + assertEqual "RFC4880 encrypted S2K" s2k parsedS2K + pure (BL.toStrict payloadBytes) + other -> + assertFailure + ("RFC4880 encryption should emit SKESKv4 + SEIPDv1 packets, got " ++ + show other) >> + fail "unexpected encrypted packet layout" + keyLen <- + case keySize AES128 of + Left err -> + assertFailure ("keySize failed for AES128: " ++ show err) >> + fail "keySize failed" + Right n -> pure n + sessionKey <- + case string2Key s2k keyLen passphraseBytes of + Left err -> + assertFailure ("string2Key failed: " ++ renderS2KError err) >> + fail "string2Key failed" + Right keyBytes -> pure keyBytes + (nonce, decrypted) <- + case decryptPreservingNonce AES128 ciphertext sessionKey of + Left err -> + assertFailure ("decryptPreservingNonce failed: " ++ show err) >> + fail "decryptPreservingNonce failed" + Right out -> pure out + cleartext <- + case validateSEIPD1MDC nonce decrypted of + Left err -> + assertFailure ("validateSEIPD1MDC failed: " ++ err) >> + fail "validateSEIPD1MDC failed" + Right out -> pure out + case parsePktsEither (BL.fromStrict cleartext) of + Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do + assertEqual "RFC4880 decrypted literal filename" BL.empty filename + assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp + assertEqual "RFC4880 decrypted literal payload" (clearPayloadBytes payload) clearPayload + Right other -> + assertFailure + ("RFC4880 decrypted cleartext should contain exactly one literal packet, got " ++ + show other) + Left err -> + assertFailure + ("RFC4880 decrypted cleartext should parse without trailing junk, got " ++ + show err) + +testDecryptMessageTypedParseFailure :: Assertion +testDecryptMessageTypedParseFailure = do + let passphrase = mkPassphrase "unused" + encrypted = mkEncryptedPayload BL.empty + case decryptMessage passphrase encrypted of + Left (MessageParseFailureError MissingEncryptedMessage) -> pure () + Left err -> + assertFailure ("Expected MissingEncryptedMessage parse failure, got " ++ show err) + Right clear -> + assertFailure ("Expected parse failure, got payload " ++ show clear) + +testDecryptMessageRejectsUnknownCriticalPacket :: Assertion +testDecryptMessageRejectsUnknownCriticalPacket = do + let passphrase = mkPassphrase "unused" + encrypted = + mkEncryptedPayload . runPut . put $ + Block [OtherPacketPkt 39 "unknown-critical"] + case decryptMessage passphrase encrypted of + Left (MessageParseFailureError (UnknownCriticalPacketType 39)) -> pure () + Left err -> + assertFailure + ("Expected UnknownCriticalPacketType 39 parse failure, got " ++ show err) + Right clear -> + assertFailure + ("Expected unknown critical packet rejection, got payload " ++ show clear) + +testDecryptMessageTypedDecryptFailure :: Assertion +testDecryptMessageTypedDecryptFailure = do + let correctPassphrase = mkPassphrase "correct passphrase" + wrongPassphrase = mkPassphrase "wrong passphrase" + payload = mkClearPayload "typed decrypt failure payload" + encryptedResult = + encryptMessageDefault DoNotExposeSessionMaterial correctPassphrase payload + encrypted <- + case encryptedResult of + Left err -> + assertFailure ("encryptMessageDefault failed: " ++ show err) >> + fail "encryptMessageDefault failed" + Right (bs, _) -> pure bs + case decryptMessage wrongPassphrase encrypted of + Left (MessageDecryptFailureError (PayloadDecryptFailed _)) -> pure () + Left (MessageDecryptFailureError (SessionMaterialDerivationFailed _)) -> pure () + Left err -> + assertFailure ("Expected typed decrypt failure, got " ++ show err) + Right clear -> + assertFailure ("Expected decrypt failure, got payload " ++ show clear) + +testDecryptMessageSEIPDv1MDCTampering :: Assertion +testDecryptMessageSEIPDv1MDCTampering = do + let passphrase = mkPassphrase "mdc-tamper-test" + payload = mkClearPayload "payload for MDC tampering test" + s2k = IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) + iv = IV "1234567890ABCDEF" + encrypted <- + case encryptMessage + (RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = AES128 + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + }) + passphrase + payload of + Left err -> + assertFailure ("SEIPDv1 encryption failed: " ++ show err) >> + fail "encryptMessage failed" + Right (bs, _) -> pure bs + let raw = encryptedPayloadBytes encrypted + midpoint = BL.length raw `div` 2 + tampered = BL.take midpoint raw <> + BL.cons (BL.head (BL.drop midpoint raw) `xor` 0xFF) + (BL.drop (midpoint + 1) raw) + case decryptMessage passphrase (mkEncryptedPayload tampered) of + Left (MessageDecryptFailureError (PayloadDecryptFailed msg)) + | "MDC" `isInfixOf` msg -> pure () + | otherwise -> + assertFailure + ("Expected MDC-related PayloadDecryptFailed, got: " ++ msg) + Left err -> + assertFailure + ("Expected PayloadDecryptFailed with MDC error, got: " ++ show err) + Right _ -> + assertFailure "Expected MDC tampering rejection, but decryption succeeded" + +testSignMessageShape :: Assertion +testSignMessageShape = do + (signer, signingKey) <- loadUnencryptedRsaSigner + signerV4 <- expectV4PKPayload "RSA v4 signer" signer + signedResult <- signMessageWith (mkRSASignerV4 signerV4 signingKey) (mkClearPayload "message-api signing payload") + signedMessage <- + case signedResult of + Left err -> + assertFailure ("message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + case parsePkts signedMessage of + [LiteralDataPkt {}, SignaturePkt _] -> pure () + _ -> assertFailure "signing output should contain literal data and one signature packet" + +testSignMessageRSAV6 :: Assertion +testSignMessageRSAV6 = do + (signer, signingKey) <- loadUnencryptedRsaSignerV6 + signerV6 <- expectV6PKPayload "RSA v6 signer" signer + let payload = "message-api signing payload with RSA SigV6" + signedResult <- signMessageWith (mkRSASignerV6 signerV6 signingKey) (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("RSA SigV6 message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig RSA SHA512 salt _ _ _ _))] -> do + assertEqual "SigV6 RSA salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ("RSA SigV6 signing output should contain [LiteralDataPkt, RSA SigV6], got " ++ + show other) >> + fail "unexpected RSA SigV6 signMessage output shape" + let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of + Left err -> + assertFailure + ("RSA SigV6 signed message verification failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testSignMessageEd25519 :: Assertion +testSignMessageEd25519 = do + (signer, signingKey) <- loadDeterministicEd25519Signer + signerV4 <- expectV4PKPayload "Ed25519 v4 signer" signer + let payload = "message-api signing payload with Ed25519" + signedResult <- signMessageWith (mkEd25519SignerV4 signerV4 signingKey) (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed25519 message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))] -> + pure sig + other -> + assertFailure + ("Ed25519 signing output should contain [LiteralDataPkt, Ed25519 SigV4], got " ++ + show other) >> + fail "unexpected Ed25519 signMessage output shape" + let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of + Left err -> + assertFailure + ("Ed25519 signed message verification failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testSignMessageEd25519V6 :: Assertion +testSignMessageEd25519V6 = do + (signer, signingKey) <- loadDeterministicEd25519SignerV6 + signerV6 <- expectV6PKPayload "Ed25519 v6 signer" signer + let payload = "message-api signing payload with Ed25519 SigV6" + signedResult <- signMessageWith (mkEd25519SignerV6 signerV6 signingKey) (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed25519 SigV6 message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _))] -> do + assertEqual "SigV6 Ed25519 salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ("Ed25519 SigV6 signing output should contain [LiteralDataPkt, Ed25519 SigV6], got " ++ + show other) >> + fail "unexpected Ed25519 SigV6 signMessage output shape" + case signaturePkt of + SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do + let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of + Left err -> + assertFailure + ("Ed25519 SigV6 signed message verification failed: " ++ + renderVerificationError err) + Right _ -> pure () + _ -> assertFailure "expected an Ed25519 SigV6 signature packet" + +testV4Ed25519LegacyKeyRejectsMissingPrefix :: Assertion +testV4Ed25519LegacyKeyRejectsMissingPrefix = do + let legacyEd25519Oid = B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] + rawEd25519Public = B.replicate 32 0x01 + encoded = + runPut $ do + putWord8 4 + putWord32be 0 + putWord8 (fromFVal EdDSA) + putWord8 (fromIntegral (B.length legacyEd25519Oid)) + putByteString legacyEd25519Oid + putWord16be 256 + putByteString rawEd25519Public + case runGetOrFail (get :: Get SomePKPayload) encoded of + Left (_, _, err) -> + assertBool + ("expected invalid-legacy-point parse failure, got: " ++ err) + ("invalid Ed25519Legacy public key" `isInfixOf` err) + Right _ -> + assertFailure "legacy Ed25519 key without 0x40 prefix should be rejected" + +testSignMessageEd448 :: Assertion +testSignMessageEd448 = do + (signer, signingKey) <- loadDeterministicEd448Signer + signerV4 <- expectV4PKPayload "Ed448 v4 signer" signer + let payload = "message-api signing payload with Ed448" + signedResult <- signMessageWith (mkEd448SignerV4 signerV4 signingKey) (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed448 message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _))] -> + pure sig + other -> + assertFailure + ("Ed448 signing output should contain [LiteralDataPkt, Ed448 SigV4], got " ++ + show other) >> + fail "unexpected Ed448 signMessage output shape" + let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of + Left err -> + assertFailure + ("Ed448 signed message verification failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testSignMessageEd448V6 :: Assertion +testSignMessageEd448V6 = do + (signer, signingKey) <- loadDeterministicEd448SignerV6 + signerV6 <- expectV6PKPayload "Ed448 v6 signer" signer + let payload = "message-api signing payload with Ed448 SigV6" + signedResult <- signMessageWith (mkEd448SignerV6 signerV6 signingKey) (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed448 SigV6 message signing failed: " ++ show err) >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _))] -> do + assertEqual "SigV6 Ed448 salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ("Ed448 SigV6 signing output should contain [LiteralDataPkt, Ed448 SigV6], got " ++ + show other) >> + fail "unexpected Ed448 SigV6 signMessage output shape" + case signaturePkt of + SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 _ _ _ _ _) -> pure () + _ -> assertFailure "expected an Ed448 SigV6 signature packet" + +testV4EdSignaturesUseNativeFixedWidthEncoding :: Assertion +testV4EdSignaturesUseNativeFixedWidthEncoding = do + (_, ed25519SigningKey) <- loadDeterministicEd25519Signer + ed25519Sig <- + case signDataWithEd25519 BinarySig ed25519SigningKey [] [] "v4 ed25519 encoding" of + Left err -> + assertFailure ("Ed25519 v4 signing failed: " ++ renderSignError err) >> + fail "expected Ed25519 signature" + Right sig -> pure sig + case extractV4SignatureAlgorithmFields (runPut (put ed25519Sig)) of + Left err -> + assertFailure ("failed to decode serialized Ed25519 v4 signature payload: " ++ err) + Right (pka, algorithmFields) -> do + assertEqual "Ed25519 v4 signature packet algorithm id" PKA.Ed25519 pka + assertEqual "Ed25519 v4 algorithm field width" 64 (B.length algorithmFields) + + (_, ed448SigningKey) <- loadDeterministicEd448Signer + ed448Sig <- + case signDataWithEd448 BinarySig ed448SigningKey [] [] "v4 ed448 encoding" of + Left err -> + assertFailure ("Ed448 v4 signing failed: " ++ renderSignError err) >> + fail "expected Ed448 signature" + Right sig -> pure sig + case extractV4SignatureAlgorithmFields (runPut (put ed448Sig)) of + Left err -> + assertFailure ("failed to decode serialized Ed448 v4 signature payload: " ++ err) + Right (pka, algorithmFields) -> do + assertEqual "Ed448 v4 signature packet algorithm id" PKA.Ed448 pka + assertEqual "Ed448 v4 algorithm field width" 114 (B.length algorithmFields) + +testVerifyDetachedEd25519WithoutIssuerHints :: Assertion +testVerifyDetachedEd25519WithoutIssuerHints = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload without issuer hints" + state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] [] payload of + Left err -> + assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + case verifySigWith (verifyAgainstKeyring keyring) (SignaturePkt sigPayload) state Nothing of + Left err -> + assertFailure + ("Ed25519 detached verification without issuer hints failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testVerifyDetachedEd25519WithFakeIssuerHint :: Assertion +testVerifyDetachedEd25519WithFakeIssuerHint = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload with fake issuer hint" + state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" + unhashed = [SigSubPacket False (Issuer fakeIssuer)] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] unhashed payload of + Left err -> + assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + case verifySigWith (verifyAgainstKeyring keyring) (SignaturePkt sigPayload) state Nothing of + Left err -> + assertFailure + ("Ed25519 detached verification with fake issuer hint failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys :: Assertion +testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)" + state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keys = [TKUnknown (signer, Nothing) [] [] [] []] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] [] payload of + Left err -> + assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + case verifySigWith (verifyAgainstKeys keys) (SignaturePkt sigPayload) state Nothing of + Left err -> + assertFailure + ("Ed25519 detached verification against keys without issuer hints failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys :: Assertion +testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)" + state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keys = [TKUnknown (signer, Nothing) [] [] [] []] + fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" + unhashed = [SigSubPacket False (Issuer fakeIssuer)] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] unhashed payload of + Left err -> + assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + case verifySigWith (verifyAgainstKeys keys) (SignaturePkt sigPayload) state Nothing of + Left err -> + assertFailure + ("Ed25519 detached verification against keys with fake issuer hint failed: " ++ + renderVerificationError err) + Right _ -> pure () + +testCanonicalTextSigPayloadNormalization :: Assertion +testCanonicalTextSigPayloadNormalization = do + let state = + emptyPSC + { lastLD = + LiteralDataPkt + TextData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "line1 \t\nline2\t \rline3\t \r\nline4 \t" + } + assertEqual + "Binary signatures preserve original line endings" + "line1 \t\nline2\t \rline3\t \r\nline4 \t" + (payloadForSig BinarySig state) + assertEqual + "Canonical text signatures normalize line endings and trim trailing whitespace" + "line1\r\nline2\r\nline3\r\nline4" + (payloadForSig CanonicalTextSig state) + +testTextNormalizationModes :: Assertion +testTextNormalizationModes = do + let state = + emptyPSC + { lastLD = + LiteralDataPkt + TextData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "line1 \t\nline2\t \r\nline3" + } + let cleartextResult = payloadForSigWith CleartextCompat CanonicalTextSig state + strictResult = payloadForSigWith RFC9580Strict CanonicalTextSig state + assertEqual + "CleartextCompat mode strips trailing whitespace per line" + "line1\r\nline2\r\nline3" + cleartextResult + assertEqual + "RFC9580Strict mode preserves trailing whitespace (CRLF-only normalization)" + "line1 \t\r\nline2\t \r\nline3" + strictResult + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id: " ++ err) >> + fail "expected issuer key id" + Right i -> pure i + let payload = "line with trailing space \nno trailing space\n" + hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] + unhashed = [SigSubPacket False (Issuer issuerKeyId)] + builderCompat = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 + builderStrict = (sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512) { sbTextNormMode = RFC9580Strict } + withSubs b = addUnhashedSubs (listToUnhashedSubs unhashed) (addHashedSubs (listToHashedSubs hashed) b) + bc = withSubs builderCompat + bs = withSubs builderStrict + sigCompat <- case signDataWithRSABuilder bc signingKey payload of + Left err -> assertFailure ("CleartextCompat sign failed: " ++ renderSignError err) >> fail "" + Right s -> pure s + sigStrict <- case signDataWithRSABuilder bs signingKey payload of + Left err -> assertFailure ("RFC9580Strict sign failed: " ++ renderSignError err) >> fail "" + Right s -> pure s + assertBool + "CleartextCompat and RFC9580Strict produce different signatures for payloads with trailing whitespace" + (sigCompat /= sigStrict) + +testCanonicalTextSignatureSigningPaths :: Assertion +testCanonicalTextSignatureSigningPaths = do + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id: " ++ err) >> + fail "expected issuer key id" + Right i -> pure i + let mixedPayload = "line1 \t\nline2\t \rline3\t \r\nline4 \t" + normalizedPayload = "line1\r\nline2\r\nline3\r\nline4" + hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] + unhashed = [SigSubPacket False (Issuer issuerKeyId)] + primitiveMixed <- + case signDataWithRSA CanonicalTextSig signingKey hashed unhashed mixedPayload of + Left err -> + assertFailure ("canonical text primitive signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + primitiveNormalized <- + case signDataWithRSA CanonicalTextSig signingKey hashed unhashed normalizedPayload of + Left err -> + assertFailure ("canonical text primitive signing (normalized payload) failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + assertEqual + "primitive canonical text signing should normalize mixed line endings" + primitiveNormalized + primitiveMixed + + let builder = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + builderMixed <- + case signDataWithRSABuilder withUnhashed signingKey mixedPayload of + Left err -> + assertFailure ("canonical text builder signing failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + builderNormalized <- + case signDataWithRSABuilder withUnhashed signingKey normalizedPayload of + Left err -> + assertFailure ("canonical text builder signing (normalized payload) failed: " ++ renderSignError err) >> + fail (renderSignError err) + Right sig -> pure sig + assertEqual + "builder canonical text signing should normalize mixed line endings" + builderNormalized + builderMixed + +testSignaturePrimitives :: Assertion +testSignaturePrimitives = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let userId = UserId "primitive-api@example.org" + assertSigType :: + String -> SigType -> Either SignError SignaturePayload -> Assertion + assertSigType testLabel expected result = + case result of + Left err -> assertFailure (testLabel ++ " failed: " ++ renderSignError err) + Right (SigV4 sigType _ _ _ _ _ _) -> + assertEqual (testLabel ++ " uses expected signature type") expected sigType + Right _ -> assertFailure (testLabel ++ " should generate a V4 signature payload") + assertSigType + "certification signature" + GenericCert + (signCertificationWithRSA GenericCert signer userId [] [] signingKey) + assertSigType + "key revocation signature" + KeyRevocationSig + (signKeyRevocationWithRSA signer [] [] signingKey) + assertSigType + "subkey revocation signature" + SubkeyRevocationSig + (signSubkeyRevocationWithRSA signer signer [] [] signingKey) + assertSigType + "certification revocation signature" + CertRevocationSig + (signCertRevocationWithRSA signer userId [] [] signingKey) + let left16Payload = "left16 primitive payload" + left16Keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + left16Sig <- + case signDataWithRSA BinarySig signingKey [] [] left16Payload of + Left err -> + assertFailure ("RSA primitive signing for left16 failed: " ++ renderSignError err) >> + fail "expected RSA signature payload" + Right sigPayload -> pure sigPayload + case verifyAgainstKeyring left16Keyring (SignaturePkt left16Sig) Nothing left16Payload of + Right _ -> pure () + Left err -> + assertFailure + ("fresh RSA signature should verify with matching left16, got: " ++ + renderVerificationError err) + let tamperedLeft16Sig = + case left16Sig of + SigV4 st pka ha hs us l16 mpis -> SigV4 st pka ha hs us (l16 + 1) mpis + other -> other + case verifyAgainstKeyring left16Keyring (SignaturePkt tamperedLeft16Sig) Nothing left16Payload of + Left _ -> pure () + Right _ -> + assertFailure "verification unexpectedly succeeded with tampered left16" + if isRight (signCertificationWithRSA KeyRevocationSig signer userId [] [] signingKey) + then + assertFailure + "certification primitive should reject non-certification signature types" + else pure () + (edSigner, edSigningKey) <- loadDeterministicEd25519Signer + edIssuerKeyId <- + case eightOctetKeyID edSigner of + Left err -> + assertFailure ("failed to derive Ed25519 issuer key id: " ++ err) >> + fail "expected Ed25519 issuer key id" + Right i -> pure i + let edPayload = "primitive Ed25519 payload" + edHashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint edSigner))] + edUnhashed = [SigSubPacket False (Issuer edIssuerKeyId)] + case signDataWithEd25519 BinarySig edSigningKey edHashed edUnhashed edPayload of + Left err -> assertFailure ("Ed25519 primitive signing failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure ("Ed25519 primitive should generate an Ed25519 SigV4 payload, got " ++ show other) + let v6Salt = SignatureSalt (BL.replicate 32 0x42) + case signDataWithEd25519V6 BinarySig v6Salt edSigningKey edHashed edUnhashed edPayload of + Left err -> assertFailure ("Ed25519 SigV6 primitive signing failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> + assertEqual "Ed25519 SigV6 primitive should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure ("Ed25519 SigV6 primitive should generate an Ed25519 SigV6 payload, got " ++ show other) + (ed448Signer, ed448SigningKey) <- loadDeterministicEd448Signer + ed448IssuerKeyId <- + case eightOctetKeyID ed448Signer of + Left err -> + assertFailure ("failed to derive Ed448 issuer key id: " ++ err) >> + fail "expected Ed448 issuer key id" + Right i -> pure i + let ed448Payload = "primitive Ed448 payload" + ed448Hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint ed448Signer))] + ed448Unhashed = [SigSubPacket False (Issuer ed448IssuerKeyId)] + case signDataWithEd448 BinarySig ed448SigningKey ed448Hashed ed448Unhashed ed448Payload of + Left err -> assertFailure ("Ed448 primitive signing failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure ("Ed448 primitive should generate an Ed448 SigV4 payload, got " ++ show other) + case signDataWithEd448V6 BinarySig v6Salt ed448SigningKey ed448Hashed ed448Unhashed ed448Payload of + Left err -> assertFailure ("Ed448 SigV6 primitive signing failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _) -> + assertEqual "Ed448 SigV6 primitive should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure ("Ed448 SigV6 primitive should generate an Ed448 SigV6 payload, got " ++ show other) + +testSignatureDataKindsCoercions :: Assertion +testSignatureDataKindsCoercions = do + let sigV3 = + SigV3 + BinarySig + (ThirtyTwoBitTimeStamp 1) + (EightOctetKeyId "\x01\x02\x03\x04\x05\x06\x07\x08") + RSA + SHA256 + 0 + (NE.fromList [MPI 1]) + sigV4 = + SigV4 + BinarySig + RSA + SHA256 + [] + [] + 0 + (NE.fromList [MPI 2]) + sigV6 = + SigV6 + BinarySig + PKA.Ed25519 + SHA512 + (SignatureSalt (BL.replicate 32 0x01)) + [] + [] + 0 + (NE.fromList [MPI 3, MPI 4]) + sigOther = SigVOther 77 "opaque-signature-body" + assertPacketRoundTrip label expected pkt = + case fromPktEitherSomeSignatureV pkt of + Left err -> assertFailure (label ++ " packet coercion failed: " ++ err) + Right (SomeSignatureV typedSig) -> + assertEqual + (label ++ " packet coercion preserves payload") + expected + (signaturePayloadFromSignatureV typedSig) + assertBool + "toSomeSignaturePayload should preserve SigV3 witness" + (isRight (asSignaturePayloadV3 sigV3)) + assertBool + "toSomeSignaturePayload should preserve SigV4 witness" + (isRight (asSignaturePayloadV4 sigV4)) + assertBool + "toSomeSignaturePayload should preserve SigV6 witness" + (isRight (asSignaturePayloadV6 sigV6)) + assertBool + "toSomeSignaturePayload should preserve SigVOther witness" + (isRight (asSignaturePayloadOther sigOther)) + case asSignaturePayloadV3 sigV3 of + Left err -> assertFailure ("asSignaturePayloadV3 should accept SigV3: " ++ err) + Right typed -> + assertEqual "asSignaturePayloadV3 round-trips SigV3" sigV3 (toSignaturePayload typed) + case asSignaturePayloadV4 sigV4 of + Left err -> assertFailure ("asSignaturePayloadV4 should accept SigV4: " ++ err) + Right typed -> + assertEqual "asSignaturePayloadV4 round-trips SigV4" sigV4 (toSignaturePayload typed) + case asSignaturePayloadV6 sigV6 of + Left err -> assertFailure ("asSignaturePayloadV6 should accept SigV6: " ++ err) + Right typed -> + assertEqual "asSignaturePayloadV6 round-trips SigV6" sigV6 (toSignaturePayload typed) + case asSignaturePayloadOther sigOther of + Left err -> assertFailure ("asSignaturePayloadOther should accept SigVOther: " ++ err) + Right typed -> + assertEqual "asSignaturePayloadOther round-trips SigVOther" sigOther (toSignaturePayload typed) + assertBool + "asSignaturePayloadV6 rejects SigV4" + (not (isRight (asSignaturePayloadV6 sigV4))) + assertBool + "asSignaturePayloadV4 rejects SigVOther" + (not (isRight (asSignaturePayloadV4 sigOther))) + assertPacketRoundTrip "SigV3" sigV3 (SignaturePkt sigV3) + assertPacketRoundTrip "SigV4" sigV4 (SignaturePkt sigV4) + assertPacketRoundTrip "SigV6" sigV6 (SignaturePkt sigV6) + assertPacketRoundTrip "SigVOther" sigOther (SignaturePkt sigOther) + assertBool + "fromPktEitherSomeSignatureV rejects non-signature packets" + (not (isRight (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 "")))) + +testSignerTimelineSoftPrimaryRevocation :: Assertion +testSignerTimelineSoftPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "soft primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigAfterTime = addTimestampSeconds keyCreated 30 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAt signer signingKey revocationTime KeySuperseded + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "soft primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "soft primary revocation should reject post-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineHardPrimaryRevocation :: Assertion +testSignerTimelineHardPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "hard primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAt signer signingKey revocationTime KeyMaterialCompromised + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "hard primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineNoReasonPrimaryRevocation :: Assertion +testSignerTimelineNoReasonPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "no-reason primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAt signer signingKey revocationTime NoReason + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "no-reason primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineUnknownReasonPrimaryRevocation :: Assertion +testSignerTimelineUnknownReasonPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "unknown-reason primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAt signer signingKey revocationTime (RCoOther 100) + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "unknown-reason primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineNonCompromisePrimaryRevocationIsHistorical :: Assertion +testSignerTimelineNonCompromisePrimaryRevocationIsHistorical = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "non-compromise primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigAfterTime = addTimestampSeconds keyCreated 30 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + UserIdInfoNoLongerValid + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "non-compromise primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "non-compromise primary revocation should reject post-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineTemporaryPrimaryRevocationExpires :: Assertion +testSignerTimelineTemporaryPrimaryRevocationExpires = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "temporary primary revocation expiry timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigDuringTime = addTimestampSeconds keyCreated 25 + sigAfterTime = addTimestampSeconds keyCreated 35 + sigBefore <- + signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload + revocation <- + signKeyRevocationWithReasonAndExtrasAt + signer + signingKey + revocationTime + KeySuperseded + [SigSubPacket False (SigExpirationTime 10)] + sigDuring <- + signBinaryMessageWithRSAAt signer signingKey sigDuringTime payload + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "temporary primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "temporary primary revocation should reject signatures while revocation is effective" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigDuring) + assertSingleSignerFingerprint + "temporary primary revocation should allow signatures after revocation expiration" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineSubkeyRevocation :: Assertion +testSignerTimelineSubkeyRevocation = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySigner, subkeySigningKey) <- loadDeterministicEd25519Signer + let payload = "subkey revocation timeline payload" + keyCreated = _timestamp primarySigner + bindingTime = addTimestampSeconds keyCreated 10 + sigBeforeTime = addTimestampSeconds keyCreated 20 + revocationTime = addTimestampSeconds keyCreated 30 + sigAfterTime = addTimestampSeconds keyCreated 40 + subkeyPacket = PublicSubkeyPkt subkeySigner + bindingSig <- + signSubkeyBindingWithRSAAt primarySigner subkeySigner primarySigningKey bindingTime + sigBefore <- + signBinaryMessageWithEd25519At subkeySigner subkeySigningKey sigBeforeTime payload + revocationSig <- + signSubkeyRevocationWithRSAAt primarySigner subkeySigner primarySigningKey revocationTime + sigAfter <- + signBinaryMessageWithEd25519At subkeySigner subkeySigningKey sigAfterTime payload + let keyring = + mkTestKeyring + [TKUnknown (primarySigner, Nothing) [] [] [] [(subkeyPacket, [bindingSig, revocationSig])]] + assertSingleSignerFingerprint + "subkey revocation should preserve pre-revocation signatures" + (fingerprint subkeySigner) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "subkey revocation should reject post-revocation signatures" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload sigAfter) + +testSignMessageConvenience :: Assertion +testSignMessageConvenience = do + (signer, signingKey) <- loadUnencryptedRsaSigner + signerV4 <- expectV4PKPayload "RSA v4 convenience signer" signer + signedResult <- signMessage (mkRSASignerV4 signerV4 signingKey) "message-api convenience signing payload" + signedMessage <- + case signedResult of + Left err -> + assertFailure ("message signing convenience API failed: " ++ show err) >> pure mempty + Right bs -> pure bs + case parsePkts signedMessage of + [LiteralDataPkt {}, SignaturePkt _] -> pure () + _ -> assertFailure "convenience signing output should contain literal data and one signature packet" + +testTypedVerifySurfaceMatchesLegacy :: Assertion +testTypedVerifySurfaceMatchesLegacy = do + kr <- loadKeyring "pubring.gpg" + signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" + let typedResults = + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + kr + signedMessage + strictResults = + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + kr + signedMessage + normalizeTyped :: Either VerificationError Verification -> Either Bool Fingerprint + normalizeTyped (Left _) = Left False + normalizeTyped (Right v) = Right (fingerprint (_verificationSigner v)) + assertEqual + "strict verification should collapse informational failures" + (map normalizeTyped (either (pure . Left) (Right <$>) (sequence typedResults))) + (map normalizeTyped strictResults) + assertBool + "informational verification should emit at least one result for known-good fixture" + (not (null (map normalizeTyped typedResults))) + +testVerifyMessageStrictRejectsTamper :: Assertion +testVerifyMessageStrictRejectsTamper = do + kr <- loadKeyring "pubring.gpg" + packets <- loadAndDecompressPkts "uncompressed-ops-rsa.gpg" + let tamperedPackets = map tamperLiteral packets + strictOptions = + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + case verifyMessagePackets strictOptions kr tamperedPackets of + [Left _] -> pure () + _ -> assertFailure "strict typed verification should fail on tampered payload" + where + tamperLiteral (LiteralDataPkt dt fn ts payload) = + LiteralDataPkt dt fn ts (BL.snoc payload 0) + tamperLiteral pkt = pkt + +testVerifySignedMessageConvenience :: Assertion +testVerifySignedMessageConvenience = do + kr <- loadKeyring "pubring.gpg" + signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" + strictResult <- + pure + (verifySignedMessage + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + kr + signedMessage) + case strictResult of + [Left _] -> assertFailure "verifySignedMessage should succeed for known-good fixture" + verifications -> + assertBool "verifySignedMessage should emit at least one verification" (not (null verifications)) + +testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm :: Assertion +testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let signerWithEd25519Pka = setPKAlgorithm PKA.Ed25519 signer + signerV4 <- expectV4PKPayload "Ed25519 v4 signer with Ed25519 key algorithm" signerWithEd25519Pka + let payload = "v4 eddsa signature with Ed25519 key algorithm" + state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = mkTestKeyring [TKUnknown (signerWithEd25519Pka, Nothing) [] [] [] []] + signedResult <- + signMessageWith + (mkEd25519SignerV4 signerV4 signingKey) + (mkClearPayload payload) + signaturePkt <- + case signedResult of + Left err -> + assertFailure ("Ed25519 message signing failed: " ++ show err) >> + fail "expected signed Ed25519 payload" + Right signedMessage -> + case parsePkts signedMessage of + [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))] -> + pure sig + other -> + assertFailure + ("Expected [LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got " ++ + show other) >> + fail "unexpected Ed25519-key-algorithm signature shape" + case verifySigWith (verifyAgainstKeyring keyring) signaturePkt state Nothing of + Left err -> + assertFailure + ("Ed25519 SigV4 verification with Ed25519 key algorithm failed: " ++ + renderVerificationError err) + Right _ -> pure () + + diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Properties.hs @@ -0,0 +1,274 @@ +-- Properties.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Properties (propertiesTests) where + +import Codec.Encryption.OpenPGP.Encrypt (canonicalizePKESKRecipientId) +import Codec.Encryption.OpenPGP.Policy (OpenPGPPolicy(..), OpenPGPRFC(RFC4880), defaultPolicy, policyForRFC) +import Codec.Encryption.OpenPGP.KeyringParser (parseTKsWithWireRep) +import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) +import Codec.Encryption.OpenPGP.Serialize (parsePktsEither, parsePktsWithWireRep) +import Codec.Encryption.OpenPGP.Types +import Control.Exception (SomeException, try) +import Data.Binary (get, put) +import Data.Binary.Put (runPut) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.List as CL +import Data.Word (Word8) +import Test.Tasty (TestTree, localOption, testGroup) +import qualified Test.Tasty.QuickCheck as QC +import Tests.Common + ( collectSecretKeyInfos + , conduitDecryptWithPKESKContext + , loadSEIPDv2FixtureWithV4Secret + , loadV4EncryptedSecretKeyFixtureForProperty + , loadV6UnencryptedSecretKeyFixtureForProperty + , prependUnusableLatestPKESK + , readFixtureLazy + , reorderPrecedingPKESKs + , reverseIf + , runGet + , selectRecipientKeyInfo + ) + +propertiesTests :: TestTree +propertiesTests = testGroup "Properties" [qcProps] + +qcProps :: TestTree +qcProps = + testGroup + "(checked by QuickCheck)" + [ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk -> + Right (pkesk :: PKESK 'PKESKV3) == runGet get (runPut (put pkesk)) + , QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk -> + Right (pkesk :: PKESK 'PKESKV6) == runGet get (runPut (put pkesk)) + , QC.testProperty "Signature packet serialization-deserialization" $ \sig -> + (case _signaturePayload (sig :: Signature) of + SigVOther _ _ -> False + _ -> True) QC.==> + Right (sig :: Signature) == runGet get (runPut (put sig)) + , QC.testProperty "UserId packet serialization-deserialization" $ \uid -> + Right (uid :: UserId) == runGet get (runPut (put uid)) + , QC.testProperty "decryptPrivateKey (encryptPrivateKey sk pw) pw equivalence" $ \passphraseNE -> + QC.ioProperty $ do + fixture <- loadV6UnencryptedSecretKeyFixtureForProperty + case fixture of + Left err -> pure (QC.counterexample err False) + Right (pkp, ska, expectedSKey) -> do + let passphraseChars = (QC.getNonEmpty passphraseNE :: String) + passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars) + encryptedResult <- encryptPrivateKey defaultPolicy pkp ska passphrase + pure $ + case encryptedResult of + Left err -> + QC.counterexample ("encryptPrivateKey failed: " ++ err) False + Right encryptedSKA -> + case decryptPrivateKey (pkp, encryptedSKA) passphrase of + Left err -> + QC.counterexample ("decryptPrivateKey failed: " ++ err) False + Right (SUUnencrypted skey _) -> + QC.counterexample + "secret key material changed across encrypt/decrypt roundtrip" + (skey == expectedSKey) + Right other -> + QC.counterexample + ("expected SUUnencrypted after decrypting encrypted key, got: " ++ + show other) + False + , localOption + (QC.QuickCheckTests 5) + (QC.testProperty "decryptPrivateKey (encryptPrivateKey v4sk pw) pw equivalence" $ + QC.ioProperty $ do + fixture <- loadV4EncryptedSecretKeyFixtureForProperty + case fixture of + Left err -> pure (QC.counterexample err False) + Right (pkp, ska, expectedSKey, passphrase) -> do + let legacyOverridePolicy :: OpenPGPPolicy + legacyOverridePolicy = + (policyForRFC RFC4880) + { policySecretKeyProtection = policySecretKeyProtection defaultPolicy + } + encryptedResult <- encryptPrivateKey legacyOverridePolicy pkp ska passphrase + pure $ + case encryptedResult of + Left err -> + QC.counterexample ("encryptPrivateKey failed under legacy override policy: " ++ err) False + Right encryptedSKA -> + case decryptPrivateKey (pkp, encryptedSKA) passphrase of + Left err -> + QC.counterexample ("decryptPrivateKey failed: " ++ err) False + Right (SUUnencrypted skey _) -> + QC.counterexample + "v4 secret key material changed across encrypt/decrypt roundtrip" + (skey == expectedSKey) + Right other -> + QC.counterexample + ("expected SUUnencrypted after decrypting v4 encrypted key, got: " ++ + show other) + False) + , QC.testProperty + "canonicalizePKESKRecipientId idempotence on valid v4/v6 recipient ids" + propertyCanonicalizePKESKRecipientIdIdempotent + , localOption + (QC.QuickCheckTests 10) + (QC.testProperty + "canonicalizeTKStructuredWithWireRep is stable across packet/sig reordering" + propertyCanonicalizeTKStructuredStableAcrossReordering) + , localOption + (QC.QuickCheckTests 1) + (QC.testProperty + "recipient selection remains decryptable with extra unusable PKESK candidates" + propertyRecipientSelectionMonotonicWithUnusableCandidates) + , QC.testProperty + "parsePktsEither does not accept truncated packet streams as intact packets" + 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) + where + targetLen = if useV6 then 32 else 20 + versionOctet = if useV6 then 0x06 else 0x04 + ridBody = BL.pack (take targetLen (seedBytes ++ repeat 0x00)) + rid + | prefixed = BL.cons versionOctet ridBody + | otherwise = ridBody + payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") + +propertyCanonicalizeTKStructuredStableAcrossReordering :: + QC.NonNegative Int + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> QC.Property +propertyCanonicalizeTKStructuredStableAcrossReordering + (QC.NonNegative indexSeed) + reverseDirect + reverseUIDs + reverseUIDSigs + reverseUATs + reverseUATSigs + reverseSubs + reverseSubSigs = + QC.ioProperty $ do + lbs <- readFixtureLazy "pubring.gpg" + let src = wireRepRef lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) + if null parsed + then pure (QC.counterexample "pubring.gpg parsed to no TKWithWireRep values" False) + else do + let tk = parsed !! (indexSeed `mod` length parsed) + pure $ + case toStructuredTKWithWireRep tk of + Left err -> + QC.counterexample ("toStructuredTKWithWireRep failed: " ++ err) False + Right structured -> + let shuffled = + structured + { _tkStructuredDirectSignatures = + reverseIf reverseDirect (_tkStructuredDirectSignatures structured) + , _tkStructuredUIDs = + reverseIf reverseUIDs + (map + (\uid -> + uid + { _uidWithWireRefsSignatures = + reverseIf reverseUIDSigs (_uidWithWireRefsSignatures uid) + }) + (_tkStructuredUIDs structured)) + , _tkStructuredUAts = + reverseIf reverseUATs + (map + (\uat -> + uat + { _uatWithWireRefsSignatures = + reverseIf reverseUATSigs (_uatWithWireRefsSignatures uat) + }) + (_tkStructuredUAts structured)) + , _tkStructuredSubkeys = + reverseIf reverseSubs + (map + (\sub -> + sub + { _subkeyWithWireRefsSignatures = + reverseIf reverseSubSigs (_subkeyWithWireRefsSignatures sub) + }) + (_tkStructuredSubkeys structured)) + } + in case (canonicalizeTKStructuredWithWireRep structured, canonicalizeTKStructuredWithWireRep shuffled) of + (Right canonicalBase, Right canonicalShuffled) -> + QC.counterexample + "canonicalization should be stable under packet/sig reordering" + (canonicalBase == canonicalShuffled) + (Left err, _) -> + QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on base: " ++ show err) False + (_, Left err) -> + QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on shuffled: " ++ show err) False + +propertyRecipientSelectionMonotonicWithUnusableCandidates :: + QC.NonNegative Int -> Bool -> QC.Property +propertyRecipientSelectionMonotonicWithUnusableCandidates (QC.NonNegative extraBogus) reorderPKESKs = + QC.ioProperty $ do + let applyBogus = foldr (.) id (replicate (extraBogus `mod` 5) prependUnusableLatestPKESK) + transformPackets + | reorderPKESKs = applyBogus . reorderPrecedingPKESKs + | otherwise = applyBogus + result <- + (try $ do + (messagePacketsRaw, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-three-recipients.pgp.aa" + keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase + let messagePackets = transformPackets messagePacketsRaw + passphraseCallback _ = pure BL.empty + keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets DC..| + conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| + CL.consume + pure (any (not . BL.null) [payload | LiteralDataPkt _ _ _ payload <- decrypted])) + :: IO (Either SomeException Bool) + case result of + Left e -> + pure $ + QC.counterexample + ("recipient selection should remain decryptable despite added unusable candidates: " ++ show e) + False + Right didDecrypt -> + pure $ + QC.counterexample + "recipient selection should still yield a non-empty decrypted literal payload" + didDecrypt + +propertyParsePktsEitherRejectsTruncatedPacketStream :: + PKESK 'PKESKV6 -> QC.Positive Int -> QC.Property +propertyParsePktsEitherRejectsTruncatedPacketStream pkesk (QC.Positive cutSeed) = + case parsePktsEither truncated of + Left _ -> QC.property True + Right parsed -> + QC.counterexample + ("parsePktsEither unexpectedly treated truncated packet stream as original packet: " ++ + show parsed) + (parsed /= [toPkt pkesk]) + where + encoded = runPut (put (toPkt pkesk)) + cut = fromIntegral (1 + (cutSeed `mod` fromIntegral (BL.length encoded))) + truncated = BL.take (BL.length encoded - cut) encoded + diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Serialization.hs @@ -0,0 +1,956 @@ +-- Serialization.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Serialization (serializationTests) where + +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal (emptyPSC, point2MBS) +import Codec.Encryption.OpenPGP.KeyringParser (parseTKsWithWireRep) +import Codec.Encryption.OpenPGP.Policy + ( signatureV6SaltSizeForHashAlgorithm + ) +import Codec.Encryption.OpenPGP.Serialize (parsePkts, parsePktsWithWireRep) +import Codec.Encryption.OpenPGP.Signatures + ( VerificationError(..) + , verifySigWith + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Control.Applicative ((<|>)) +import Control.Monad (forM_) +import Crypto.Number.Serialize (os2ip) +import Data.Binary (Get, get, put) +import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord8, runPut) +import Data.Bits (xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Data.Conduit.Serialization.Binary (conduitGet) +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Data.Word (Word8) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Tests.Common + ( armorPayload + , loadArmor + , readFixturePayload + , runGet + ) + +serializationTests :: TestTree +serializationTests = + testGroup + "Serialization" + [ testGroup + "Serialization group" + [ testCase + "000001-006.public_key" + (testSerialization "000001-006.public_key") + , testCase + "issuer-fingerprint-rejects-unknown-version" + testIssuerFingerprintRejectsUnknownVersion + , testCase + "v6-ed25519-public-key-serializes-fixed-length" + testV6Ed25519PublicKeySerializesFixedLength + , testCase + "v4-ed25519-public-key-parses-native-fixed-length" + testV4Ed25519PublicKeyParsesNativeFixedLength + , testCase + "v4-x25519-public-subkey-parses-native-fixed-length" + testV4X25519PublicSubkeyParsesNativeFixedLength + , testCase + "v6-signature-issuer-fingerprint-version-mismatch" + testV6SignatureIssuerFingerprintVersionMismatch + , testCase "000002-013.user_id" (testSerialization "000002-013.user_id") + , testCase "000003-002.sig" (testSerialization "000003-002.sig") + , testCase + "000004-012.ring_trust" + (testSerialization "000004-012.ring_trust") + , testCase "000005-002.sig" (testSerialization "000005-002.sig") + , testCase + "000006-012.ring_trust" + (testSerialization "000006-012.ring_trust") + , testCase "000007-002.sig" (testSerialization "000007-002.sig") + , testCase + "000008-012.ring_trust" + (testSerialization "000008-012.ring_trust") + , testCase "000009-002.sig" (testSerialization "000009-002.sig") + , testCase + "000010-012.ring_trust" + (testSerialization "000010-012.ring_trust") + , testCase "000011-002.sig" (testSerialization "000011-002.sig") + , testCase + "000012-012.ring_trust" + (testSerialization "000012-012.ring_trust") + , testCase + "000013-014.public_subkey" + (testSerialization "000013-014.public_subkey") + , testCase "000014-002.sig" (testSerialization "000014-002.sig") + , testCase + "000015-012.ring_trust" + (testSerialization "000015-012.ring_trust") + , testCase + "000016-006.public_key" + (testSerialization "000016-006.public_key") + , testCase "000017-002.sig" (testSerialization "000017-002.sig") + , testCase + "000018-012.ring_trust" + (testSerialization "000018-012.ring_trust") + , testCase "000019-013.user_id" (testSerialization "000019-013.user_id") + , testCase "000020-002.sig" (testSerialization "000020-002.sig") + , testCase + "000021-012.ring_trust" + (testSerialization "000021-012.ring_trust") + , testCase "000022-002.sig" (testSerialization "000022-002.sig") + , testCase + "000023-012.ring_trust" + (testSerialization "000023-012.ring_trust") + , testCase + "000024-014.public_subkey" + (testSerialization "000024-014.public_subkey") + , testCase "000025-002.sig" (testSerialization "000025-002.sig") + , testCase + "000026-012.ring_trust" + (testSerialization "000026-012.ring_trust") + , testCase + "000027-006.public_key" + (testSerialization "000027-006.public_key") + , testCase "000028-002.sig" (testSerialization "000028-002.sig") + , testCase + "000029-012.ring_trust" + (testSerialization "000029-012.ring_trust") + , testCase "000030-013.user_id" (testSerialization "000030-013.user_id") + , testCase "000031-002.sig" (testSerialization "000031-002.sig") + , testCase + "000032-012.ring_trust" + (testSerialization "000032-012.ring_trust") + , testCase "000033-002.sig" (testSerialization "000033-002.sig") + , testCase + "000034-012.ring_trust" + (testSerialization "000034-012.ring_trust") + , testCase + "000035-006.public_key" + (testSerialization "000035-006.public_key") + , testCase "000036-013.user_id" (testSerialization "000036-013.user_id") + , testCase "000037-002.sig" (testSerialization "000037-002.sig") + , testCase + "000038-012.ring_trust" + (testSerialization "000038-012.ring_trust") + , testCase "000039-002.sig" (testSerialization "000039-002.sig") + , testCase + "000040-012.ring_trust" + (testSerialization "000040-012.ring_trust") + , testCase + "000041-017.attribute" + (testSerialization "000041-017.attribute") + , testCase "000042-002.sig" (testSerialization "000042-002.sig") + , testCase + "000043-012.ring_trust" + (testSerialization "000043-012.ring_trust") + , testCase + "000044-014.public_subkey" + (testSerialization "000044-014.public_subkey") + , testCase "000045-002.sig" (testSerialization "000045-002.sig") + , testCase + "000046-012.ring_trust" + (testSerialization "000046-012.ring_trust") + , testCase + "000047-005.secret_key" + (testSerialization "000047-005.secret_key") + , testCase "000048-013.user_id" (testSerialization "000048-013.user_id") + , testCase "000049-002.sig" (testSerialization "000049-002.sig") + , testCase + "000050-012.ring_trust" + (testSerialization "000050-012.ring_trust") + , testCase + "000051-007.secret_subkey" + (testSerialization "000051-007.secret_subkey") + , testCase "000052-002.sig" (testSerialization "000052-002.sig") + , testCase + "000053-012.ring_trust" + (testSerialization "000053-012.ring_trust") + , testCase + "000054-005.secret_key" + (testSerialization "000054-005.secret_key") + , testCase "000055-002.sig" (testSerialization "000055-002.sig") + , testCase + "000056-012.ring_trust" + (testSerialization "000056-012.ring_trust") + , testCase "000057-013.user_id" (testSerialization "000057-013.user_id") + , testCase "000058-002.sig" (testSerialization "000058-002.sig") + , testCase + "000059-012.ring_trust" + (testSerialization "000059-012.ring_trust") + , testCase + "000060-007.secret_subkey" + (testSerialization "000060-007.secret_subkey") + , testCase "000061-002.sig" (testSerialization "000061-002.sig") + , testCase + "000062-012.ring_trust" + (testSerialization "000062-012.ring_trust") + , testCase + "000063-005.secret_key" + (testSerialization "000063-005.secret_key") + , testCase "000064-002.sig" (testSerialization "000064-002.sig") + , testCase + "000065-012.ring_trust" + (testSerialization "000065-012.ring_trust") + , testCase "000066-013.user_id" (testSerialization "000066-013.user_id") + , testCase "000067-002.sig" (testSerialization "000067-002.sig") + , testCase + "000068-012.ring_trust" + (testSerialization "000068-012.ring_trust") + , testCase + "000069-005.secret_key" + (testSerialization "000069-005.secret_key") + , testCase "000070-013.user_id" (testSerialization "000070-013.user_id") + , testCase "000071-002.sig" (testSerialization "000071-002.sig") + , testCase + "000072-012.ring_trust" + (testSerialization "000072-012.ring_trust") + , testCase + "000073-017.attribute" + (testSerialization "000073-017.attribute") + , testCase "000074-002.sig" (testSerialization "000074-002.sig") + , testCase + "000075-012.ring_trust" + (testSerialization "000075-012.ring_trust") + , testCase + "000076-007.secret_subkey" + (testSerialization "000076-007.secret_subkey") + , testCase "000077-002.sig" (testSerialization "000077-002.sig") + , testCase + "000078-012.ring_trust" + (testSerialization "000078-012.ring_trust") + , testCase "pubring.gpg" (testSerialization "pubring.gpg") + , testCase "secring.gpg" (testSerialization "secring.gpg") + , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg") + , testCase + "compressedsig-zlib.gpg" + (testSerialization "compressedsig-zlib.gpg") + , testCase + "compressedsig-bzip2.gpg" + (testSerialization "compressedsig-bzip2.gpg") + , testCase "onepass_sig" (testSerialization "onepass_sig") + , testCase + "uncompressed-ops-dsa.gpg" + (testSerialization "uncompressed-ops-dsa.gpg") + , testCase + "uncompressed-ops-rsa.gpg" + (testSerialization "uncompressed-ops-rsa.gpg") + , testCase "simple.seckey" (testSerialization "simple.seckey") + , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig") + , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes") + , testCase + "gnu-dummy-s2k-101-secret-key.gpg" + (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") + , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg") + , testCase "nist_p-256_key.gpg" (testSerialization "nist_p-256_key.gpg") + , testCase + "nist_p-256_secretkey.gpg" + (testSerialization "nist_p-256_secretkey.gpg") + , testCase "v6-secret.pgp.aa" (testSerialization "v6-secret.pgp.aa") + , testCase + "sample-eddsa.pubkey" + (testSerialization "sample-eddsa.pubkey") + , testCase "should not serialize point at infinity" testPointAtInfinitySerialization + , testCase + "should reject mismatched EC coordinate widths" + testPointSerializationRejectsMismatchedCoordinateWidths + ] + , testGroup + "TKUnknown Serialization group" + [ testCase "pubring.gpg TKUnknown serialization" (testTKSerialization "pubring.gpg") + , testCase "secring.gpg TKUnknown serialization" (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 + "SEIPD v2 rejects invalid chunk size" + testSEIPDv2RejectInvalidChunkSize + , testCase + "PKESKv6 parsing does not fall back to legacy parser" + testPKESKv6ParsesAsV6WithoutLegacyFallback + , testCase + "PKESKv6 rejects invalid recipient key version" + testPKESKv6RejectsInvalidRecipientIdentifierVersion + , testCase + "PKESKv6 rejects recipient length/version mismatches" + testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch + , testCase + "legacy RSA PKESK rejects extra MPIs" + testLegacyPKESKRSARejectsExtraMPI + , testCase + "legacy ECDH PKESK rejects wrong MPI count" + testLegacyPKESKECDHRejectsWrongMPICount + , testCase + "legacy X25519 PKESK rejects wrong MPI count" + testLegacyPKESKX25519RejectsWrongMPICount + , testCase + "legacy unencrypted secret key rejects checksum mismatch" + testLegacyUnencryptedSecretKeyRejectsChecksumMismatch + , testCase + "legacy secret key rejects unsupported symmetric algorithm IV sizing" + testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing + , testCase + "legacy X25519 PKESK parses RFC9580 v3 octet layout" + testLegacyPKESKX25519ParsesRFC9580V3OctetLayout + , testCase "SigV6 rejects invalid salt size" testSigV6RejectsInvalidSaltSize + , testCase "OPS6 rejects invalid salt size" testOPS6RejectsInvalidSaltSize + , testCase "OPS3 rejects invalid nested-flag octet" testOPS3RejectsInvalidNestedFlagOctet + , testCase "OPS6 rejects invalid nested-flag octet" testOPS6RejectsInvalidNestedFlagOctet + , testCase + "ECDH pubkey rejects reserved KDF length 0" + testECDHPubkeyRejectsReservedKDFLengthZero + , testCase + "ECDH pubkey rejects reserved KDF length 255" + testECDHPubkeyRejectsReservedKDFLength255 + , testCase + "ECDH pubkey encodes fixed KDF length trailer" + testECDHPubkeyEncodesFixedKDFLength + , testCase + "empty key-flags subpacket encodes explicit zero octet" + testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet + , testCase + "v6-secret fixture SigV6 semantics" + testV6SecretFixtureSignatureSemantics + , testCase + "v6-secret fixture derives eight-octet key-id from fingerprint prefix" + testV6SecretFixtureDerivesEightOctetKeyID + ] + ] + +testSerialization :: FilePath -> Assertion +testSerialization fpr = do + bs <- readFixturePayload fpr + let firstpass = runGet get bs + case fmap unBlock firstpass of + Left _ -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> + assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." + Right packs -> do + let roundtrip = runPut $ put (Block packs) + let secondpass = runGet (get :: Get (Block Pkt)) roundtrip + if fmap unBlock secondpass == Right [] + then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." + else assertEqual ("for " ++ fpr) firstpass secondpass + +testTKSerialization :: FilePath -> Assertion +testTKSerialization fpr = do + bs <- readFixturePayload fpr + let pkts = parsePktsWithWireRep (wireRepRef bs) bs + tksWithWireRep = parseTKsWithWireRep True pkts + if null tksWithWireRep + then assertFailure $ "TKUnknown serialization test: " ++ fpr ++ " parsed to no TKs" + else forM_ tksWithWireRep (testTKRoundtrip fpr) + +testTKRoundtrip :: FilePath -> TKWithWireRep -> Assertion +testTKRoundtrip fpr tk = do + let packets = _tkPackets tk + encoded = runPut (put (Block (map _pktValue packets))) + case runGet (get :: Get (Block Pkt)) encoded of + Left err -> assertFailure $ "TKUnknown " ++ fpr ++ " packet re-parse failed: " ++ err + Right reparsedBlock -> + assertEqual + ("TKUnknown packet re-serialization roundtrip for " ++ fpr) + (Block (map _pktValue packets)) + reparsedBlock + case toStructuredTKWithWireRep tk of + Left err -> assertFailure $ "TKUnknown structured conversion failed for " ++ fpr ++ ": " ++ show err + Right structured -> + case canonicalizeTKStructuredWithWireRep structured of + Left err -> assertFailure $ "TKUnknown canonical conversion failed for " ++ fpr ++ ": " ++ 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) + (runGet (get :: Get Pkt) encoded) + + +testIssuerFingerprintRejectsUnknownVersion :: Assertion +testIssuerFingerprintRejectsUnknownVersion = do + let encoded = + runPut $ do + putWord8 34 + putWord8 33 + putWord8 5 + putByteString (B.replicate 32 0) + case runGet (get :: Get SigSubPacket) encoded of + Left _ -> pure () + Right _ -> assertFailure "issuer fingerprint subpacket version 5 should be rejected" + +testV6Ed25519PublicKeySerializesFixedLength :: Assertion +testV6Ed25519PublicKeySerializesFixedLength = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) + encoded = runPut (put (PublicKeyPkt pkp)) + assertEqual + "v6 Ed25519 public key serialization uses fixed-length octet strings" + 44 + (BL.length encoded) + +testV4Ed25519PublicKeyParsesNativeFixedLength :: Assertion +testV4Ed25519PublicKeyParsesNativeFixedLength = do + let raw = B.pack [0x01 .. 0x20] + encoded = + runPut $ do + putWord8 0xc6 + putWord8 38 + putWord8 4 + putWord32be 0 + putWord8 (fromIntegral (fromFVal PKA.Ed25519)) + putByteString raw + case runGet (get :: Get Pkt) encoded of + Right (PublicKeyPkt (PKPayload V4 (ThirtyTwoBitTimeStamp 0) _ PKA.Ed25519 (EdDSAPubKey Ed25519 (NativeEPoint (EPoint x))))) -> + assertEqual "v4 Ed25519 fixed-length key material parsed as native point" (os2ip raw) x + other -> + assertFailure + ("Expected v4 Ed25519 fixed-length public key parse, got " ++ show other) + +testV4X25519PublicSubkeyParsesNativeFixedLength :: Assertion +testV4X25519PublicSubkeyParsesNativeFixedLength = do + let raw = B.pack [0x01 .. 0x20] + encoded = + runPut $ do + putWord8 0xce + putWord8 38 + putWord8 4 + putWord32be 0 + putWord8 (fromIntegral (fromFVal PKA.X25519)) + putByteString raw + case runGet (get :: Get Pkt) encoded of + Right (PublicSubkeyPkt (PKPayload V4 (ThirtyTwoBitTimeStamp 0) _ PKA.X25519 (EdDSAPubKey Ed25519 (NativeEPoint (EPoint x))))) -> + assertEqual "v4 X25519 fixed-length key material parsed as native point" (os2ip raw) x + other -> + assertFailure + ("Expected v4 X25519 fixed-length public subkey parse, got " ++ show other) + +testV6SignatureIssuerFingerprintVersionMismatch :: Assertion +testV6SignatureIssuerFingerprintVersionMismatch = do + let signer = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) + sig = + SignaturePkt + (SigV6 + BinarySig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0)) + [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] + [] + 0 + (NE.fromList [MPI 0, MPI 0])) + verifier _ _ _ = Right (Verification signer (case sig of SignaturePkt sp -> sp; _ -> error "impossible") []) + case verifySigWith verifier sig emptyPSC Nothing of + Left IssuerFingerprintSubpacketMismatch -> pure () + Left err -> assertFailure ("unexpected verification error: " ++ show err) + Right _ -> assertFailure "v6 signature with issuer fingerprint version 4 should be rejected" + +testPointAtInfinitySerialization :: Assertion +testPointAtInfinitySerialization = + assertEqual "point at infinity should not serialize" Nothing (point2MBS ECCT.PointO) + +testPointSerializationRejectsMismatchedCoordinateWidths :: Assertion +testPointSerializationRejectsMismatchedCoordinateWidths = + assertEqual + "point serialization should reject mismatched coordinate widths" + Nothing + (point2MBS (ECCT.Point 1 256)) + +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) + (runGet (get :: Get Pkt) encoded) + +testSEIPDv2RejectInvalidChunkSize :: Assertion +testSEIPDv2RejectInvalidChunkSize = do + let encoded = + runPut $ do + putWord8 0xd2 + putWord8 37 + putWord8 2 + putWord8 7 + putWord8 2 + putWord8 17 + putByteString (B.replicate 32 0) + putWord8 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ("SEIPD v2 parser should reject chunk sizes larger than 16, got " ++ + show other) + +testPKESKv6ParsesAsV6WithoutLegacyFallback :: Assertion +testPKESKv6ParsesAsV6WithoutLegacyFallback = do + let recipientKeyIdentifier = BL.pack (0x04 : replicate 20 0) + esk = "\x00\x00" + encoded = + runPut $ do + putWord8 0xc1 + putWord8 26 + putWord8 6 + putWord8 21 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + putByteString (BL.toStrict esk) + case runGet (get :: Get Pkt) encoded of + Right (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka parsedEsk))) -> do + assertEqual "PKESKv6 recipient key identifier" recipientKeyIdentifier rid + assertEqual "PKESKv6 algorithm" RSA pka + assertEqual "PKESKv6 ESK payload" esk parsedEsk + other -> + assertFailure ("Expected PKESKPkt (PKESK6 ...) parse result, got " ++ show other) + +testPKESKv6RejectsInvalidRecipientIdentifierVersion :: Assertion +testPKESKv6RejectsInvalidRecipientIdentifierVersion = do + let recipientKeyIdentifier = BL.pack (0x05 : replicate 20 0) + encoded = + runPut $ do + putWord8 0xc1 + putWord8 24 + putWord8 6 + putWord8 21 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected malformed PKESKv6 key version to produce BrokenPacketPkt, got " ++ + show other) + +testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch :: Assertion +testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch = do + let recipientKeyIdentifier = BL.pack (0x04 : replicate 32 0) + encoded = + runPut $ do + putWord8 0xc1 + putWord8 36 + putWord8 6 + putWord8 33 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected malformed PKESKv6 recipient length/version mismatch to produce BrokenPacketPkt, got " ++ + show other) + +testLegacyPKESKRSARejectsExtraMPI :: Assertion +testLegacyPKESKRSARejectsExtraMPI = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 16 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 1 + put (MPI 1) + put (MPI 2) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected malformed legacy RSA PKESK to produce BrokenPacketPkt, got " ++ + show other) + +testLegacyPKESKECDHRejectsWrongMPICount :: Assertion +testLegacyPKESKECDHRejectsWrongMPICount = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 13 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 18 + put (MPI 1) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected malformed legacy ECDH PKESK to produce BrokenPacketPkt, got " ++ + show other) + +testLegacyPKESKX25519RejectsWrongMPICount :: Assertion +testLegacyPKESKX25519RejectsWrongMPICount = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 13 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 (fromIntegral (fromFVal X25519)) + put (MPI 1) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected malformed legacy X25519 PKESK to produce BrokenPacketPkt, got " ++ + show other) + +testLegacyUnencryptedSecretKeyRejectsChecksumMismatch :: Assertion +testLegacyUnencryptedSecretKeyRejectsChecksumMismatch = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume + pkt <- + case secretPackets of + (SecretKeyPkt pkp (SUUnencrypted sk checksum):_) -> + pure (SecretKeyPkt pkp (SUUnencrypted sk (checksum `xor` 1))) + (SecretKeyPkt _ _ :_) -> + assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" >> + fail "expected unencrypted secret key packet" + _ -> + assertFailure "unencrypted.seckey did not begin with a secret key packet" >> + fail "expected secret key packet" + let encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected unencrypted secret key checksum mismatch to produce BrokenPacketPkt, got " ++ + show other) + +testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing :: Assertion +testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing = do + let pkt = + SecretKeyPkt + (PKPayload V4 0 0 RSA (UnknownPKey BL.empty)) + (SUSSHA1 + (OtherSA 0xfe) + (IteratedSalted SHA256 (Salt8 "12345678") (IterationCount 65536)) + (IV (B.replicate 8 0)) + BL.empty) + encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected legacy secret key with unsupported symmetric algorithm to produce BrokenPacketPkt, got " ++ + show other) + +testLegacyPKESKX25519ParsesRFC9580V3OctetLayout :: Assertion +testLegacyPKESKX25519ParsesRFC9580V3OctetLayout = do + let ephemeral = B.pack [0x01 .. 0x20] + wrappedWithAlgo = B.singleton (fromIntegral (fromFVal AES128)) <> B.replicate 24 0x5a + encoded = + runPut $ do + putWord8 0xc1 + putWord8 (fromIntegral (1 + 8 + 1 + B.length ephemeral + 1 + B.length wrappedWithAlgo)) + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 (fromIntegral (fromFVal X25519)) + putByteString ephemeral + putWord8 (fromIntegral (B.length wrappedWithAlgo)) + putByteString wrappedWithAlgo + case runGet (get :: Get Pkt) encoded of + Right (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 3 _ X25519 (ephMPI :| [eskMPI])))) -> do + assertEqual "legacy X25519 v3 octet-layout ephemeral parse" (MPI (os2ip ephemeral)) ephMPI + assertEqual + "legacy X25519 v3 octet-layout wrapped parse" + (MPI (os2ip wrappedWithAlgo)) + eskMPI + other -> + assertFailure + ("Expected legacy X25519 PKESK v3 octet-layout parse success, got " ++ show other) + +testSigV6RejectsInvalidSaltSize :: Assertion +testSigV6RejectsInvalidSaltSize = do + let encoded = + runPut $ do + putWord8 0xc2 + putWord8 45 + putWord8 6 + putWord8 0 + putWord8 1 + putWord8 8 + putWord32be 0 + putWord32be 0 + putWord16be 0 + putWord8 32 + putByteString (B.replicate 32 0) + putWord16be 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ("Expected invalid SigV6 salt size to produce BrokenPacketPkt, got " ++ + show other) + +testOPS6RejectsInvalidSaltSize :: Assertion +testOPS6RejectsInvalidSaltSize = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 69 + putWord8 6 + putWord8 0 + putWord8 10 + putWord8 22 + putWord8 31 + putByteString (B.replicate 31 0) + putByteString (B.replicate 32 0) + putWord8 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ("Expected invalid OPS6 salt size to produce BrokenPacketPkt, got " ++ + show other) + +testOPS3RejectsInvalidNestedFlagOctet :: Assertion +testOPS3RejectsInvalidNestedFlagOctet = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 13 + putWord8 3 + putWord8 0 + putWord8 8 + putWord8 1 + putByteString (B.replicate 8 0) + putWord8 2 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected invalid OPS3 nested-flag octet to produce BrokenPacketPkt, got " ++ + show other) + +testOPS6RejectsInvalidNestedFlagOctet :: Assertion +testOPS6RejectsInvalidNestedFlagOctet = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 70 + putWord8 6 + putWord8 0 + putWord8 8 + putWord8 1 + putWord8 32 + putByteString (B.replicate 32 0) + putByteString (B.replicate 32 0) + putWord8 2 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected invalid OPS6 nested-flag octet to produce BrokenPacketPkt, got " ++ + show other) + +mkECDHBoundaryTestPacket :: Pkt +mkECDHBoundaryTestPacket = + PublicKeyPkt + (PKPayload + V4 + 0 + 0 + ECDH + (ECDHPubKey + (ECDSAPubKey + (ECDSA_PublicKey + (ECDSA.PublicKey (ECCT.getCurveByName ECCT.SEC_p256r1) (ECCT.Point 1 2)))) + SHA256 + AES128)) + +setStrictByteAt :: Int -> Word8 -> B.ByteString -> Maybe B.ByteString +setStrictByteAt idx w bs + | idx < 0 || idx >= B.length bs = Nothing + | otherwise = + let (prefix, rest) = B.splitAt idx bs + in case B.uncons rest of + Nothing -> Nothing + Just (_, suffix) -> Just (prefix <> B.singleton w <> suffix) + +testECDHPubkeyRejectsReservedKDFLengthZero :: Assertion +testECDHPubkeyRejectsReservedKDFLengthZero = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + mutated <- + maybe + (assertFailure "failed to locate ECDH KDF length byte for zero-length rejection test" >> fail "unreachable") + pure + (setStrictByteAt (B.length encoded - 4) 0x00 encoded) + case runGet (get :: Get Pkt) (BL.fromStrict mutated) of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected ECDH KDF length 0 to produce BrokenPacketPkt, got " ++ show other) + +testECDHPubkeyRejectsReservedKDFLength255 :: Assertion +testECDHPubkeyRejectsReservedKDFLength255 = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + mutated <- + maybe + (assertFailure "failed to locate ECDH KDF length byte for 0xff rejection test" >> fail "unreachable") + pure + (setStrictByteAt (B.length encoded - 4) 0xff encoded) + case runGet (get :: Get Pkt) (BL.fromStrict mutated) of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ("Expected ECDH KDF length 255 to produce BrokenPacketPkt, got " ++ show other) + +testECDHPubkeyEncodesFixedKDFLength :: Assertion +testECDHPubkeyEncodesFixedKDFLength = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + trailer = B.drop (B.length encoded - 4) encoded + assertEqual + "ECDH public-key encoding should emit fixed KDF trailer [3,1,hash,sym]" + (B.pack [0x03, 0x01, fromFVal SHA256, fromFVal AES128]) + trailer + +testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet :: Assertion +testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet = do + let encoded = runPut (put (SigSubPacket False (KeyFlags Set.empty))) + assertEqual + "empty key-flags subpacket should encode an explicit zero flags octet" + [2, 27, 0] + (BL.unpack encoded) + case runGet (get :: Get SigSubPacket) encoded of + Right (SigSubPacket False (KeyFlags flags)) -> + assertEqual + "empty key-flags subpacket should decode back to an empty flag set" + Set.empty + flags + other -> + assertFailure + ("Expected empty key-flags subpacket roundtrip, got " ++ show other) + +expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int +expectedV6SaltSizeForTest = + fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm + +signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool +signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = + expectedFp `elem` + [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed + ] +signatureHasIssuerFingerprintV6 _ _ = False + +testV6SecretFixtureSignatureSemantics :: Assertion +testV6SecretFixtureSignatureSemantics = do + armors <- loadArmor "v6-secret.pgp.aa" + payload <- + case armors of + (a:_) -> pure (armorPayload a) + [] -> + assertFailure "v6-secret.pgp.aa should contain one armored payload" >> + fail "expected one armored payload" + let packets = parsePkts payload + primaryV6Key = + listToMaybe + [ pkp + | SecretKeyPkt pkp _ <- packets + , _keyVersion pkp == V6 + ] <|> + listToMaybe + [ pkp + | PublicKeyPkt pkp <- packets + , _keyVersion pkp == V6 + ] + signatures = + [ (sig, ha, salt) + | SignaturePkt sig@(SigV6 _ _ ha salt _ _ _ _) <- packets + ] + pkp <- + case primaryV6Key of + Nothing -> + assertFailure "v6-secret.pgp.aa should contain a primary v6 key packet" >> + fail "expected primary v6 key packet" + Just k -> pure k + assertBool + "v6-secret.pgp.aa should contain at least one SigV6 packet" + (not (null signatures)) + mapM_ + (\(_, ha, salt) -> + case expectedV6SaltSizeForTest ha of + Nothing -> + assertFailure ("SigV6 in v6-secret.pgp.aa uses unsupported salt hash algorithm: " ++ show ha) + Just expected -> + assertEqual + "SigV6 salt size in v6-secret.pgp.aa should match hash algorithm" + expected + (fromIntegral (BL.length (unSignatureSalt salt)))) + signatures + assertBool + "v6-secret.pgp.aa should include at least one IssuerFingerprint v6 matching the primary key" + (any (\(sig, _, _) -> signatureHasIssuerFingerprintV6 (fingerprint pkp) sig) signatures) + +testV6SecretFixtureDerivesEightOctetKeyID :: Assertion +testV6SecretFixtureDerivesEightOctetKeyID = do + armors <- loadArmor "v6-secret.pgp.aa" + payload <- + case armors of + (a:_) -> pure (armorPayload a) + [] -> + assertFailure "v6-secret.pgp.aa should contain one armored payload" >> + fail "expected one armored payload" + let packets = parsePkts payload + primaryV6Key = + listToMaybe + [ pkp + | SecretKeyPkt pkp _ <- packets + , _keyVersion pkp == V6 + ] <|> + listToMaybe + [ pkp + | PublicKeyPkt pkp <- packets + , _keyVersion pkp == V6 + ] + pkp <- + case primaryV6Key of + Nothing -> + assertFailure "v6-secret.pgp.aa should contain a primary v6 key packet" >> + fail "expected primary v6 key packet" + Just k -> pure k + derivedKeyId <- + case eightOctetKeyID pkp of + Left err -> + assertFailure ("Expected v6 eight-octet key-id derivation to succeed: " ++ err) >> + fail "expected v6 eight-octet key-id" + Right keyId -> pure keyId + let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint pkp))) + assertEqual + "v6 eight-octet key-id should be the high-order 64 bits of the fingerprint" + expectedKeyId + derivedKeyId diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Utilities.hs @@ -0,0 +1,1234 @@ +-- Utilities.hs: hOpenPGP test suite +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Utilities (utilityTests) where + +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev) +import Codec.Encryption.OpenPGP.KeyringParser + ( parsePublicTKs + , parseSecretTKs + , parseTKs + , parseTKsWithWireRep + , parseUnknownTKs + ) +import Codec.Encryption.OpenPGP.Serialize + ( PktParseError(..) + , WireRepInput(..) + , conduitParsePktsWithWireRep + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + , wireRepRefFromInput + ) +import Codec.Encryption.OpenPGP.Types +import Crypto.Number.Serialize (os2ip) +import Data.Binary (get) +import Data.Binary.Get (Get) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.OpenPGP.Keyring + ( AuthSecretSubkeyRejectionReason(..) + , AuthSecretSubkeyUID(..) + , AuthSecretSubkeysAtReport(..) + , authSecretSubkeysAt + , authSecretSubkeysAtReport + , authSecretSubkeyPrimaryUID + , authSecretSubkeyRejectedReason + , authSecretSubkeyUIDs + , authSecretSubkeyValue + , conduitToAuthSecretSubkeysAt + , conduitToAuthSecretSubkeysAtReport + , conduitToPublicTKs + , conduitToSecretTKs + , conduitToTKs + , conduitToTKsWithWireRep + , conduitToUnknownTKs + ) +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.List (nub, sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Set as Set +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Tests.Common + ( addTimestampSeconds + , armorPayload + , loadAndDecompressPkts + , loadUnencryptedRsaSigner + , loadV6UnencryptedSecretKeyFixtureForProperty + , readFixtureLazy + , readFixturePackets + , runGet + , setKeyTimestamp + , signCertificationAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , timestampToUTCTime + ) + + +utilityTests :: TestTree +utilityTests = + testGroup + "Utility function group" + [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") + , testCase + "pubring parsePktsEither equals parsePkts on valid input" + (testParsePktsEitherUtil "pubring.gpg") + , testCase + "parsePktsEither reports truncation errors" + (testParsePktsEitherFailureUtil "pubring.gpg") + , testCase + "parseUnknownTKs drops disallowed primary-key signature context (v4)" + testParseTKsDropsDisallowedPrimaryKeySigContextV4 + , testCase + "parseUnknownTKs drops disallowed primary-key signature context (v6)" + testParseTKsDropsDisallowedPrimaryKeySigContextV6 + , testCase + "parseUnknownTKs accepts allowed primary-key signature context (v6)" + testParseTKsAcceptsAllowedPrimaryKeySigContextV6 + , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") + , testCase + "pubring as typed TKs" + (testParseTKsTypedUtil "pubring.gpg") + , testCase + "typed TKUnknown conduit partitioning" + (testConduitToTKsTypedUtil "pubring.gpg") + , testCase + "auth-capable secret-subkey conduit filters revoked/expired/auth flags" + testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth + , testCase + "auth-capable secret-subkey conduit tracks primary UID over time" + testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime + , testCase + "auth-capable secret-subkey report includes typed rejection reasons" + testAuthSecretSubkeysAtReportIncludesRejectionReasons + , testCase + "pkalgoAbbrev handles RFC9580-era pubkey algorithms" + testPKAlgoAbbrevRFC9580 + , testCase + "EightOctetKeyId Show/Read roundtrip uses hex form" + testEightOctetKeyIdReadShowRoundtrip + , testCase + "PktWithWireRep Ord uses raw bytes for tie-breakers" + testPktWithWireRepOrdUsesRawBytes + , testCase + "pubring as packets with provenance" + (testParsePktsWithWireRepUtil "pubring.gpg") + , testCase + "pubring as TKs with provenance" + (testParseTKsWithWireRepUtil "pubring.gpg") + , testCase + "wire provenance tracks original ASCII armor" + testWireRepRefTracksArmorProvenance + , testCase + "tksFromWireRep matches any source in TKUnknown provenance list" + testTksFromWireRepMatchesAnySource + , testCase + "TKWithWireRep Semigroup preserves structured provenance" + testSemigroupTKWithWireRepPreservesStructuredRefs + , testCase + "canonicalizeTKWithWireRep matches manual wire-byte ordering" + testCanonicalizeTKWithWireRepMatchesManualWireOrdering + , testCase + "canonicalizeTKWithWireRep reports missing packet refs" + testCanonicalizeTKWithWireRepReportsMissingRef + , testCase + "KeyPkt wrappers preserve packet kind/role round-trips" + testKeyPktWrappersRoundTrip + , testCase + "TK public/secret conversion and projection round-trip" + testTKTypedRoundTripAndPublicView + , testCase + "uat.gpg embeds expected image data from uat.jpg" + testUatImageFixture + ] + +testPKAlgoAbbrevRFC9580 :: Assertion +testPKAlgoAbbrevRFC9580 = do + assertEqual "X25519 abbreviation" "x25" (pkalgoAbbrev (toFVal 25)) + assertEqual "X448 abbreviation" "x448" (pkalgoAbbrev (toFVal 26)) + assertEqual "Ed25519 abbreviation" "e25" (pkalgoAbbrev (toFVal 27)) + assertEqual "Ed448 abbreviation" "e448" (pkalgoAbbrev (toFVal 28)) + +testEightOctetKeyIdReadShowRoundtrip :: Assertion +testEightOctetKeyIdReadShowRoundtrip = do + let eoki = EightOctetKeyId (BL.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef]) + assertEqual "show prints canonical uppercase hex" "0123456789ABCDEF" (show eoki) + assertEqual "read . show roundtrip" eoki (read (show eoki)) + +testUatImageFixture :: Assertion +testUatImageFixture = do + expectedImage <- readFixtureLazy "uat.jpg" + packets <- loadAndDecompressPkts "uat.gpg" + let images = + [ imageData + | UserAttributePkt uas <- packets + , ImageAttribute _ imageData <- uas + ] + assertBool "uat.gpg should contain a user-attribute image packet" (not (null images)) + assertBool + "uat.gpg should embed the uat.jpg payload" + (expectedImage `elem` images) + +testParsePktsUtil :: FilePath -> Assertion +testParsePktsUtil fn = do + cp <- readFixturePackets fn + pp <- parsePkts `fmap` readFixtureLazy fn + assertEqual + "parsePkts utility function gives same results as conduit pipeline" + cp + pp + +testParsePktsEitherUtil :: FilePath -> Assertion +testParsePktsEitherUtil fn = do + lbs <- readFixtureLazy fn + assertEqual + "parsePktsEither matches parsePkts on valid input" + (Right (parsePkts lbs)) + (parsePktsEither lbs) + +testParsePktsEitherFailureUtil :: FilePath -> Assertion +testParsePktsEitherFailureUtil fn = do + lbs <- readFixtureLazy fn + let truncated = BL.take (BL.length lbs - 1) lbs + case parsePktsEither truncated of + Left (PktParseError off msg) -> do + assertBool "parsePktsEither reports non-empty parse error messages" (not (null msg)) + assertBool "parsePktsEither reports an in-range failure offset" (off >= 0 && off <= BL.length truncated) + assertBool + "legacy parsePkts still returns a parsed prefix on malformed input" + (length (parsePkts truncated) <= length (parsePkts lbs)) + Right _ -> + assertFailure "parsePktsEither should fail when input is truncated" + +testParseTKsUtil :: FilePath -> Assertion +testParseTKsUtil fn = do + lbs <- readFixtureLazy fn + cp <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToUnknownTKs DC..| CL.consume + let pt = parseUnknownTKs True . parsePkts $ lbs + assertEqual + "parsePkts utility function gives same results as conduit pipeline" + cp + pt + +testParseTKsTypedUtil :: FilePath -> Assertion +testParseTKsTypedUtil fn = do + lbs <- readFixtureLazy fn + let packets = parsePkts lbs + plain = parseUnknownTKs True packets + typed = parseTKs True packets + typedPublic = parsePublicTKs True packets + typedSecret = parseSecretTKs True packets + assertEqual + "parseTKs round-trips to the same untyped TKUnknown semantics" + plain + (map someTKToUnknown typed) + assertEqual + "public + secret typed partitions preserve full typed parse count" + (length typed) + (length typedPublic + length typedSecret) + +testConduitToTKsTypedUtil :: FilePath -> Assertion +testConduitToTKsTypedUtil fn = do + lbs <- readFixtureLazy fn + allTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume + publicTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToPublicTKs DC..| CL.consume + secretTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSecretTKs DC..| CL.consume + assertEqual + "typed conduit round-trips to parseUnknownTKs semantics" + (parseUnknownTKs True (parsePkts lbs)) + (map someTKToUnknown allTyped) + assertEqual + "typed conduit public + secret partitions preserve full count" + (length allTyped) + (length publicTyped + length secretTyped) + +testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth :: Assertion +testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) + uidText = "auth-subkeys@example.org" + uid = UserId uidText + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer + signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer + + uidCertification <- + signCertificationAt + signer + signingKey + uid + (addTimestampSeconds baseTime 8) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + expiringAuthBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + expiringAuthSubkey + signingKey + (addTimestampSeconds baseTime 10) + [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) + , SigSubPacket False (KeyExpirationTime 20) + ] + signingOnlyBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + signingOnlySubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + authRevocation <- + signSubkeyRevocationWithRSAAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 22) + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidText, [uidCertification])] + [] + [ (SecretSubkeyPkt authSubkey secretAddendum, [authBinding, authRevocation]) + , (SecretSubkeyPkt expiringAuthSubkey secretAddendum, [expiringAuthBinding]) + , (SecretSubkeyPkt signingOnlySubkey secretAddendum, [signingOnlyBinding]) + ] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure "expected secret typed TKUnknown for auth subkey test fixture" >> fail "unreachable" + Left err -> + assertFailure ("fromUnknownToTK failed for auth subkey test fixture: " ++ err) >> fail "unreachable" + + selectedBefore <- + DC.runConduitRes $ + CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt beforeTime DC..| CL.consume + assertEqual + "pure authSecretSubkeysAt helper and conduit output should match" + (authSecretSubkeysAt beforeTime typedSecret) + selectedBefore + assertEqual + "before revocation/expiry, conduit should keep only auth-capable secret subkeys" + 2 + (length selectedBefore) + let selectedBeforeFps = + Set.fromList + (map (fingerprint . keyPktPKPayload . authSecretSubkeyValue) selectedBefore) + assertEqual + "selected auth-capable subkeys should match expected fingerprints" + (Set.fromList [fingerprint authSubkey, fingerprint expiringAuthSubkey]) + selectedBeforeFps + mapM_ + (\selection -> do + assertEqual "selected auth subkey should retain active primary UID context" (Just uidText) (authSecretSubkeyPrimaryUID selection) + assertEqual + "selected auth subkey should expose UID context with primary marker" + [AuthSecretSubkeyUID uidText True] + (authSecretSubkeyUIDs selection)) + selectedBefore + + selectedAfter <- + DC.runConduitRes $ + CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt afterTime DC..| CL.consume + assertEqual + "after revocation/expiry, conduit should drop revoked/expired auth subkeys" + [] + selectedAfter + +testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime :: Assertion +testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 15) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 25) + uidA = UserId "uid-a@example.org" + UserId uidAText = uidA + uidB = UserId "uid-b@example.org" + UserId uidBText = uidB + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + + uidACert <- + signCertificationAt + signer + signingKey + uidA + (addTimestampSeconds baseTime 10) + [SigSubPacket False (PrimaryUserId True)] + uidBCert <- + signCertificationAt + signer + signingKey + uidB + (addTimestampSeconds baseTime 20) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 11) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidAText, [uidACert]), (uidBText, [uidBCert])] + [] + [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure "expected secret typed TKUnknown for primary-uid test fixture" >> fail "unreachable" + Left err -> + assertFailure ("fromUnknownToTK failed for primary-uid test fixture: " ++ err) >> fail "unreachable" + + beforeSelections <- + DC.runConduitRes $ + CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt beforeTime DC..| CL.consume + beforeSelection <- + case beforeSelections of + [selection] -> pure selection + other -> + assertFailure ("expected one auth-capable subkey selection before primary-uid rollover, got " ++ show (length other)) >> + fail "unreachable" + assertEqual + "earlier primary UID should be selected before newer self-certification" + (Just uidAText) + (authSecretSubkeyPrimaryUID beforeSelection) + assertEqual + "UID context should include only active UIDs before uid-b certification exists" + [(uidAText, True)] + (map (\u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)) (authSecretSubkeyUIDs beforeSelection)) + + afterSelections <- + DC.runConduitRes $ + CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt afterTime DC..| CL.consume + afterSelection <- + case afterSelections of + [selection] -> pure selection + other -> + assertFailure ("expected one auth-capable subkey selection after primary-uid rollover, got " ++ show (length other)) >> + fail "unreachable" + assertEqual + "newer primary UID self-certification should win after rollover" + (Just uidBText) + (authSecretSubkeyPrimaryUID afterSelection) + assertEqual + "UID context should mark uid-b as primary after rollover" + [(uidAText, False), (uidBText, True)] + (map (\u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)) (authSecretSubkeyUIDs afterSelection)) + +testAuthSecretSubkeysAtReportIncludesRejectionReasons :: Assertion +testAuthSecretSubkeysAtReportIncludesRejectionReasons = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) + uidText = "auth-subkeys@example.org" + uid = UserId uidText + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer + signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer + + uidCertification <- + signCertificationAt + signer + signingKey + uid + (addTimestampSeconds baseTime 8) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + expiringAuthBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + expiringAuthSubkey + signingKey + (addTimestampSeconds baseTime 10) + [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) + , SigSubPacket False (KeyExpirationTime 20) + ] + signingOnlyBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + signingOnlySubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + authRevocation <- + signSubkeyRevocationWithRSAAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 22) + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidText, [uidCertification])] + [] + [ (SecretSubkeyPkt authSubkey secretAddendum, [authBinding, authRevocation]) + , (SecretSubkeyPkt expiringAuthSubkey secretAddendum, [expiringAuthBinding]) + , (SecretSubkeyPkt signingOnlySubkey secretAddendum, [signingOnlyBinding]) + ] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure "expected secret typed TKUnknown for auth subkey rejection test fixture" >> fail "unreachable" + Left err -> + assertFailure ("fromUnknownToTK failed for auth subkey rejection test fixture: " ++ err) >> fail "unreachable" + + let beforeReport = authSecretSubkeysAtReport beforeTime typedSecret + assertEqual + "report accepted list should match authSecretSubkeysAt before revocation/expiry" + (authSecretSubkeysAt beforeTime typedSecret) + (authSecretSubkeysAccepted beforeReport) + assertEqual + "before revocation/expiry, only signing-only subkey should be rejected" + [AuthSecretSubkeyMissingAuthCapability] + (map authSecretSubkeyRejectedReason (authSecretSubkeysRejected beforeReport)) + + afterReportsViaConduit <- + DC.runConduitRes $ + CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAtReport afterTime DC..| CL.consume + afterReport <- + case afterReportsViaConduit of + [singleReport] -> pure singleReport + other -> + assertFailure ("expected one report from conduitToAuthSecretSubkeysAtReport, got " ++ show (length other)) >> + fail "unreachable" + assertEqual + "after revocation/expiry, no accepted auth subkeys should remain" + [] + (authSecretSubkeysAccepted afterReport) + assertEqual + "after revocation/expiry, rejected reasons should report invalid-time and missing-auth cases for still-visible candidates" + [ AuthSecretSubkeySubkeyInvalidAtTime + , AuthSecretSubkeyMissingAuthCapability + ] + (map authSecretSubkeyRejectedReason (authSecretSubkeysRejected afterReport)) + +testPktWithWireRepOrdUsesRawBytes :: Assertion +testPktWithWireRepOrdUsesRawBytes = do + let src = wireRepRef "src" + pktA = + PktWithWireRep + src + (ByteRange 0 1) + "a" + 0 + (OtherPacketPkt 42 "a") + pktB = + PktWithWireRep + src + (ByteRange 1 1) + "b" + 1 + (BrokenPacketPkt "broken" 42 "b") + assertEqual + "base packet ordering can tie on tag-only fallback" + EQ + (compare (_pktValue pktA) (_pktValue pktB)) + assertEqual + "PktWithWireRep ordering should break ties using packet bytes" + LT + (compare pktA pktB) + +testParsePktsWithWireRepUtil :: FilePath -> Assertion +testParsePktsWithWireRepUtil fn = do + let fpath = "tests/data/" ++ fn + lbs <- BL.readFile fpath + let WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = srcBytes + } = + either + (const + WireRepInput + { wireRepInputRef = wireRepRef lbs + , wireRepInputPayload = lbs + }) + id + (wireRepRefFromInput Nothing lbs) + parsed = parsePktsWithWireRep src srcBytes + chunkedInput = chunkStrict 7 (BL.toStrict lbs) + conduitParsed <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitParsePktsWithWireRep Nothing DC..| CL.consume + conduitParsedChunked <- + DC.runConduitRes $ + CL.sourceList chunkedInput DC..| conduitParsePktsWithWireRep Nothing DC..| CL.consume + assertEqual + "provenance-aware parsePkts preserves packet semantics" + (parsePkts lbs) + (map _pktValue parsed) + assertEqual + "conduit and pure provenance-aware packet parsing agree" + parsed + conduitParsed + assertEqual + "conduit parser handles packets split across chunk boundaries" + parsed + conduitParsedChunked + assertEqual + "packetsFromWireRep returns all packets for the originating bytestream" + parsed + (packetsFromWireRep src parsed) + mapM_ (assertPktProvenance src srcBytes) parsed + where + chunkStrict n bs + | B.null bs = [] + | otherwise = + let (prefix, suffix) = B.splitAt n bs + in prefix : chunkStrict n suffix + +testParseTKsWithWireRepUtil :: FilePath -> Assertion +testParseTKsWithWireRepUtil fn = do + let fpath = "tests/data/" ++ fn + lbs <- BL.readFile fpath + let WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = srcBytes + } = + either + (const + WireRepInput + { wireRepInputRef = wireRepRef lbs + , wireRepInputPayload = lbs + }) + id + (wireRepRefFromInput Nothing lbs) + packets = parsePktsWithWireRep src srcBytes + parsed = parseTKsWithWireRep True packets + plain = parseUnknownTKs True (map _pktValue packets) + conduitParsed <- + DC.runConduitRes $ CL.sourceList packets DC..| conduitToTKsWithWireRep DC..| CL.consume + assertEqual + "provenance-aware parseUnknownTKs preserves TKUnknown semantics" + plain + (map _tkValue parsed) + assertEqual + "conduit and pure provenance-aware TKUnknown parsing agree" + parsed + conduitParsed + assertEqual + "tksFromWireRep returns all TKs for the originating bytestream" + parsed + (tksFromWireRep src parsed) + mapM_ (assertTKProvenance src parsed) parsed + +assertPktProvenance :: WireRepRef -> BL.ByteString -> PktWithWireRep -> Assertion +assertPktProvenance src srcBytes pkt = do + assertEqual + "packet raw bytes round-trip back to the same packet" + (Right (_pktValue pkt)) + (runGet (get :: Get Pkt) (_pktRaw pkt)) + assertEqual + "packet source reference is preserved" + src + (wireRepOfPkt pkt) + let ByteRange offset len = _pktRange pkt + assertEqual + "packet raw bytes match the source bytestream slice" + (_pktRaw pkt) + (BL.take len (BL.drop offset srcBytes)) + +assertTKProvenance :: WireRepRef -> [TKWithWireRep] -> TKWithWireRep -> Assertion +assertTKProvenance src allTks tk = do + assertBool "TKUnknown source reference list includes originating source" (src `elem` _tkWireRepRefs tk) + assertEqual "TKUnknown source reference is preserved" src (wireRepOfTK tk) + assertEqual + "TKUnknown packet references reconstruct the semantic TKUnknown packet sequence" + (flattenTK (_tkValue tk)) + (map _pktValue (packetRefsOfTK tk)) + assertEqual + "TKUnknown source span matches the span of its packet references" + (spanByteRanges (map _pktRange (packetRefsOfTK tk))) + (_tkWireRepRange tk) + mapM_ + (\pkt -> + assertBool + "packet backlink resolves to containing TKUnknown" + (tk `elem` tksContainingPacket pkt allTks)) + (packetRefsOfTK tk) + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + assertEqual + "structured provenance retains semantic primary key" + (_tkuKey (_tkValue tk)) + (_tkStructuredPrimaryKey structured) + assertEqual + "structured provenance retains packet source reference list" + (_tkWireRepRefs tk) + (_tkStructuredWireRepRefs structured) + resolved <- resolveStructuredPacketRefs structured + assertEqual + "structured provenance resolves packet refs in TKUnknown packet order" + (map _pktValue (packetRefsOfTK tk)) + (map _pktValue resolved) + assertEqual + "structured provenance keeps stable packet ref ids" + (map packetRefIdOf (packetRefsOfTK tk)) + (map packetRefIdOf resolved) + +resolveStructuredPacketRefs :: TKStructuredWithWireRep -> IO [PktWithWireRep] +resolveStructuredPacketRefs structured = do + let collectSigRefs = map _signatureWithWireRefRef + uidRefs = + concatMap + (\uid -> _uidWithWireRefsRef uid : collectSigRefs (_uidWithWireRefsSignatures uid)) + (_tkStructuredUIDs structured) + uatRefs = + concatMap + (\uat -> _uatWithWireRefsRef uat : collectSigRefs (_uatWithWireRefsSignatures uat)) + (_tkStructuredUAts structured) + subRefs = + concatMap + (\sub -> + _subkeyWithWireRefsRef sub : collectSigRefs (_subkeyWithWireRefsSignatures sub)) + (_tkStructuredSubkeys structured) + refIds = + _tkStructuredPrimaryKeyRef structured : + collectSigRefs (_tkStructuredDirectSignatures structured) ++ uidRefs ++ uatRefs ++ subRefs + mapM + (\refId -> + case lookupPacketRef structured refId of + Nothing -> + assertFailure + ("lookupPacketRef failed for ref id " ++ show refId) + Just pkt -> pure pkt) + refIds + +testCanonicalizeTKWithWireRepMatchesManualWireOrdering :: Assertion +testCanonicalizeTKWithWireRepMatchesManualWireOrdering = do + lbs <- readFixtureLazy "pubring.gpg" + let src = wireRepRef lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) + case parsed of + (tk:_) -> + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + let shuffled = + structured + { _tkStructuredDirectSignatures = + reverse (_tkStructuredDirectSignatures structured) + , _tkStructuredUIDs = + reverse + (map + (\uid -> + uid + { _uidWithWireRefsSignatures = + reverse (_uidWithWireRefsSignatures uid) + }) + (_tkStructuredUIDs structured)) + , _tkStructuredUAts = + reverse + (map + (\uat -> + uat + { _uatWithWireRefsSignatures = + reverse (_uatWithWireRefsSignatures uat) + }) + (_tkStructuredUAts structured)) + , _tkStructuredSubkeys = + reverse + (map + (\sub -> + sub + { _subkeyWithWireRefsSignatures = + reverse (_subkeyWithWireRefsSignatures sub) + }) + (_tkStructuredSubkeys structured)) + } + expected <- + case manualCanonicalizeStructured shuffled of + Left err -> + assertFailure ("manual canonicalization failed: " ++ err) >> fail "manual canonicalization failed" + Right x -> pure x + got <- + case canonicalizeTKStructuredWithWireRep shuffled of + Left err -> + assertFailure ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) >> + fail "canonicalizeTKStructuredWithWireRep failed" + Right x -> pure x + assertEqual + "canonicalizeTKStructuredWithWireRep matches manual wire-byte ordering" + expected + got + wrapped <- + case canonicalizeTKWithWireRep tk of + Left err -> + assertFailure ("canonicalizeTKWithWireRep failed: " ++ show err) >> + fail "canonicalizeTKWithWireRep failed" + Right x -> pure x + structuredCanonical <- + case canonicalizeTKStructuredWithWireRep structured of + Left err -> + assertFailure ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) >> + fail "canonicalizeTKStructuredWithWireRep failed" + Right x -> pure x + assertEqual + "canonicalizeTKWithWireRep delegates to structured canonicalization" + structuredCanonical + wrapped + [] -> + assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" + where + manualCanonicalizeStructured :: TKStructuredWithWireRep -> Either String TKUnknown + manualCanonicalizeStructured structured = do + direct <- sortSigs (_tkStructuredDirectSignatures structured) + uids <- + sortByRef _uidWithWireRefsRef =<< + mapM + (\uid -> do + sigs <- sortSigs (_uidWithWireRefsSignatures uid) + Right (uid, sigs)) + (_tkStructuredUIDs structured) + uats <- + sortByRef _uatWithWireRefsRef =<< + mapM + (\uat -> do + sigs <- sortSigs (_uatWithWireRefsSignatures uat) + Right (uat, sigs)) + (_tkStructuredUAts structured) + subs <- + sortByRef _subkeyWithWireRefsRef =<< + mapM + (\sub -> do + sigs <- sortSigs (_subkeyWithWireRefsSignatures sub) + Right (sub, sigs)) + (_tkStructuredSubkeys structured) + Right $ + TKUnknown + { _tkuKey = _tkStructuredPrimaryKey structured + , _tkuRevs = map _signatureWithWireRefValue direct + , _tkuUIDs = + map + (\(uid, sigs) -> + (_uidWithWireRefsValue uid, map _signatureWithWireRefValue sigs)) + uids + , _tkuUAts = + map + (\(uat, sigs) -> + (_uatWithWireRefsValue uat, map _signatureWithWireRefValue sigs)) + uats + , _tkuSubs = + map + (\(sub, sigs) -> + (_subkeyWithWireRefsValue sub, map _signatureWithWireRefValue sigs)) + subs + } + where + wireBytes refId = + maybe + (Left ("lookupPacketRef failed for ref id " ++ show refId)) + (Right . _pktRaw) + (lookupPacketRef structured refId) + + sortSigs sigs = do + keyed <- + mapM + (\sig -> do + raw <- wireBytes (_signatureWithWireRefRef sig) + Right ((raw, _signatureWithWireRefRef sig), sig)) + sigs + Right (map snd (sortOn fst keyed)) + + sortByRef refAccessor items = do + keyed <- + mapM + (\(x, sigs) -> do + raw <- wireBytes (refAccessor x) + Right ((raw, refAccessor x), (x, sigs))) + items + Right (map snd (sortOn fst keyed)) + +testCanonicalizeTKWithWireRepReportsMissingRef :: Assertion +testCanonicalizeTKWithWireRepReportsMissingRef = do + lbs <- readFixtureLazy "pubring.gpg" + let src = wireRepRef lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) + case parsed of + (tk:_) -> + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + let badRef = PacketRefId src 999999 + brokenWithBadRef = + case _tkStructuredDirectSignatures structured of + (sig:rest) -> + Just + structured + { _tkStructuredDirectSignatures = + sig {_signatureWithWireRefRef = badRef} : rest + } + [] -> + case _tkStructuredUIDs structured of + (uid:restUIDs) -> + Just + structured + { _tkStructuredUIDs = + uid {_uidWithWireRefsRef = badRef} : restUIDs + } + [] -> + case _tkStructuredUAts structured of + (uat:restUATs) -> + Just + structured + { _tkStructuredUAts = + uat {_uatWithWireRefsRef = badRef} : restUATs + } + [] -> + case _tkStructuredSubkeys structured of + (sub:restSubs) -> + Just + structured + { _tkStructuredSubkeys = + sub {_subkeyWithWireRefsRef = badRef} : restSubs + } + [] -> Nothing + case brokenWithBadRef of + Nothing -> + assertFailure + "pubring.gpg first TKUnknown unexpectedly has no direct signatures, UIDs, UATs, or subkeys" + Just broken -> + case canonicalizeTKStructuredWithWireRep broken of + Left (CanonicalizeMissingPacketRef ref) -> + assertEqual "missing ref error should include unresolved ref id" badRef ref + Left err -> + assertFailure ("Expected CanonicalizeMissingPacketRef, got " ++ show err) + Right _ -> + assertFailure "Expected canonicalization to fail on missing packet ref" + [] -> + assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testWireRepRefTracksArmorProvenance :: Assertion +testWireRepRefTracksArmorProvenance = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + case wireRepRefFromInput Nothing armored of + Left err -> assertFailure ("wireRepRefFromInput failed on armored input: " ++ err) + Right WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = payload + } -> do + assertBool + "wireRepRefFromInput should mark ASCII-armored input as originally armored" + (_wireRepWasOriginallyArmored src) + assertBool + "dearmored payload should parse into packets" + (not (null (parsePktsWithWireRep src payload))) + +testTksFromWireRepMatchesAnySource :: Assertion +testTksFromWireRepMatchesAnySource = do + lbs <- readFixtureLazy "pubring.gpg" + let srcA = wireRepRef lbs + srcB = namedWireRepRef "synthetic-merge-source" lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) + case parsed of + (tk:_) -> do + let multiSourceTk = tk { _tkWireRepRefs = srcA :| [srcB] } + assertBool + "tksFromWireRep matches TKs whose source list contains the queried source" + (multiSourceTk `elem` tksFromWireRep srcA [multiSourceTk]) + assertBool + "tksFromWireRep can match secondary provenance sources" + (multiSourceTk `elem` tksFromWireRep srcB [multiSourceTk]) + [] -> + assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testSemigroupTKWithWireRepPreservesStructuredRefs :: Assertion +testSemigroupTKWithWireRepPreservesStructuredRefs = do + lbs <- readFixtureLazy "pubring.gpg" + let srcA = wireRepRef lbs + srcB = namedWireRepRef "synthetic-merge-source" lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) + case parsed of + (tk:_) -> do + let remappedPackets = map (\pkt -> pkt { _pktWireRepRef = srcB }) (packetRefsOfTK tk) + tkFromSecondSource = + TKWithWireRep + (srcB :| []) + (spanByteRanges (map _pktRange remappedPackets)) + remappedPackets + (_tkValue tk) + merged = tk <> tkFromSecondSource + mergedRefIds = map packetRefIdOf (packetRefsOfTK merged) + assertEqual + "Semigroup preserves TKUnknown semantic merge behavior" + (_tkValue tk <> _tkValue tkFromSecondSource) + (_tkValue merged) + assertBool + "Semigroup merged provenance references include both sources" + (srcA `elem` wireRepsOfTK merged && srcB `elem` wireRepsOfTK merged) + assertEqual + "Semigroup result packet refs match merged TKUnknown packet sequence" + (flattenTK (_tkValue merged)) + (map _pktValue (packetRefsOfTK merged)) + assertEqual + "Semigroup result keeps packet refs unique by source-aware PacketRefId" + (length mergedRefIds) + (length (nub mergedRefIds)) + case toStructuredTKWithWireRep merged of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed for Semigroup result: " ++ err) + Right structured -> do + resolved <- resolveStructuredPacketRefs structured + assertEqual + "Semigroup result structured refs resolve in packet order" + (map _pktValue (packetRefsOfTK merged)) + (map _pktValue resolved) + [] -> + assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testKeyPktWrappersRoundTrip :: Assertion +testKeyPktWrappersRoundTrip = do + fixture <- loadV6UnencryptedSecretKeyFixtureForProperty + case fixture of + Left err -> + assertFailure err + Right (pkp, ska, _) -> do + let publicPrimaryPkt = PublicKeyPkt pkp + publicSubkeyPkt = PublicSubkeyPkt pkp + secretPrimaryPkt = SecretKeyPkt pkp ska + secretSubkeyPkt = SecretSubkeyPkt pkp ska + assertEqual + "mkPrimaryKeyPkt preserves public primary packets" + publicPrimaryPkt + (someKeyPktToPkt (mkPrimaryKeyPkt pkp Nothing)) + assertEqual + "mkPrimaryKeyPkt preserves secret primary packets" + secretPrimaryPkt + (someKeyPktToPkt (mkPrimaryKeyPkt pkp (Just ska))) + assertEqual + "mkSubkeyKeyPkt preserves public subkey packets" + publicSubkeyPkt + (someKeyPktToPkt (mkSubkeyKeyPkt pkp Nothing)) + assertEqual + "mkSubkeyKeyPkt preserves secret subkey packets" + secretSubkeyPkt + (someKeyPktToPkt (mkSubkeyKeyPkt pkp (Just ska))) + case pktToPublicKeyPkt publicPrimaryPkt of + Nothing -> + assertFailure "pktToPublicKeyPkt should accept PublicKeyPkt" + Just keyPkt -> do + assertEqual "public primary role is preserved" KeyPktPrimary (keyPktRole keyPkt) + assertEqual "public primary TKUnknown key view is preserved" (pkp, Nothing) (keyPktTKKey keyPkt) + assertEqual "public primary round-trips through KeyPkt" publicPrimaryPkt (keyPktToPkt keyPkt) + case pktToPublicKeyPkt publicSubkeyPkt of + Nothing -> + assertFailure "pktToPublicKeyPkt should accept PublicSubkeyPkt" + Just keyPkt -> + assertEqual "public subkey role is preserved" KeyPktSubkey (keyPktRole keyPkt) + case pktToSecretKeyPkt secretPrimaryPkt of + Nothing -> + assertFailure "pktToSecretKeyPkt should accept SecretKeyPkt" + Just keyPkt -> do + assertEqual "secret primary role is preserved" KeyPktPrimary (keyPktRole keyPkt) + assertEqual "secret primary TKUnknown key view is preserved" (pkp, Just ska) (keyPktTKKey keyPkt) + assertEqual "secret primary round-trips through KeyPkt" secretPrimaryPkt (keyPktToPkt keyPkt) + assertEqual + "secret primary public view downgrades to PublicKeyPkt" + publicPrimaryPkt + (keyPktToPkt (keyPktToPublicView keyPkt)) + case pktToSecretKeyPkt secretSubkeyPkt of + Nothing -> + assertFailure "pktToSecretKeyPkt should accept SecretSubkeyPkt" + Just keyPkt -> do + assertEqual "secret subkey role is preserved" KeyPktSubkey (keyPktRole keyPkt) + assertEqual + "secret subkey public view downgrades to PublicSubkeyPkt" + publicSubkeyPkt + (keyPktToPkt (keyPktToPublicView keyPkt)) + case pktToSomeKeyPktEither (UserIdPkt "not a key packet") of + Left (NotAKeyPacket pkt) -> + assertEqual "non-key coercion error reports the original packet" (UserIdPkt "not a key packet") pkt + other -> + assertFailure ("Expected NotAKeyPacket error, got " ++ show other) + +testTKTypedRoundTripAndPublicView :: Assertion +testTKTypedRoundTripAndPublicView = do + pubringBytes <- readFixtureLazy "pubring.gpg" + let publicParsed = parseUnknownTKs True (parsePkts pubringBytes) + publicTk <- + case publicParsed of + (tk:_) -> pure tk + [] -> assertFailure "pubring.gpg should parse to at least one TKUnknown" >> fail "unreachable" + publicTyped <- + case fromUnknownToTK publicTk of + Left err -> assertFailure ("fromUnknownToTK failed for public TKUnknown: " ++ err) >> fail "unreachable" + Right typed@(SomePublicTK _) -> pure typed + Right (SomeSecretTK _) -> + assertFailure "fromUnknownToTK should classify pubring primary key as public" >> fail "unreachable" + assertEqual + "public typed TKUnknown round-trips back to untyped TKUnknown" + publicTk + (someTKToUnknown publicTyped) + + armored <- readFixtureLazy "v6-secret.pgp.aa" + secretTk <- do + armors <- + case AA.decodeLazy armored of + Left err -> + assertFailure ("failed to decode v6-secret fixture: " ++ err) >> fail "unreachable" + Right as -> pure as + armor <- + case armors of + (a:_) -> pure a + [] -> assertFailure "v6-secret.pgp.aa should contain one armored payload" >> fail "unreachable" + case parseUnknownTKs True (parsePkts (armorPayload armor)) of + (tk:_) -> pure tk + [] -> assertFailure "v6-secret.pgp.aa should parse to at least one TKUnknown" >> fail "unreachable" + secretTyped <- + case fromUnknownToTK secretTk of + Left err -> assertFailure ("fromUnknownToTK failed for secret TKUnknown: " ++ err) >> fail "unreachable" + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure "fromUnknownToTK should classify v6 secret primary key as secret" >> fail "unreachable" + let secretRoundTrip = tkToUnknown secretTyped + assertEqual + "secret typed TKUnknown round-trips back to untyped TKUnknown" + secretTk + secretRoundTrip + let projectedPublic = tkToUnknown (publicViewTK secretTyped) + expectedPublic = + secretTk + { _tkuKey = (\(pkp, _) -> (pkp, Nothing)) (_tkuKey secretTk) + , _tkuSubs = map (\(pkt, sigs) -> (publicKeyPacketOf pkt, sigs)) (_tkuSubs secretTk) + } + assertEqual + "publicViewTK drops secret material from primary/subkeys" + expectedPublic + projectedPublic + +flattenTK :: TKUnknown -> [Pkt] +flattenTK tk = + [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ + map SignaturePkt (_tkuRevs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ + concatMap flattenUAt (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk) + where + (pkp, mska) = _tkuKey tk + flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs + flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs + flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs + +testParseTKsDropsDisallowedPrimaryKeySigContextV4 :: Assertion +testParseTKsDropsDisallowedPrimaryKeySigContextV4 = do + let pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) + invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + [tk] -> + assertEqual + "parseUnknownTKs True should drop GenericCert as a primary-key signature in v4" + [] + (_tkuRevs tk) + other -> + assertFailure ("Expected one TKUnknown when dropping invalid v4 signature context, got " ++ show other) + +testParseTKsDropsDisallowedPrimaryKeySigContextV6 :: Assertion +testParseTKsDropsDisallowedPrimaryKeySigContextV6 = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) + invalidSig = + SigV6 + GenericCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x01)) + [] + [] + 0 + (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + [tk] -> + assertEqual + "parseUnknownTKs True should drop GenericCert as a primary-key signature in v6" + [] + (_tkuRevs tk) + other -> + assertFailure ("Expected one TKUnknown when dropping invalid v6 signature context, got " ++ show other) + +testParseTKsAcceptsAllowedPrimaryKeySigContextV6 :: Assertion +testParseTKsAcceptsAllowedPrimaryKeySigContextV6 = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) + allowedSig = + SigV6 + KeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x02)) + [] + [] + 0 + (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig] of + [tk] -> + assertBool + "parseUnknownTKs True should keep allowed v6 key-revocation signatures on primary keys" + (not (null (_tkuRevs tk))) + other -> + assertFailure + ("Expected one TKUnknown with a retained v6 revocation signature, got " ++ show other) + + diff --git a/tests/data/encryption-sym-aes256-sha256.pgp b/tests/data/encryption-sym-aes256-sha256.pgp new file mode 100644 --- /dev/null +++ b/tests/data/encryption-sym-aes256-sha256.pgp @@ -0,0 +1,1 @@ +Ã.  j,KWfb‚ÿ4q¯õ¸ïtugs«}«{{%Ū»ˆ¡t$WxMÜó)¬ÿ;Ò6˜8:µâÅŸ}$•¯ñ|{ˆ™°±Ê"ÅNWã¹Å@˜ör¯†JÖK…êDM7V£] ‹€õ diff --git a/tests/data/seipdv2-for-v4-key.pgp.aa b/tests/data/seipdv2-for-v4-key.pgp.aa new file mode 100644 --- /dev/null +++ b/tests/data/seipdv2-for-v4-key.pgp.aa @@ -0,0 +1,8 @@ +-----BEGIN PGP MESSAGE----- + +wWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0BwOFvfLenhFHR1kdTjP/Wp+Ghn +LO5VTiE7bl1W7V/wAzAlO0jypAZyu5jCTeqGKqjipkMDEbou8BKoRPUInw6jn04s +P7QkQ+ZGFFlsY2frya3SagIJAgbmRJucr1ylMximFV/OaApO0g+y/AU6lJ74s6rU +5mK8o91lNZt976H0vAiqIhRNWLT18MUqd4/mPA75DVKBrkFzxoiMf+CpT6vJmHH/ +K008SSmmSROTVY1XOiNxfW/Ohzj3ExR2h1k= +-----END PGP MESSAGE----- diff --git a/tests/data/seipdv2-three-recipients.pgp.aa b/tests/data/seipdv2-three-recipients.pgp.aa new file mode 100644 --- /dev/null +++ b/tests/data/seipdv2-three-recipients.pgp.aa @@ -0,0 +1,13 @@ +-----BEGIN PGP MESSAGE----- + +wW0GIQZPa+Qzhph44YDttKf207N15ZZ3CS8z5eTPx5Qg0amc4xl6s9436hXVOf9U +lbOM7X9pn7y8WPNI0YkebVA1QApUTih6jitnR1Wpyt4/A0Vj6RErk+SdC3WiKHWI +OuRShYlvNiK+CEvQD/4FwW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF ++5URxRn+KP0OCEXprvbaDAmzJqDbXuVx5FW7uAGB5GVeEPt1XSjyfokGV/L4YRPU +TbC2y2O6v2E/9wjR1C/7zxe6KlpDwbcJQqbFzIZzwWwGFQTIJj/G1nYES26XOVnC +8sLK4w3pCBIBB0Cq0yu1vFmBEh/u4ja1vGjGaed0nZln10mE0rxvF4kISTDRXXAE +iii1x557ssJf3VW4ziIVSHPy+nOE8mAYbmfO11AtzapS5d5mZh7PfjFGt5LSdgIJ +Agad51+IWqNRs2YEAz6TKjTSuLOpQDyDRmod6XKIeP7F0dX0jp1FSy0C15pu9lxS +KZE4h9DRZjelsbi3MxP15uHRQkUs/JtxWVvz577/wkbHkZDg1JFD0e19k009EN5/ +7vN3KaeRKAJeOSNQnmjCqJTemkk= +-----END PGP MESSAGE----- diff --git a/tests/data/seipdv2-two-recipients.pgp.aa b/tests/data/seipdv2-two-recipients.pgp.aa new file mode 100644 --- /dev/null +++ b/tests/data/seipdv2-two-recipients.pgp.aa @@ -0,0 +1,11 @@ +-----BEGIN PGP MESSAGE----- + +wW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF+5URxRmPwQGf5CbZQKLE +VnWosSwUCTzfssCThJ8F3ipLqGWyJyjPK9ORkR2F2mJcFaGN37sgh6YS3YDCy7M8 +KtEW4sCKbPPaCi8AHyWTwWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0Cc/SaD +cEivp/+lPv11uVOacGCxzAUmg3j0N7QfvpCOYDAPTgXG+2wHd4o1GCW3t/vCTnHU +BsC9fym6071xys8em8YXQAMwYaxNFd1tQd9GL5zSdgIJAgbnRfhxbeKxWPQjGsCo +11qRYfinBxjBQUwI8NpwPrGstym4RvVuxDSBGMrga6FRIjAn9VD9cwDZsJ5mxWhO +bsV0rVwQr/Nn2ibpJpOzVHty/6hkyf3dRDSPiaZdRQmvuWCTtyWd/ptLBX6oK0c6 +JidNvfI= +-----END PGP MESSAGE----- diff --git a/tests/data/v4-encrypted-secret.pgp.aa b/tests/data/v4-encrypted-secret.pgp.aa new file mode 100644 --- /dev/null +++ b/tests/data/v4-encrypted-secret.pgp.aa @@ -0,0 +1,53 @@ +-----BEGIN PGP PRIVATE KEY BLOCK----- +Comment: D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1 +Comment: +Comment: v4 Test User + +xYYEakxBgBYJKwYBBAHaRw8BAQdAP6cjID4HFp73MwUjEA/nCYXMRSItPLypDLtZ +jPULW1j+CQMIBVN3fzlNeWf/NUtTI5lsyaQwJ7txmqD2DJddv9MzNrfdevWxKi6/ +qZi5Pj/B2fJtowuVKubAkW8NG1Jt9unEFzkRPjITiScX1kzBod6Pz8LAEQQfFgoA +gwWCakxBgAWJBaSPvQMLCQcJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRp +b25zLnNlcXVvaWEtcGdwLm9yZ7fr7BFc0dXw/uIYQrhm5mpoiJ4e0mp7WnbeXyx0 +bx4DAxUKCAKbAQIeCRYhBNLggek/3KLni1/EM4EdkkM5S3nBAAAEkAD+JNB39+p4 +4O+r5Cj5mvh9koCA9QnkY/lpToQvDSGsP4YBANT1ActXzuojvIiLDFGOrjrazt5P +b0UTIX1xe4pYyhwJzRQ8djR0ZXN0QGV4YW1wbGUub3JnPsLAEQQTFgoAgwWCakxB +gAWJBaSPvQMLCQcJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNl +cXVvaWEtcGdwLm9yZ6pEf7QImN4zmmOa2+CA5afhgwI6rRMVVxuVJo5W1JunAxUK +CAKbAQIeCRYhBNLggek/3KLni1/EM4EdkkM5S3nBAAB42AEA8RDxMFea/zKix9NK +bAaeBwqOJMcscgnuuCHtyTqEJYoBAJ0OFgd23E1F4Bk36WagxQaKEm8ydT2plOoy +8heMUBQGzQx2NCBUZXN0IFVzZXLCwBQEExYKAIYFgmpMQYAFiQWkj70DCwkHCRCB +HZJDOUt5wUcUAAAAAAAeACBzYWx0QG5vdGF0aW9ucy5zZXF1b2lhLXBncC5vcmcQ +LUNEYWE0LcmZi084v2NCvn6yEuINrfq9OGkVy385DAMVCggCmQECmwECHgkWIQTS +4IHpP9yi54tfxDOBHZJDOUt5wQAAYOoA/RGoqHdtnZBqxUeXtUfIqoXnHn+FEphU +6CS4GHwYgSJFAP0ce+15SkJi2VvSElFqvkeIbdh7gomteMAfqIJFAW/OCMeGBGpM +QYAWCSsGAQQB2kcPAQEHQE1Rjs6t3JJG2+UEf+zBg+g4pRD/ol/iOpg8P58vQR1P +/gkDCBjWEF9Wp4kL/6dQC/ZJG+cMCBNObsxLap40lfTke7B9bIkvJMKG2zgQZFmD ++P0Xjx54AoMCdBoD5elL4g8RHrqLfRmqEsgCX192nwZOiB7CwMUEGBYKATcFgmpM +QYAFiQWkj70JEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNlcXVv +aWEtcGdwLm9yZyPbWroy3KJpldFNV47M7QMGHQ8rQ6Ds0mJXeBzA5P5CApsgvqAE +GRYKAG8FgmpMQYAJEPLqKEWf4aYJRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNl +cXVvaWEtcGdwLm9yZ7r2xBAYhuFDFKoEDwXIgc6m3QXvzNQG/eFv2JfAS712FiEE +Z++ptbFZk3QKYa7M8uooRZ/hpgkAAASFAP9o4O5pjTjH1ujo8UXb+22P69+Fcihz +OzfCYrSng/pV9wEAk1WgfQCms4H20m2IPYeqLyOMfH3sIuKKTrDGjSeg1gUWIQTS +4IHpP9yi54tfxDOBHZJDOUt5wQAA4mUBANMpQNBcIb+Gi8iaiyYlMHM3Rtod/TMw +prV/DbYEIpUQAP4xd2kzSQVhuUCPiq+RQLei5E3Qx9bS0GIFmt/h0raaAMeFBGpM +QYAWCSsGAQQB2kcPAQEHQMNngMJd1pQ+XQ0GUbSiwS3OHZCd4dUfGAkLNB6JqbRY +/gkDCMVmOyXdRurS/8c2HaPSB1jITSgg6ZAVG6V1ZxhfVce7HwSjLhKuICQi9+Y3 +GDljo3ue/QFTro54AclH9rAPPlwpsbcpYOllULUoz23d/8LAxQQYFgoBNwWCakxB +gAWJBaSPvQkQgR2SQzlLecFHFAAAAAAAHgAgc2FsdEBub3RhdGlvbnMuc2VxdW9p +YS1wZ3Aub3JnZUbCxX8ypIkwqs0KmQ4WjsmPgyqO4agTzNiWQCDcJBQCmwK+oAQZ +FgoAbwWCakxBgAkQtObvvvoWfY5HFAAAAAAAHgAgc2FsdEBub3RhdGlvbnMuc2Vx +dW9pYS1wZ3Aub3JnxPnaJie9YiqdQjuk3kKU3g+U5P4LCs/9DLVbcMWxE58WIQTK +yP+HQkGn71lSMmG05u+++hZ9jgAAuTwA/A1884gQ+whCdQYHqx2dRSb6ijTEID04 +vNfipqkwVeMEAQDx/BDvmCjhQxvyLXwQWzwmpg9TajJ9JIX5gfQfQ+AUCBYhBNLg +gek/3KLni1/EM4EdkkM5S3nBAACEGAEAhCuyvJd3xYFoy1oSfFT05SYYffEu14vV +8AZEImlbMxIBAL1VPDuFgzurhFH11uBNFZctiD0STqy3ie0FqWdu79ECx4sEakxB +gBIKKwYBBAGXVQEFAQEHQGYIS0ABM7tj0fiVSRc01ubWpmamos9nmfwJjlsL2gV6 +AwEIB/4JAwiTiWBEjQz6e/+8ggxoJQAReywsGp/dyXqGJKmUMzZ3Wd4JOdY/eaa/ +/JXUxUFn5xQM4aQMgzNqZHhVETviatOgzGjdIYkrXk/B+9xRSCutwsAGBBgWCgB4 +BYJqTEGABYkFpI+9CRCBHZJDOUt5wUcUAAAAAAAeACBzYWx0QG5vdGF0aW9ucy5z +ZXF1b2lhLXBncC5vcmfsDzehKc6JLlUgf6olNquNINHH1gVHtdwJ95ebnDYTUQKb +DBYhBNLggek/3KLni1/EM4EdkkM5S3nBAADqzQEA1IooYWmFopaZ0DPcEVRR4laQ +7XfFjtq6hmJHaCdy8FcBAJKK1DZchtVbUMZeiVfin/ZRC84Ex44f54THm7Xne/EC +=f9e3 +-----END PGP PRIVATE KEY BLOCK----- diff --git a/tests/data/v4-encrypted.rev.aa b/tests/data/v4-encrypted.rev.aa new file mode 100644 --- /dev/null +++ b/tests/data/v4-encrypted.rev.aa @@ -0,0 +1,14 @@ +-----BEGIN PGP PUBLIC KEY BLOCK----- +Comment: Revocation certificate for +Comment: D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1 +Comment: +Comment: v4 Test User + +xjMEakxBgBYJKwYBBAHaRw8BAQdAP6cjID4HFp73MwUjEA/nCYXMRSItPLypDLtZ +jPULW1jCwAsEIBYKAH0FgmpMQYAJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90 +YXRpb25zLnNlcXVvaWEtcGdwLm9yZ/hWf5apgI9nH8rb38xB9/pvNhBar7LRWmx3 +nhaGr1GIDR0AVW5zcGVjaWZpZWQWIQTS4IHpP9yi54tfxDOBHZJDOUt5wQAAytsA +/R0VwOa7/1datJPZxyqeF0t9xD/XUGvjxMAnDoJSWyLyAQCPOEdgir5BeKShK+Z3 +J45dM+Ccv0l5tcQDqUsOUMa0AA== +=ASZC +-----END PGP PUBLIC KEY BLOCK----- diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -1,928 +1,38 @@ -{-# LANGUAGE OverloadedStrings #-} - -- suite.hs: hOpenPGP test suite --- Copyright © 2012-2019 Clint Adams +-- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase) -import Test.Tasty.QuickCheck as QC -import Codec.Encryption.OpenPGP.Arbitrary () -import Codec.Encryption.OpenPGP.Compression (compressPkts, decompressPkt) -import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize) -import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) -import Codec.Encryption.OpenPGP.KeyringParser (parseTKs) -import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) -import Codec.Encryption.OpenPGP.Serialize (parsePkts) -import Codec.Encryption.OpenPGP.Signatures - ( verifyAgainstKeys - , verifySigWith - , verifyTKWith - ) -import Codec.Encryption.OpenPGP.Types -import Control.Error.Util (isRight) -import Control.Exception.Base (SomeException, catch) -import Control.Monad.Trans.Resource (ResourceT) -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.RSA as RSA -import Data.Bifunctor (bimap) -import Data.Binary (get, put) -import Data.Binary.Get (Get, runGetOrFail) -import Data.Binary.Put (runPut) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) -import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt) -import Data.Conduit.OpenPGP.Keyring - ( conduitToTKs - , conduitToTKsDropping - , sinkKeyringMap - ) -import Data.Conduit.OpenPGP.Verify (conduitVerify) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.IxSet.Typed ((@=), getOne) -import Data.Maybe (isJust) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (pretty) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) - -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL - --- this needs a better name -runGet :: Get a -> BL.ByteString -> Either String a -runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs) - --- FIXME: nothing tests serialization of TKs -testSerialization :: FilePath -> Assertion -testSerialization fpr = do - bs <- BL.readFile $ "tests/data/" ++ fpr - let firstpass = runGet get bs - case fmap unBlock firstpass of - Left _ -> assertFailure $ "First pass failed on " ++ fpr - Right [] -> - assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." - Right packs -> do - let roundtrip = runPut $ put (Block packs) - let secondpass = runGet (get :: Get (Block Pkt)) roundtrip - if fmap unBlock secondpass == Right [] - then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." - else assertEqual ("for " ++ fpr) firstpass secondpass - -testCompression :: FilePath -> Assertion -testCompression fpr = do - bs <- BL.readFile $ "tests/data/" ++ fpr - let firstpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ bs - case firstpass of - Left _ -> assertFailure $ "First pass failed on " ++ fpr - Right [] -> - assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." - Right packs -> do - let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] - let secondpass = - fmap (concatMap decompressPkt . unBlock) . runGet get $ roundtrip - if secondpass == Right [] - then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." - else assertEqual ("for " ++ fpr) firstpass secondpass - -counter :: (Monad m) => DC.ConduitT a DC.Void m Int -counter = CL.fold (const . (1 +)) 0 - -testConduitOutputLength :: - FilePath - -> DC.ConduitT B.ByteString b (ResourceT IO) () - -> Int - -> Assertion -testConduitOutputLength fpr c target = do - len <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter - assertEqual ("expected length " ++ show target) target len - -testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion -testPKAandSizeAndKeyIDandFingerprint fpr kf = do - bs <- BL.readFile $ "tests/data/" ++ fpr - case runGet (get :: Get Pkt) bs of - Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." - Right (PublicKeyPkt pkp) -> do - let pref = - concat - [ pkalgoAbbrev (_pkalgo pkp) - , either (const "unknown") show (pubkeySize (_pubkey pkp)) - , ":" - , either (const "unknown") (show . pretty) (eightOctetKeyID pkp) - , "/" - ] - assertEqual - ("for " ++ fpr ++ " (spaceless)") - (spaceless kf) - (pref ++ show (pretty (fingerprint pkp))) - assertEqual - ("for " ++ fpr ++ " (spaced)") - kf - (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) - _ -> assertFailure "Expected public key, got something else." - where - spaceless = filter (/= ' ') - -testKeyringLookup :: FilePath -> String -> Bool -> Assertion -testKeyringLookup fpr eok expected = do - kr <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ fpr) DC..| conduitGet get DC..| conduitToTKs DC..| - sinkKeyringMap - let key = getOne (kr @= (read eok :: EightOctetKeyId)) - assertEqual (eok ++ " in " ++ fpr) expected (isJust key) - -testVerifyMessage :: - FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion -testVerifyMessage keyring message issuers = do - kr <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyring) DC..| conduitGet get DC..| - conduitToTKs DC..| - sinkKeyringMap - verification <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ message) DC..| conduitGet get DC..| - conduitDecompress DC..| - conduitVerify kr Nothing DC..| - CL.consume - let verification' = - map (fmap (fingerprint . _verificationSigner)) verification - assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' - -testKeysSelfVerification :: Bool -> FilePath -> Assertion -testKeysSelfVerification expectsuccess keyfile = do - ks <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| - conduitToTKs DC..| - CL.consume - let verifieds = - mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks - assertEqual - (keyfile ++ " self-verification") - expectsuccess - (isRight verifieds) -- FIXME: - -testKeysExpiration :: Bool -> FilePath -> Assertion -testKeysExpiration expectsuccess keyfile = do - ks <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| - conduitToTKs DC..| - CL.consume - let Right verifieds = - mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks - tvalid = - all - (isTKTimeValid - (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) - verifieds - assertEqual (keyfile ++ " key expiration") expectsuccess tvalid - --- This needs a lot of work -testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion -testSymmetricEncryption encfile passfile cleartext = do - passphrase <- BL.readFile $ "tests/data/" ++ passfile - -- get parse tree - pt <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ encfile) DC..| conduitGet get DC..| - CL.consume - -- assert parse tree has exactly two packets: skesk, encdata - assertEqual "wrong number of packets" 2 (length pt) - let skesk = fromPkt . head $ pt - d = fromPkt . last $ pt - -- FIXME: these assertions don't currently do anything properly, - -- because haskell notices the _-prefixed accessor invocations below - -- and the type system chokes before we hit them: - assertEqual "first packet should be SKESK" SKESKType (packetType skesk) - assertEqual - "second packet should be encrypted data" - SymEncIntegrityProtectedDataType - (packetType d) - decrypted <- - catch - (DC.runConduitRes $ - CL.sourceList pt DC..| conduitDecrypt (fakeCallback passphrase) DC..| - CL.consume) - (\e -> do - let err = show (e :: SomeException) - assertFailure ("decryption threw exception: " ++ err)) - let payload = _literalDataPayload . fromPkt . head $ decrypted - assertEqual ("cleartext for " ++ encfile) cleartext payload - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - -testSecretKeyDecryption :: FilePath -> FilePath -> Assertion -testSecretKeyDecryption keyfile passfile = do - passphrase <- BL.readFile $ "tests/data/" ++ passfile - kr <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| - CL.consume - let SecretKey pkp ska = fromPkt . head $ kr - SUUnencrypted skey _ = decryptPrivateKey (pkp, ska) passphrase - doPkeyAndSkeyMatch (_pubkey pkp) skey - --- FIXME: this should be reworked either with tasty-golden or some other form of sanity -testSecretKeyEncryption :: FilePath -> FilePath -> Assertion -testSecretKeyEncryption keyfile passfile = do - passphrase <- BL.readFile $ "tests/data/" ++ passfile - kr <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| - CL.consume - gkr <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC..| conduitGet get DC..| - CL.consume - let SecretKey pkp ska = fromPkt . head $ kr - newska = - encryptPrivateKey - "\226~\197\a\202#\"G" - (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") - ska - passphrase - newtruck = toPkt (SecretKey pkp newska) : tail kr - assertEqual "encrypted private key matches golden file" gkr newtruck - -testParsePktsUtil :: FilePath -> Assertion -testParsePktsUtil fn = do - let fpath = "tests/data/" ++ fn - cp <- - DC.runConduitRes $ CB.sourceFile fpath DC..| conduitGet get DC..| CL.consume - pp <- parsePkts `fmap` BL.readFile fpath - assertEqual - "parsePkts utility function gives same results as conduit pipeline" - cp - pp - -testParseTKsUtil :: FilePath -> Assertion -testParseTKsUtil fn = do - let fpath = "tests/data/" ++ fn - lbs <- BL.readFile fpath - cp <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume - let pt = parseTKs True . parsePkts $ lbs - assertEqual - "parsePkts utility function gives same results as conduit pipeline" - cp - pt +import Test.Tasty (TestTree, defaultMain, localOption, testGroup) +import qualified Test.Tasty.QuickCheck as QC +import Test.Tasty.Runners (NumThreads(..)) +import Tests.Encryption (encryptionAndCompressionTests) +import Tests.Keys (keyAndVerificationTests) +import Tests.MessageAndArmor (messageAndArmorTests) +import Tests.Properties (propertiesTests) +import Tests.Serialization (serializationTests) +import Tests.Utilities (utilityTests) tests :: TestTree -tests = testGroup "Tests" [properties, unitTests] +tests = + localOption + (NumThreads 4) + (testGroup + "Tests" + [ localOption (QC.QuickCheckTests 20) propertiesTests + , unitTests + ]) unitTests :: TestTree unitTests = testGroup "Unit Tests" - [ testGroup - "Serialization group" - [ testCase - "000001-006.public_key" - (testSerialization "000001-006.public_key") - , testCase "000002-013.user_id" (testSerialization "000002-013.user_id") - , testCase "000003-002.sig" (testSerialization "000003-002.sig") - , testCase - "000004-012.ring_trust" - (testSerialization "000004-012.ring_trust") - , testCase "000005-002.sig" (testSerialization "000005-002.sig") - , testCase - "000006-012.ring_trust" - (testSerialization "000006-012.ring_trust") - , testCase "000007-002.sig" (testSerialization "000007-002.sig") - , testCase - "000008-012.ring_trust" - (testSerialization "000008-012.ring_trust") - , testCase "000009-002.sig" (testSerialization "000009-002.sig") - , testCase - "000010-012.ring_trust" - (testSerialization "000010-012.ring_trust") - , testCase "000011-002.sig" (testSerialization "000011-002.sig") - , testCase - "000012-012.ring_trust" - (testSerialization "000012-012.ring_trust") - , testCase - "000013-014.public_subkey" - (testSerialization "000013-014.public_subkey") - , testCase "000014-002.sig" (testSerialization "000014-002.sig") - , testCase - "000015-012.ring_trust" - (testSerialization "000015-012.ring_trust") - , testCase - "000016-006.public_key" - (testSerialization "000016-006.public_key") - , testCase "000017-002.sig" (testSerialization "000017-002.sig") - , testCase - "000018-012.ring_trust" - (testSerialization "000018-012.ring_trust") - , testCase "000019-013.user_id" (testSerialization "000019-013.user_id") - , testCase "000020-002.sig" (testSerialization "000020-002.sig") - , testCase - "000021-012.ring_trust" - (testSerialization "000021-012.ring_trust") - , testCase "000022-002.sig" (testSerialization "000022-002.sig") - , testCase - "000023-012.ring_trust" - (testSerialization "000023-012.ring_trust") - , testCase - "000024-014.public_subkey" - (testSerialization "000024-014.public_subkey") - , testCase "000025-002.sig" (testSerialization "000025-002.sig") - , testCase - "000026-012.ring_trust" - (testSerialization "000026-012.ring_trust") - , testCase - "000027-006.public_key" - (testSerialization "000027-006.public_key") - , testCase "000028-002.sig" (testSerialization "000028-002.sig") - , testCase - "000029-012.ring_trust" - (testSerialization "000029-012.ring_trust") - , testCase "000030-013.user_id" (testSerialization "000030-013.user_id") - , testCase "000031-002.sig" (testSerialization "000031-002.sig") - , testCase - "000032-012.ring_trust" - (testSerialization "000032-012.ring_trust") - , testCase "000033-002.sig" (testSerialization "000033-002.sig") - , testCase - "000034-012.ring_trust" - (testSerialization "000034-012.ring_trust") - , testCase - "000035-006.public_key" - (testSerialization "000035-006.public_key") - , testCase "000036-013.user_id" (testSerialization "000036-013.user_id") - , testCase "000037-002.sig" (testSerialization "000037-002.sig") - , testCase - "000038-012.ring_trust" - (testSerialization "000038-012.ring_trust") - , testCase "000039-002.sig" (testSerialization "000039-002.sig") - , testCase - "000040-012.ring_trust" - (testSerialization "000040-012.ring_trust") - , testCase - "000041-017.attribute" - (testSerialization "000041-017.attribute") - , testCase "000042-002.sig" (testSerialization "000042-002.sig") - , testCase - "000043-012.ring_trust" - (testSerialization "000043-012.ring_trust") - , testCase - "000044-014.public_subkey" - (testSerialization "000044-014.public_subkey") - , testCase "000045-002.sig" (testSerialization "000045-002.sig") - , testCase - "000046-012.ring_trust" - (testSerialization "000046-012.ring_trust") - , testCase - "000047-005.secret_key" - (testSerialization "000047-005.secret_key") - , testCase "000048-013.user_id" (testSerialization "000048-013.user_id") - , testCase "000049-002.sig" (testSerialization "000049-002.sig") - , testCase - "000050-012.ring_trust" - (testSerialization "000050-012.ring_trust") - , testCase - "000051-007.secret_subkey" - (testSerialization "000051-007.secret_subkey") - , testCase "000052-002.sig" (testSerialization "000052-002.sig") - , testCase - "000053-012.ring_trust" - (testSerialization "000053-012.ring_trust") - , testCase - "000054-005.secret_key" - (testSerialization "000054-005.secret_key") - , testCase "000055-002.sig" (testSerialization "000055-002.sig") - , testCase - "000056-012.ring_trust" - (testSerialization "000056-012.ring_trust") - , testCase "000057-013.user_id" (testSerialization "000057-013.user_id") - , testCase "000058-002.sig" (testSerialization "000058-002.sig") - , testCase - "000059-012.ring_trust" - (testSerialization "000059-012.ring_trust") - , testCase - "000060-007.secret_subkey" - (testSerialization "000060-007.secret_subkey") - , testCase "000061-002.sig" (testSerialization "000061-002.sig") - , testCase - "000062-012.ring_trust" - (testSerialization "000062-012.ring_trust") - , testCase - "000063-005.secret_key" - (testSerialization "000063-005.secret_key") - , testCase "000064-002.sig" (testSerialization "000064-002.sig") - , testCase - "000065-012.ring_trust" - (testSerialization "000065-012.ring_trust") - , testCase "000066-013.user_id" (testSerialization "000066-013.user_id") - , testCase "000067-002.sig" (testSerialization "000067-002.sig") - , testCase - "000068-012.ring_trust" - (testSerialization "000068-012.ring_trust") - , testCase - "000069-005.secret_key" - (testSerialization "000069-005.secret_key") - , testCase "000070-013.user_id" (testSerialization "000070-013.user_id") - , testCase "000071-002.sig" (testSerialization "000071-002.sig") - , testCase - "000072-012.ring_trust" - (testSerialization "000072-012.ring_trust") - , testCase - "000073-017.attribute" - (testSerialization "000073-017.attribute") - , testCase "000074-002.sig" (testSerialization "000074-002.sig") - , testCase - "000075-012.ring_trust" - (testSerialization "000075-012.ring_trust") - , testCase - "000076-007.secret_subkey" - (testSerialization "000076-007.secret_subkey") - , testCase "000077-002.sig" (testSerialization "000077-002.sig") - , testCase - "000078-012.ring_trust" - (testSerialization "000078-012.ring_trust") - , testCase "pubring.gpg" (testSerialization "pubring.gpg") - , testCase "secring.gpg" (testSerialization "secring.gpg") - , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg") - , testCase - "compressedsig-zlib.gpg" - (testSerialization "compressedsig-zlib.gpg") - , testCase - "compressedsig-bzip2.gpg" - (testSerialization "compressedsig-bzip2.gpg") - , testCase "onepass_sig" (testSerialization "onepass_sig") - , testCase - "uncompressed-ops-dsa.gpg" - (testSerialization "uncompressed-ops-dsa.gpg") - , testCase - "uncompressed-ops-rsa.gpg" - (testSerialization "uncompressed-ops-rsa.gpg") - , testCase "simple.seckey" (testSerialization "simple.seckey") - , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig") - , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes") - , testCase - "gnu-dummy-s2k-101-secret-key.gpg" - (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") - , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg") - , testCase "nist_p-256_key.gpg" (testSerialization "nist_p-256_key.gpg") - , testCase - "nist_p-256_secretkey.gpg" - (testSerialization "nist_p-256_secretkey.gpg") - , testCase - "sample-eddsa.pubkey" - (testSerialization "sample-eddsa.pubkey") - ] - , testGroup - "PKA/Size/KeyID/fingerprint group" - [ testCase - "v3 key" - (testPKAandSizeAndKeyIDandFingerprint - "v3.key" - "R1024:C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") - , testCase - "v4 key" - (testPKAandSizeAndKeyIDandFingerprint - "000001-006.public_key" - "R1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") - , testCase - "ECDSA key" - (testPKAandSizeAndKeyIDandFingerprint - "nist_p-256_key.gpg" - "E256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224") - , testCase - "EdDSA key" - (testPKAandSizeAndKeyIDandFingerprint - "sample-eddsa.pubkey" - "w256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A") - ] - , testGroup - "Keyring group" - [ testCase - "pubring 7732CF988A63EA86" - (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) - , testCase - "pubring 123456789ABCDEF0" - (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False) - , testCase - "pubsub AD992E9C24399832" - (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) - , testCase - "secring 7732CF988A63EA86" - (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) - , testCase - "secring 123456789ABCDEF0" - (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) - , testCase - "secsub AD992E9C24399832" - (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) - -- FIXME: should count keys in rings - ] - , testGroup - "Message verification group" - [ testCase - "uncompressed-ops-dsa" - (testVerifyMessage - "pubring.gpg" - "uncompressed-ops-dsa.gpg" - [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) - , testCase - "uncompressed-ops-dsa-sha384" - (testVerifyMessage - "pubring.gpg" - "uncompressed-ops-dsa-sha384.txt.gpg" - [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) - , testCase - "uncompressed-ops-rsa" - (testVerifyMessage - "pubring.gpg" - "uncompressed-ops-rsa.gpg" - [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"]) - , testCase - "compressedsig" - (testVerifyMessage - "pubring.gpg" - "compressedsig.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "compressedsig-zlib" - (testVerifyMessage - "pubring.gpg" - "compressedsig-zlib.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "compressedsig-bzip2" - (testVerifyMessage - "pubring.gpg" - "compressedsig-bzip2.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - ] - , testGroup - "Certificate verification group" - [ testCase - "userid" - (testVerifyMessage - "pubring.gpg" - "minimized.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "subkey" - (testVerifyMessage - "pubring.gpg" - "subkey.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "primary key binding" - (testVerifyMessage - "signing-subkey.gpg" - "primary-binding.gpg" - [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"]) - , testCase - "attribute" - (testVerifyMessage - "pubring.gpg" - "uat.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "primary key revocation" - (testVerifyMessage - "pubring.gpg" - "prikey-rev.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "subkey revocation" - (testVerifyMessage - "pubring.gpg" - "subkey-rev.gpg" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "6F87040E" - (testVerifyMessage - "pubring.gpg" - "6F87040E.pubkey" - [ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" - , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - ]) - , testCase - "6F87040E-cr" - (testVerifyMessage - "pubring.gpg" - "6F87040E-cr.pubkey" - [ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - , fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" - , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - ]) - , testCase - "simple RSA secret key" - (testVerifyMessage - "pubring.gpg" - "simple.seckey" - [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , testCase - "simple ECDSA public key" - (testVerifyMessage - "ecdsa-key-without-ecdh.pubkey" - "ecdsa-key-without-ecdh.pubkey" - [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"]) - ] - , testGroup - "Key verification group" - [ testCase - "6F87040E pubkey" - (testKeysSelfVerification True "6F87040E.pubkey") - , testCase - "revoked pubkey" - (testKeysSelfVerification False "revoked.pubkey") - , testCase - "expired pubkey" - (testKeysSelfVerification True "expired.pubkey") - , testCase - "nist_p-256 pubkey" - (testKeysSelfVerification True "nist_p-256_key.gpg") - , testCase - "ed25519 pubkey" - (testKeysSelfVerification True "ed25519.pubkey") - ] - , testGroup - "Key expiration group" - [ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey") - , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey") - , testCase - "nist_p-256 pubkey" - (testKeysExpiration True "nist_p-256_key.gpg") - , testCase - "ed25519-without-curve25519.pubkey" - (testKeysExpiration True "ed25519-without-curve25519.pubkey") - , testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey") - ] - , testGroup - "Compression group" - [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg") - , testCase - "compressedsig-zlib.gpg" - (testCompression "compressedsig-zlib.gpg") - , testCase - "compressedsig-bzip2.gpg" - (testCompression "compressedsig-bzip2.gpg") - ] - , testGroup - "Conduit length group" - [ testCase - "conduitCompress (ZIP)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress ZIP) - 1) - , testCase - "conduitCompress (Zlib)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress ZLIB) - 1) - , testCase - "conduitCompress (BZip2)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress BZip2) - 1) - , testCase - "conduitToTKs" - (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToTKs) 4) - , testCase - "conduitToTKsDropping" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitToTKsDropping) - 4) - ] - , testGroup - "Encrypted data" - [ testCase - "Symmetric Encryption simple S2K SHA1 3DES, no MDC" - (testSymmetricEncryption - "encryption-sym-3des-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC" - (testSymmetricEncryption - "encryption-sym-3des.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 3DES" - (testSymmetricEncryption - "encryption-sym-3des-mdc-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 3DES" - (testSymmetricEncryption - "encryption-sym-3des-mdc.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 CAST5, no MDC" - (testSymmetricEncryption - "encryption-sym-cast5-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC" - (testSymmetricEncryption - "encryption-sym-cast5.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 CAST5" - (testSymmetricEncryption - "encryption-sym-cast5-mdc-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 CAST5" - (testSymmetricEncryption - "encryption-sym-cast5-mdc.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC" - (testSymmetricEncryption - "encryption-sym-blowfish-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC" - (testSymmetricEncryption - "encryption-sym-blowfish.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 Blowfish" - (testSymmetricEncryption - "encryption-sym-blowfish-mdc-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 Blowfish" - (testSymmetricEncryption - "encryption-sym-blowfish-mdc.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 AES128" - (testSymmetricEncryption - "encryption-sym-aes128-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 AES128" - (testSymmetricEncryption - "encryption-sym-aes128.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 AES192" - (testSymmetricEncryption - "encryption-sym-aes192-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 AES192" - (testSymmetricEncryption - "encryption-sym-aes192.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 AES256" - (testSymmetricEncryption - "encryption-sym-aes256-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 AES256" - (testSymmetricEncryption - "encryption-sym-aes256.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple S2K SHA1 Twofish" - (testSymmetricEncryption - "encryption-sym-twofish-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted S2K SHA1 Twofish" - (testSymmetricEncryption - "encryption-sym-twofish.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption simple Camellia128" - (testSymmetricEncryption - "encryption-sym-camellia128-s2k0.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted Camellia128" - (testSymmetricEncryption - "encryption-sym-camellia128.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted Camellia192" - (testSymmetricEncryption - "encryption-sym-camellia192.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption iterated-salted Camellia256" - (testSymmetricEncryption - "encryption-sym-camellia256.gpg" - "symmetric-password.txt" - "test\n") - , testCase - "Symmetric Encryption pgcrypto" - (testSymmetricEncryption - "encryption-sym-pgcrypto.pgp" - "pgcrypto-passphrase.txt" - "{\"t\":\"plus\"}") - ] - , testGroup - "Encrypted secret keys" - [ testCase - "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" - (testSecretKeyDecryption "simple.seckey" "pki-password.txt") - , testCase - "SUS16bit CAST5 IteratedSalted SHA1 RSA" - (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") - , testCase - "SUSSHA1 AES256 IteratedSalted SHA512 RSA" - (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") - , testCase - "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA" - (testSecretKeyDecryption - "nist_p-256_secretkey.gpg" - "pki-password.txt") - ] - , testGroup - "Encrypting secret keys" - [ testCase - "SUSSHA1 AES256 IteratedSalted SHA512 RSA" - (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt") - ] - , testGroup - "Utility function group" - [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") - , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") - ] - ] - -properties :: TestTree -properties = testGroup "Properties" [qcProps] - -qcProps :: TestTree -qcProps = - testGroup - "(checked by QuickCheck)" - [ QC.testProperty "PKESK packet serialization-deserialization" $ \pkesk -> - Right (pkesk :: PKESK) == runGet get (runPut (put pkesk)) - , QC.testProperty "Signature packet serialization-deserialization" $ \sig -> - Right (sig :: Signature) == runGet get (runPut (put sig)) - , QC.testProperty "UserId packet serialization-deserialization" $ \uid -> - Right (uid :: UserId) == runGet get (runPut (put uid)) + [ serializationTests + , keyAndVerificationTests + , encryptionAndCompressionTests + , messageAndArmorTests + , utilityTests ] - -cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) () -cgp = conduitGet (get :: Get Pkt) - -fp :: Text -> TwentyOctetFingerprint -fp = either error id . parseFingerprint - -doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion -doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = - assertEqual - "RSA private key matches RSA public key" - rpub - (RSA.private_pub rpriv) -doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) = - assertEqual - "ECDSA private key curve matches ECDSA public key curve" - (ECDSA.public_curve ecpub) - (ECDSA.private_curve ecpriv) -doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" main :: IO () main = defaultMain tests