diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -26,9 +26,15 @@ , recipientEncryptionTargetsReportFromTKAtTimestamp , recipientEncryptionTargetsReportFromTK , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetFromTKAtTimestampWithPolicy , recipientEncryptionTargetsFromTKAtTimestamp , recipientEncryptionTargetFromTK + , recipientEncryptionTargetFromTKWithPolicy , recipientEncryptionTargetsFromTK + , RecipientTargetSelectionPolicy(..) + , PassphraseSKESKVersionPolicy(..) + , PassphraseEncryptRequest(..) + , encryptPassphraseWithPolicy , PKESKVersionPolicy(..) , RecipientPKESKVersionStrategy(..) , RecipientPKESKVersionStrategyW(..) @@ -113,6 +119,7 @@ , messageSEIPDv2SymmetricAlgorithms , messageDefaultAEADAlgorithm , messageDefaultChunkSize + , messageSEIPDv2SaltOctets , defaultPKESKVersionPolicy ) import Codec.Encryption.OpenPGP.Expirations @@ -129,10 +136,11 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (encryptWithOCBRFC7253) +import Control.Applicative ((<|>)) import Control.Lens ((.~), ix) import Control.Monad (when) import Data.List (find, foldl', maximumBy) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Ord (comparing) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -365,16 +373,49 @@ -> TKUnknown -> Either RecipientCapabilityError RecipientEncryptionTarget recipientEncryptionTargetFromTKAtTimestamp timestamp tk = - case recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) of - (target:_) -> Right target - [] -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK + recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionFirstValid + timestamp + tk +data RecipientTargetSelectionPolicy + = RecipientTargetSelectionFirstValid + | RecipientTargetSelectionPreferPrimary + | RecipientTargetSelectionPreferSubkey + | RecipientTargetSelectionPreferNewestCreationTime + deriving (Eq, Show) + +recipientEncryptionTargetFromTKAtTimestampWithPolicy :: + RecipientTargetSelectionPolicy + -> ThirtyTwoBitTimeStamp + -> TKUnknown + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk = + case chooseRecipientTarget policy tk acceptedTargets of + Just target -> Right target + Nothing -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK + where + acceptedTargets = + recipientEncryptionTargetsAccepted + (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) + recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget recipientEncryptionTargetFromTK tk = - recipientEncryptionTargetFromTKAtTimestamp + recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionFirstValid (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) (tkToUnknown tk) +recipientEncryptionTargetFromTKWithPolicy :: + RecipientTargetSelectionPolicy + -> TK 'PublicTK + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKWithPolicy policy tk = + recipientEncryptionTargetFromTKAtTimestampWithPolicy + policy + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + recipientEncryptionTargetsFromTKAtTimestamp :: ThirtyTwoBitTimeStamp -> TKUnknown @@ -583,6 +624,36 @@ X448 -> True _ -> False +chooseRecipientTarget :: + RecipientTargetSelectionPolicy + -> TKUnknown + -> [RecipientEncryptionTarget] + -> Maybe RecipientEncryptionTarget +chooseRecipientTarget policy tk targets = + case policy of + RecipientTargetSelectionFirstValid -> listToMaybe targets + RecipientTargetSelectionPreferPrimary -> + listToMaybe (filter (isPrimaryTarget tk) targets) <|> listToMaybe targets + RecipientTargetSelectionPreferSubkey -> + listToMaybe (filter (not . isPrimaryTarget tk) targets) <|> listToMaybe targets + RecipientTargetSelectionPreferNewestCreationTime -> + case targets of + [] -> Nothing + (target:rest) -> + Just + (foldl' + (\best candidate -> + if _timestamp (recipientEncryptionTargetKey candidate) > + _timestamp (recipientEncryptionTargetKey best) + then candidate + else best) + target + rest) + where + isPrimaryTarget currentTK target = + fingerprint (recipientEncryptionTargetKey target) == + fingerprint (fst (_tkuKey currentTK)) + -- | Session-key bundle for PKESK/SKESK packet construction. newtype PKESKV3SessionMaterial = PKESKV3SessionMaterial @@ -793,6 +864,63 @@ } deriving (Eq, Show) +data PassphraseSKESKVersionPolicy + = PassphraseSKESKPreferV6 + | PassphraseSKESKForceV4Interop + deriving (Eq, Show) + +data PassphraseEncryptRequest = + PassphraseEncryptRequest + { passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy + , passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm + , passphraseEncryptS2K :: S2K + , passphraseEncryptPassphrase :: BL.ByteString + , passphraseEncryptPayload :: B.ByteString + , passphraseEncryptSEIPDv1IVOverride :: Maybe IV + , passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm + , passphraseEncryptSEIPDv2ChunkSizeOverride :: Maybe Word8 + , passphraseEncryptSEIPDv2SaltOverride :: Maybe Salt + } + deriving (Eq, Show) + +encryptPassphraseWithPolicy :: + MonadRandom m + => PassphraseEncryptRequest + -> m (Either String [Pkt]) +encryptPassphraseWithPolicy request = + case passphraseEncryptVersionPolicy request of + PassphraseSKESKForceV4Interop -> + encryptSEIPDv1WithSKESK + (passphraseEncryptSymmetricAlgorithm request) + (passphraseEncryptS2K request) + (passphraseEncryptSEIPDv1IVOverride request) + (passphraseEncryptPassphrase request) + (passphraseEncryptPayload request) + PassphraseSKESKPreferV6 -> do + let messagePolicy = policyMessageEncryption (policyForRFC RFC9580) + aead = + fromMaybe + (messageDefaultAEADAlgorithm messagePolicy) + (passphraseEncryptSEIPDv2AEADOverride request) + chunkSize = + fromMaybe + (messageDefaultChunkSize messagePolicy) + (passphraseEncryptSEIPDv2ChunkSizeOverride request) + salt <- + maybe + (Salt <$> getRandomBytes (messageSEIPDv2SaltOctets messagePolicy)) + pure + (passphraseEncryptSEIPDv2SaltOverride request) + pure $ + encryptSEIPDv2WithSKESK + (passphraseEncryptSymmetricAlgorithm request) + aead + chunkSize + salt + (passphraseEncryptS2K request) + (passphraseEncryptPassphrase request) + (passphraseEncryptPayload request) + defaultRecipientPayloadShape :: RecipientPayloadShape defaultRecipientPayloadShape = RecipientPayloadShape @@ -2052,6 +2180,46 @@ xorBS :: B.ByteString -> B.ByteString -> B.ByteString xorBS a b = B.pack (B.zipWith xor a b) + +encryptSEIPDv1WithSKESK :: + MonadRandom m + => SymmetricAlgorithm + -> S2K + -> Maybe IV + -> BL.ByteString + -> B.ByteString + -> m (Either String [Pkt]) +encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do + let eSessionKey = do + keyLen <- symKeySize symalgo + first renderS2KError (string2Key s2k keyLen passphrase) + case eSessionKey of + Left err -> pure (Left err) + Right sessionKeyMaterial -> + case + first + renderCipherError + (withSymmetricCipher symalgo sessionKeyMaterial (pure . blockSize)) of + Left err -> pure (Left err) + Right ivLength -> do + ivBytes <- + maybe + (getRandomBytes ivLength) + (pure . unIV) + ivOverride + let iv = IV ivBytes + let sessionKey = SessionKey sessionKeyMaterial + case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of + Left err -> pure (Left err) + Right encrypted -> + pure + (Right + [ SKESKPkt + (SKESKPayloadV4Packet + (SKESKPayloadV4 symalgo s2k Nothing)) + , SymEncIntegrityProtectedDataPkt + (SEIPD1 1 (BL.fromStrict encrypted)) + ]) encryptSEIPDv2WithSKESK :: SymmetricAlgorithm 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 @@ -47,13 +47,15 @@ , brokenWithWireRep -- * Utilities , parseUnknownTKs - , parseTKs - , parsePublicTKs - , parseSecretTKs - , parseTKsWithWireRep - ) where + , parseTKsEither + , parseTKs + , parsePublicTKs + , parseSecretTKs + , parseTKsWithWireRep + ) where import Control.Applicative ((<|>), many) +import Data.Either (rights) import Data.List (foldl') import Data.Maybe (catMaybes, mapMaybe) import qualified Data.List.NonEmpty as NE @@ -375,25 +377,20 @@ where notTrustPacket = not . isTrustPkt +parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK] +parseTKsEither intolerant = + map fromUnknownToTKEither . parseUnknownTKs intolerant + parseTKs :: Bool -> [Pkt] -> [SomeTK] -parseTKs intolerant = - mapMaybe (either (const Nothing) Just . fromUnknownToTK) . parseUnknownTKs intolerant +parseTKs intolerant packets = rights (parseTKsEither intolerant packets) parsePublicTKs :: Bool -> [Pkt] -> [TK 'PublicTK] parsePublicTKs intolerant packets = - mapMaybe - (\case - SomePublicTK tk -> Just tk - SomeSecretTK _ -> Nothing) - (parseTKs intolerant packets) + mapMaybe someTKToPublicTK (parseTKs intolerant packets) parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK] parseSecretTKs intolerant packets = - mapMaybe - (\case - SomeSecretTK tk -> Just tk - SomePublicTK _ -> Nothing) - (parseTKs intolerant packets) + mapMaybe someTKToSecretTK (parseTKs intolerant packets) anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True 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 @@ -9,6 +9,8 @@ module Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey + , reinterpretUnknownSKeyForPKPayload + , mkUnencryptedSKAddendum , encryptPrivateKeyWithPolicyAndSaltAndIV , encryptPrivateKey , changePrivateKeyPassphrase @@ -111,6 +113,31 @@ pure (SKAUnencryptedV6 sk) decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska + +reinterpretUnknownSKeyForPKPayload :: SomePKPayload -> SKey -> Either String SKey +reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk +reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) = + case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) payload of + Left (_, _, err) -> Left err + Right (_, _, (skey, trailing)) + | BL.null trailing -> Right skey + | otherwise -> Left "decoded secret key material has trailing bytes" + +mkUnencryptedSKAddendum :: SomePKPayload -> SKey -> Either String SKAddendum +mkUnencryptedSKAddendum pkp skey = do + payload <- legacySecretKeyPayload pkp skey + let checksum = + case _keyVersion pkp of + V6 -> 0 + _ -> checksum16 (BL.toStrict payload) + pure (SUUnencrypted skey checksum) decryptS2KProtectedPayload :: SomePKPayload 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 @@ -18,6 +18,12 @@ , putSKeyForPKPayload -- * Utilities , dearmorIfAsciiArmored + , dearmorIfAsciiArmoredLenient + , looksLikeAsciiArmor + , armorPayloadsOfType + , singleArmorPayloadOfType + , singleClearSignedBlock + , recommendedArmorType , WireRepInput(..) , wireRepRefFromInput , PktParseError(..) @@ -95,7 +101,7 @@ 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 Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) 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 @@ -2767,19 +2773,130 @@ , pktParseErrorMessage = msg } -armorPayload :: Armor -> ByteString -armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs) -armorPayload (ClearSigned _ _ inner) = armorPayload inner +armorPayloads :: [Armor] -> [ByteString] +armorPayloads = + foldr collect [] + where + collect (Armor _ _ payload) = (BL.fromStrict (BLC8.toStrict payload) :) + collect (ClearSigned _ _ inner) = (armorPayloads [inner] ++) +looksLikeAsciiArmor :: ByteString -> Bool +looksLikeAsciiArmor = + (armorHeaderLazy `BL.isPrefixOf`) . BL.dropWhile isLeadingArmorWhitespace + +looksLikeAsciiArmorLenient :: ByteString -> Bool +looksLikeAsciiArmorLenient = looksLikeAsciiArmor . stripUtf8Bom + +armorPayloadsOfType :: ArmorType -> [Armor] -> [ByteString] +armorPayloadsOfType atype = + foldr collect [] + where + collect (Armor innerType _ payload) + | innerType == atype = (BL.fromStrict (BLC8.toStrict payload) :) + | otherwise = id + collect (ClearSigned _ _ inner) = (armorPayloadsOfType atype [inner] ++) + +singleArmorPayloadOfType :: ArmorType -> [Armor] -> Either String ByteString +singleArmorPayloadOfType atype armors = + case armorPayloadsOfType atype armors of + [payload] -> Right payload + [] -> Left ("ASCII armor decode returned no " ++ show atype ++ " blocks") + payloads -> + Left + ("ASCII armor decode returned " ++ + show (length payloads) ++ " " ++ show atype ++ " blocks (expected exactly one)") + +singleClearSignedBlock :: + [Armor] -> Either String ([(String, String)], ByteString, ByteString) +singleClearSignedBlock armors = + case [clearSignedBlockFromArmor armor | armor@ClearSigned {} <- armors] of + [Right clearSigned] -> Right clearSigned + [Left err] -> Left err + [] -> Left "ASCII armor decode returned no clear-signed blocks" + clearSigneds -> + Left + ("ASCII armor decode returned " ++ + show (length clearSigneds) ++ " clear-signed blocks (expected exactly one)") + where + clearSignedBlockFromArmor (ClearSigned hs cleartext inner) = + case inner of + Armor ArmorSignature _ sig -> + Right + ( hs + , BL.fromStrict (BLC8.toStrict cleartext) + , BL.fromStrict (BLC8.toStrict sig) + ) + Armor atype _ _ -> + Left + ("clear-signed block contained inner armor type " ++ + show atype ++ " (expected ArmorSignature)") + ClearSigned {} -> + Left "clear-signed block contained nested clear-signed payload" + clearSignedBlockFromArmor _ = + Left "internal error: expected ClearSigned armor block" + +recommendedArmorType :: [Pkt] -> Maybe ArmorType +recommendedArmorType [] = Nothing +recommendedArmorType (pkt:_) + | isPrivateKeyPacket pkt = Just ArmorPrivateKeyBlock + | isPublicKeyPacket pkt = Just ArmorPublicKeyBlock + | isSignaturePacket pkt = Just ArmorSignature + | otherwise = Just ArmorMessage + where + isPrivateKeyPacket SecretKeyPkt {} = True + isPrivateKeyPacket SecretSubkeyPkt {} = True + isPrivateKeyPacket _ = False + + isPublicKeyPacket PublicKeyPkt {} = True + isPublicKeyPacket PublicSubkeyPkt {} = True + isPublicKeyPacket _ = False + + isSignaturePacket SignaturePkt {} = True + isSignaturePacket _ = False + 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) + | looksLikeAsciiArmor bs = + (\payload -> (True, payload)) <$> decodeSingleArmorPayload bs | otherwise = Right (False, bs) +dearmorIfAsciiArmoredLenient :: ByteString -> Either String (Bool, ByteString) +dearmorIfAsciiArmoredLenient bs + | looksLikeAsciiArmorLenient bs = + (\payload -> (True, payload)) <$> decodeSingleArmorPayloadLenient (stripUtf8Bom bs) + | otherwise = Right (False, bs) + +decodeSingleArmorPayload :: ByteString -> Either String ByteString +decodeSingleArmorPayload bs = + case AA.decodeLazy bs of + Left err -> Left err + Right armors -> singleArmorPayload armors + +decodeSingleArmorPayloadLenient :: ByteString -> Either String ByteString +decodeSingleArmorPayloadLenient bs = + case decodeSingleArmorPayload bs of + Right payload -> Right payload + Left strictErr -> + let normalized = normalizeAsciiArmorForLenientDecode bs + in if normalized == bs + then Left strictErr + else case decodeSingleArmorPayload normalized of + Left lenientErr -> + Left + (strictErr ++ + " (lenient normalization retry failed: " ++ lenientErr ++ ")") + Right payload -> Right payload + +singleArmorPayload :: [Armor] -> Either String ByteString +singleArmorPayload armors = + case armorPayloads armors of + [payload] -> Right payload + [] -> Left "ASCII armor decode succeeded but returned no blocks" + payloads -> + Left + ("ASCII armor decode returned " ++ + show (length payloads) ++ " blocks (expected exactly one)") + data WireRepInput = WireRepInput { wireRepInputRef :: WireRepRef @@ -2885,19 +3002,13 @@ (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 + in case wireRepRefFromInput mname input of + Left _ -> [] + Right WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = payload + } -> + parsePktsWithWireRep src payload finishConduitState mname (BinaryInput state) = finalizeBinaryParseState mname state initialBinaryParseState :: BinaryParseState @@ -2943,9 +3054,40 @@ | armorHeader `B.isPrefixOf` rest -> PrefixIsArmored | rest `B.isPrefixOf` armorHeader -> PrefixNeedsMore | otherwise -> PrefixIsBinary + +armorHeader :: B.ByteString +armorHeader = B.pack (map (fromIntegral . fromEnum) "-----BEGIN PGP ") + +armorHeaderLazy :: ByteString +armorHeaderLazy = BL.fromStrict armorHeader + +utf8Bom :: ByteString +utf8Bom = BL.pack [0xef, 0xbb, 0xbf] + +isLeadingArmorWhitespace :: Word8 -> Bool +isLeadingArmorWhitespace w = w == 0x20 || w == 0x09 || w == 0x0d || w == 0x0a + +stripUtf8Bom :: ByteString -> ByteString +stripUtf8Bom bs + | utf8Bom `BL.isPrefixOf` bs = BL.drop (fromIntegral (BL.length utf8Bom)) bs + | otherwise = bs + +normalizeAsciiArmorForLenientDecode :: ByteString -> ByteString +normalizeAsciiArmorForLenientDecode = + ensureTrailingLf . normalizeLineEndings where - armorHeader = BLC8.toStrict (BLC8.pack "-----BEGIN PGP ") - isLeadingArmorWhitespace w = w `elem` map (fromIntegral . fromEnum) (" \t\r\n" :: String) + ensureTrailingLf lbs + | BL.null lbs = lbs + | BL.last lbs == 0x0a = lbs + | otherwise = lbs <> BL.singleton 0x0a + normalizeLineEndings lbs = + case BL.uncons lbs of + Nothing -> BL.empty + Just (0x0d, rest) -> + case BL.uncons rest of + Just (0x0a, rest') -> BL.cons 0x0a (normalizeLineEndings rest') + _ -> BL.cons 0x0a (normalizeLineEndings rest) + Just (w, rest) -> BL.cons w (normalizeLineEndings rest) data ParsedPacketChunk = ParsedPacketChunk 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 @@ -23,6 +23,7 @@ import Codec.Encryption.OpenPGP.Types.Internal.Pkt import Control.Arrow ((&&&)) +import Data.Bifunctor (first) import Control.Lens (makeLenses) import qualified Data.Aeson.TH as ATH import qualified Data.ByteString.Lazy as BL @@ -35,6 +36,7 @@ import Data.Ord (comparing) import Data.Text (Text) import Data.Typeable (Typeable) +import Data.Word (Word8) -- | Zipper for navigating a list of packets with position context data PacketZipper = @@ -111,6 +113,21 @@ instance Eq SomeTK where left == right = someTKToUnknown left == someTKToUnknown right +data TKConversionError + = PublicSubkeyHasPrimaryRole + | SecretSubkeyHasPrimaryRole + | ExpectedPublicSubkeyPacket Word8 + | ExpectedSecretSubkeyPacket Word8 + deriving (Eq, Show) + +renderTKConversionError :: TKConversionError -> String +renderTKConversionError PublicSubkeyHasPrimaryRole = "public subkey has primary-key role" +renderTKConversionError SecretSubkeyHasPrimaryRole = "secret subkey has primary-key role" +renderTKConversionError (ExpectedPublicSubkeyPacket tagValue) = + "expected public subkey, got packet tag " ++ show tagValue +renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) = + "expected secret subkey, got packet tag " ++ show tagValue + tkToUnknown :: TK k -> TKUnknown tkToUnknown tk = TKUnknown @@ -125,6 +142,36 @@ someTKToUnknown (SomePublicTK tk) = tkToUnknown tk someTKToUnknown (SomeSecretTK tk) = tkToUnknown tk +mkTKUnknown :: SomePKPayload -> Maybe SKAddendum -> TKUnknown +mkTKUnknown pkp maybeSka = + TKUnknown + { _tkuKey = (pkp, maybeSka) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [] + } + +fromPrimaryKeyPktToTKUnknown :: Pkt -> Either String TKUnknown +fromPrimaryKeyPktToTKUnknown (PublicKeyPkt pkp) = + Right (mkTKUnknown pkp Nothing) +fromPrimaryKeyPktToTKUnknown (SecretKeyPkt pkp ska) = + Right (mkTKUnknown pkp (Just ska)) +fromPrimaryKeyPktToTKUnknown pkt = + Left ("expected primary key packet, got packet tag " ++ show (pktTag pkt)) + +someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) +someTKToPublicTK (SomePublicTK tk) = Just tk +someTKToPublicTK (SomeSecretTK _) = Nothing + +someTKToSecretTK :: SomeTK -> Maybe (TK 'SecretTK) +someTKToSecretTK (SomeSecretTK tk) = Just tk +someTKToSecretTK (SomePublicTK _) = Nothing + +someTKToPublicViewTK :: SomeTK -> TK 'PublicTK +someTKToPublicViewTK (SomePublicTK tk) = tk +someTKToPublicViewTK (SomeSecretTK tk) = publicViewTK tk + publicViewTK :: TK 'SecretTK -> TK 'PublicTK publicViewTK tk = TK @@ -135,8 +182,8 @@ , _tkSubs = map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk) } -fromUnknownToTK :: TKUnknown -> Either String SomeTK -fromUnknownToTK tk = +fromUnknownToTKEither :: TKUnknown -> Either TKConversionError SomeTK +fromUnknownToTKEither tk = case _tkuKey tk of (pkp, Nothing) -> do subs <- traverse liftPublicSubkey (_tkuSubs tk) @@ -167,30 +214,33 @@ where liftPublicSubkey :: (Pkt, [SignaturePayload]) - -> Either String (KeyPkt 'PublicPkt, [SignaturePayload]) + -> Either TKConversionError (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" + Left PublicSubkeyHasPrimaryRole Nothing -> - Left ("expected public subkey, got packet tag " ++ show (pktTag pkt)) + Left (ExpectedPublicSubkeyPacket (pktTag pkt)) liftSecretSubkey :: (Pkt, [SignaturePayload]) - -> Either String (KeyPkt 'SecretPkt, [SignaturePayload]) + -> Either TKConversionError (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" + Left SecretSubkeyHasPrimaryRole Nothing -> - Left ("expected secret subkey, got packet tag " ++ show (pktTag pkt)) + Left (ExpectedSecretSubkeyPacket (pktTag pkt)) +fromUnknownToTK :: TKUnknown -> Either String SomeTK +fromUnknownToTK = first renderTKConversionError . fromUnknownToTKEither + data TKWithWireRep = TKWithWireRep { _tkWireRepRefs :: WireRepRefs @@ -593,4 +643,3 @@ $(makeLenses ''UATWithWireRefs) $(makeLenses ''SubkeyWithWireRefs) $(makeLenses ''TKStructuredWithWireRep) - 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 @@ -8,6 +8,10 @@ module Data.Conduit.OpenPGP.Keyring ( conduitToUnknownTKs + , TypedTKConduitError(..) + , conduitToSomeTKsEither + , conduitToSomeTKsDropping + , conduitToSomeTKsDroppingEither , conduitToTKs , conduitToPublicTKs , conduitToPublicViewTKs @@ -38,6 +42,7 @@ import Data.Conduit import qualified Data.Conduit.List as CL +import Data.Bifunctor (first) import Data.List (find) import Data.Maybe (maybeToList) import qualified Data.Set as Set @@ -81,44 +86,80 @@ | SkippingBroken deriving (Eq, Ord, Show) +data TypedTKConduitError + = TypedTKParseError KeyringChunkParseError + | TypedTKConversionError TKConversionError + deriving (Eq, Show) + +-- | Deprecated: this conduit silently drops parse failures and parse-time +-- omissions. Prefer 'conduitToTKsEither' and handle errors explicitly. conduitToUnknownTKs :: Monad m => ConduitT Pkt TKUnknown m () conduitToUnknownTKs = conduitToTKsEither .| conduitDropErrorsAndNothings +{-# DEPRECATED conduitToUnknownTKs "Use conduitToTKsEither and handle Left/Maybe explicitly." #-} +-- | Canonical strict typed conduit with explicit parse+conversion error channel. +conduitToSomeTKsEither :: + Monad m => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () +conduitToSomeTKsEither = + conduitToTKsEither .| + CL.map toTypedSomeTKEither + +-- | Deprecated: this conduit silently drops parse+conversion failures. +-- Prefer 'conduitToSomeTKsEither' and handle errors explicitly. +conduitToSomeTKsDropping :: Monad m => ConduitT Pkt SomeTK m () +conduitToSomeTKsDropping = + conduitToSomeTKsDroppingEither .| + conduitDropErrorsAndNothings +{-# DEPRECATED conduitToSomeTKsDropping "Use conduitToSomeTKsEither and handle Left/Maybe explicitly." #-} + +-- | Tolerant typed conduit (broken transferable-key chunks may be omitted), +-- while still surfacing parse+conversion failures. +conduitToSomeTKsDroppingEither :: + Monad m => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () +conduitToSomeTKsDroppingEither = + conduitToTKsDroppingEither .| + CL.map toTypedSomeTKEither + +-- | Deprecated: this conduit silently drops parse+conversion failures. +-- Prefer 'conduitToSomeTKsEither' and handle errors explicitly. conduitToTKs :: Monad m => ConduitT Pkt SomeTK m () conduitToTKs = conduitToUnknownTKs .| - CL.mapMaybe (either (const Nothing) Just . fromUnknownToTK) + CL.mapMaybe (either (const Nothing) Just . fromUnknownToTKEither) +{-# DEPRECATED conduitToTKs "Use conduitToSomeTKsEither and handle Left/Maybe explicitly." #-} +toTypedSomeTKEither :: + Either KeyringChunkParseError (Maybe TKUnknown) + -> Either TypedTKConduitError (Maybe SomeTK) +toTypedSomeTKEither = + either + (Left . TypedTKParseError) + (\maybeUnknown -> + case maybeUnknown of + Nothing -> Right Nothing + Just unknown -> first TypedTKConversionError (Just <$> fromUnknownToTKEither unknown)) + conduitToPublicTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m () conduitToPublicTKs = conduitToTKs .| - CL.mapMaybe - (\stk -> - case stk of - SomePublicTK tk -> Just tk - SomeSecretTK _ -> Nothing) + CL.mapMaybe someTKToPublicTK +{-# DEPRECATED conduitToPublicTKs "Use conduitToSomeTKsEither and perform explicit projection/filtering." #-} -- | 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) + CL.map someTKToPublicViewTK +{-# DEPRECATED conduitToPublicViewTKs "Use conduitToSomeTKsEither and perform explicit projection." #-} conduitToSecretTKs :: Monad m => ConduitT Pkt (TK 'SecretTK) m () conduitToSecretTKs = conduitToTKs .| - CL.mapMaybe - (\stk -> - case stk of - SomeSecretTK tk -> Just tk - SomePublicTK _ -> Nothing) + CL.mapMaybe someTKToSecretTK +{-# DEPRECATED conduitToSecretTKs "Use conduitToSomeTKsEither and perform explicit projection/filtering." #-} data AuthSecretSubkeyUID = AuthSecretSubkeyUID @@ -345,10 +386,14 @@ Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () conduitToTKsEither = conduitToTKsEither' True +-- | Deprecated: this conduit silently drops parse failures and parse-time +-- omissions. Prefer 'conduitToTKsDroppingEither' when tolerant parsing is +-- needed, or 'conduitToTKsEither' for strict parsing. conduitToTKsDropping :: Monad m => ConduitT Pkt TKUnknown m () conduitToTKsDropping = conduitToTKsDroppingEither .| conduitDropErrorsAndNothings +{-# DEPRECATED conduitToTKsDropping "Use conduitToTKsDroppingEither or conduitToTKsEither and handle Left/Maybe explicitly." #-} conduitToTKsDroppingEither :: Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () @@ -358,6 +403,7 @@ conduitToTKsWithWireRep = conduitToTKsWithWireRepEither .| conduitDropErrorsAndNothings +{-# DEPRECATED conduitToTKsWithWireRep "Use conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-} conduitToTKsWithWireRepEither :: Monad m @@ -373,6 +419,7 @@ conduitToTKsDroppingWithWireRep = conduitToTKsDroppingWithWireRepEither .| conduitDropErrorsAndNothings +{-# DEPRECATED conduitToTKsDroppingWithWireRep "Use conduitToTKsDroppingWithWireRepEither or conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-} conduitToTKsDroppingWithWireRepEither :: Monad m diff --git a/bench/mark.hs b/bench/mark.hs --- a/bench/mark.hs +++ b/bench/mark.hs @@ -20,17 +20,21 @@ , verifyTKWith , verifyUnknownTKWith ) -import Codec.Encryption.OpenPGP.Types (wireRepRef) +import Codec.Encryption.OpenPGP.Types + ( someTKToPublicViewTK + , wireRepRef + ) import Data.Binary (get) import Data.Conduit.OpenPGP.Keyring - ( conduitToPublicViewTKs - , conduitToUnknownTKs - , sinkPublicKeyringMap + ( conduitToSomeTKsEither + , conduitToTKsEither ) import Data.Conduit.Serialization.Binary (conduitGet) import qualified Data.IxSet.Typed as IxSet import qualified Data.ByteString.Lazy as BL +import Data.Either (rights) +import Data.Maybe (catMaybes) import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB @@ -73,12 +77,17 @@ ] where loadKeys fp = - DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToUnknownTKs DC..| CL.consume + fmap + catMaybes + (DC.runConduitRes $ + CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKsEither DC..| + CL.consume) loadKeyring fp = - DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToPublicViewTKs DC..| - sinkPublicKeyringMap + fmap + (sinkFromSomeTKs . rights) + (DC.runConduitRes $ + CB.sourceFile fp DC..| conduitGet get DC..| conduitToSomeTKsEither DC..| + CL.consume) selfVerifyKeys fp = fmap (\ks -> @@ -91,3 +100,7 @@ (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) (IxSet.toList kr)) (loadKeyring fp) + sinkFromSomeTKs = + IxSet.fromList . + map someTKToPublicViewTK . + catMaybes diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.0.0 +Version: 3.0.1 Synopsis: native Haskell implementation of OpenPGP (RFC9580) Description: native Haskell implementation of OpenPGP (RFC9580), with some backwards compatibility Homepage: https://salsa.debian.org/clint/hOpenPGP @@ -331,4 +331,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.0.0 + tag: v3.0.1 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -708,7 +708,7 @@ mkTestKeyring :: [TKUnknown] -> PublicKeyring mkTestKeyring tks = - let someTKs = [stk | Right stk <- map fromUnknownToTK tks] + let someTKs = [stk | Right stk <- map fromUnknownToTKEither tks] in fst (partitionSomeTKs someTKs) addTimestampSeconds :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp @@ -1535,5 +1535,4 @@ 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 --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -17,11 +17,14 @@ ( PKESKEncryptError(InvalidRecipientIdentifier, InvalidRecipientKeyMaterial, PayloadBuildFailure, RecipientCapabilitySelectionFailure, RecipientKdfFailure, UnsupportedRecipientAlgorithm) , RecipientCapabilityError(RecipientCapabilityMissingSEIPDv1Support, RecipientCapabilityNoCommonAEADAlgorithms, RecipientCapabilityNoCommonSymmetricAlgorithms, RecipientCapabilityNoEncryptableKeyMaterialInTK) , RecipientCapabilityNegotiationMode(..) + , PassphraseSKESKVersionPolicy(..) + , PassphraseEncryptRequest(..) , EncryptCompatibilityProfile(..) , RecipientCapabilities(..) , RecipientEncryptionTargetRejected(..) , RecipientEncryptionTargetsReport(..) , RecipientTargetRejectionReason(..) + , RecipientTargetSelectionPolicy(..) , RecipientPKESKVersionStrategy(..) , RecipientEncryptionTarget(..) , RecipientPayloadShape(..) @@ -39,8 +42,10 @@ , encryptForRecipients , encryptForRecipientsLegacy , encryptForRecipientsWithCapabilityNegotiation + , encryptPassphraseWithPolicy , recipientCapabilitiesFromSubpacketPayloads , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetFromTKAtTimestampWithPolicy , recipientEncryptionTargetsFromTKAtTimestamp , recipientEncryptionTargetsReportFromTKAtTimestamp , recipientEncryptionTargetFromTK @@ -117,7 +122,10 @@ ) import qualified Data.Conduit.OpenPGP.Decrypt as DCD import Data.Conduit.OpenPGP.Keyring - ( conduitToTKsDropping + ( conduitToSomeTKsDropping + , conduitToSomeTKsDroppingEither + , conduitToSomeTKsEither + , conduitToTKsDropping , conduitToTKsDroppingEither , conduitToTKsEither , conduitToUnknownTKs @@ -295,11 +303,23 @@ (cgp DC..| conduitToTKsDropping) 4) , testCase + "conduitToSomeTKsDropping" + (testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitToSomeTKsDropping) + 4) + , testCase "conduitToTKsEither reports parse failures" testConduitToTKsEitherReportsParseFailure , testCase + "conduitToSomeTKsEither reports parse failures" + testConduitToSomeTKsEitherReportsParseFailure + , testCase "conduitToTKsDroppingEither reports parse failures" testConduitToTKsDroppingEitherReportsParseFailure + , testCase + "conduitToSomeTKsDroppingEither reports parse failures" + testConduitToSomeTKsDroppingEitherReportsParseFailure ] , testGroup "Encrypted data" @@ -555,6 +575,12 @@ "recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp" testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering , testCase + "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer primary key" + testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary + , testCase + "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer newest key" + testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest + , testCase "recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags" testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags , testCase @@ -635,6 +661,12 @@ , testCase "v4 SKESK Argon2 encrypted ESK rejects legacy checksum trailer" testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum + , testCase + "passphrase SKESK policy ForceV4Interop emits SKESKv4 + SEIPDv1" + testEncryptPassphraseWithPolicyForceV4Interop + , testCase + "passphrase SKESK policy PreferV6 emits SKESKv6 + SEIPDv2" + testEncryptPassphraseWithPolicyPreferV6 , testCase "Argon2 S2K derivation vector" testArgon2S2KVector , testCase "Argon2 S2K Ord instance is total" testArgon2S2KOrdTotal ] @@ -691,6 +723,26 @@ "conduitToTKsDroppingEither should report parse failures for non-key packet streams" (any (either (const True) (const False)) results) +testConduitToSomeTKsEitherReportsParseFailure :: Assertion +testConduitToSomeTKsEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| + conduitGet get DC..| conduitToSomeTKsEither DC..| CL.consume + assertBool + "conduitToSomeTKsEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +testConduitToSomeTKsDroppingEitherReportsParseFailure :: Assertion +testConduitToSomeTKsDroppingEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| + conduitGet get DC..| conduitToSomeTKsDroppingEither DC..| CL.consume + assertBool + "conduitToSomeTKsDroppingEither 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. @@ -2579,6 +2631,66 @@ Set.empty (recipientCapabilityKeyFlags caps) +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary = 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 [EncryptCommunicationsKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + case recipientEncryptionTargetFromTKAtTimestampWithPolicy RecipientTargetSelectionPreferPrimary signatureTime tk of + Left err -> + assertFailure ("Expected policy-based recipient selection to succeed, got " ++ show err) + Right target -> + assertEqual + "prefer-primary policy should select primary key when both primary and subkey are valid" + (fingerprint primary) + (fingerprint (recipientEncryptionTargetKey target)) + +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000002) baseKey + 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 recipientEncryptionTargetFromTKAtTimestampWithPolicy RecipientTargetSelectionPreferNewestCreationTime signatureTime tk of + Left err -> + assertFailure ("Expected policy-based recipient selection to succeed, got " ++ show err) + Right target -> + assertEqual + "prefer-newest policy should select newest valid key" + (fingerprint subkey) + (fingerprint (recipientEncryptionTargetKey target)) + testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags :: Assertion testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags = do (baseKey, signingKey) <- loadUnencryptedRsaSigner @@ -4881,6 +4993,54 @@ renderS2KError err) Right _ -> assertFailure "expected SKESK v4 trailing-checksum rejection, but decode succeeded" + +testEncryptPassphraseWithPolicyForceV4Interop :: Assertion +testEncryptPassphraseWithPolicyForceV4Interop = do + let request = + PassphraseEncryptRequest + { passphraseEncryptVersionPolicy = PassphraseSKESKForceV4Interop + , passphraseEncryptSymmetricAlgorithm = AES128 + , passphraseEncryptS2K = Simple SHA256 + , passphraseEncryptPassphrase = "password" + , passphraseEncryptPayload = "hello" + , passphraseEncryptSEIPDv1IVOverride = Just (IV (B.replicate 16 0x22)) + , passphraseEncryptSEIPDv2AEADOverride = Nothing + , passphraseEncryptSEIPDv2ChunkSizeOverride = Nothing + , passphraseEncryptSEIPDv2SaltOverride = Nothing + } + result <- encryptPassphraseWithPolicy request + case result of + Left err -> + assertFailure ("Expected passphrase SKESK force-v4 encryption to succeed, got: " ++ err) + Right (SKESKPkt (SKESKPayloadV4Packet _):SymEncIntegrityProtectedDataPkt (SEIPD1 _ _):_) -> + pure () + Right packets -> + assertFailure + ("Expected SKESKv4 + SEIPDv1 packet sequence, got: " ++ show packets) + +testEncryptPassphraseWithPolicyPreferV6 :: Assertion +testEncryptPassphraseWithPolicyPreferV6 = do + let request = + PassphraseEncryptRequest + { passphraseEncryptVersionPolicy = PassphraseSKESKPreferV6 + , passphraseEncryptSymmetricAlgorithm = AES128 + , passphraseEncryptS2K = Simple SHA256 + , passphraseEncryptPassphrase = "password" + , passphraseEncryptPayload = "hello" + , passphraseEncryptSEIPDv1IVOverride = Nothing + , passphraseEncryptSEIPDv2AEADOverride = Just OCB + , passphraseEncryptSEIPDv2ChunkSizeOverride = Just 6 + , passphraseEncryptSEIPDv2SaltOverride = Just (Salt (B.replicate 32 0x44)) + } + result <- encryptPassphraseWithPolicy request + case result of + Left err -> + assertFailure ("Expected passphrase SKESK prefer-v6 encryption to succeed, got: " ++ err) + Right (SKESKPkt (SKESKPayloadV6Packet _):SymEncIntegrityProtectedDataPkt (SEIPD2 _ _ _ _ _):_) -> + pure () + Right packets -> + assertFailure + ("Expected SKESKv6 + SEIPDv2 packet sequence, got: " ++ show packets) testArgon2S2KVector :: Assertion testArgon2S2KVector = do diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -35,10 +35,13 @@ import Codec.Encryption.OpenPGP.SecretKey ( changePrivateKeyPassphrase , decryptPrivateKey + , mkUnencryptedSKAddendum + , reinterpretUnknownSKeyForPKPayload ) import Codec.Encryption.OpenPGP.Serialize ( getSecretKey , parsePkts + , putSKeyForPKPayload ) import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) import Codec.Encryption.OpenPGP.Signatures @@ -96,6 +99,7 @@ , loadDeterministicEd25519Signer , loadKeyring , loadUnencryptedRsaSigner + , loadUnencryptedRsaSignerV6 , messageVerificationFixtures , mkTestKeyring , readFixturePayload @@ -272,6 +276,18 @@ , testCase "v4 Ed448 secret-key roundtrip preserves leading zero byte" testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte + , testCase + "mkUnencryptedSKAddendum computes legacy secret-key checksum" + testMkUnencryptedSKAddendumComputesLegacyChecksum + , testCase + "mkUnencryptedSKAddendum sets v6 unencrypted checksum to zero" + testMkUnencryptedSKAddendumUsesV6ChecksumConvention + , testCase + "reinterpretUnknownSKeyForPKPayload decodes EdDSA unknown key material" + testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA + , testCase + "fromPrimaryKeyPktToTKUnknown rejects subkey packets" + testFromPrimaryKeyPktToTKUnknownRejectsSubkey , testCase "policy signature context validation (RFC9580)" testPolicySignatureContextValidation , testCase "temporary validity uses latest effective self-signature window" @@ -1675,3 +1691,82 @@ (EdDSAPrivateKey Ed448 secretBytes) parsedSecret +testMkUnencryptedSKAddendumComputesLegacyChecksum :: Assertion +testMkUnencryptedSKAddendumComputesLegacyChecksum = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume + case packets of + (SecretKeyPkt pkp (SUUnencrypted sk _):_) -> + case mkUnencryptedSKAddendum pkp sk of + Left err -> + assertFailure ("mkUnencryptedSKAddendum should succeed for fixture key: " ++ err) + Right (SUUnencrypted _ actualChecksum) -> do + skPayload <- + case putSKeyForPKPayload pkp sk of + Left err -> + assertFailure ("failed to serialize secret key payload for checksum expectation: " ++ err) >> + fail "expected serializable secret key payload" + Right payload -> pure payload + let expectedChecksum = + fromIntegral + (BL.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) + 0 + (runPut skPayload) :: Integer) + assertEqual + "mkUnencryptedSKAddendum should use OpenPGP 16-bit checksum over serialized key material" + expectedChecksum + actualChecksum + Right other -> + assertFailure ("unexpected addendum constructor: " ++ show other) + _ -> + assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" + +testMkUnencryptedSKAddendumUsesV6ChecksumConvention :: Assertion +testMkUnencryptedSKAddendumUsesV6ChecksumConvention = do + (pkp, rsaPrivateKey) <- loadUnencryptedRsaSignerV6 + case mkUnencryptedSKAddendum pkp (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) of + Left err -> + assertFailure ("mkUnencryptedSKAddendum should support v6 key payloads: " ++ err) + Right (SUUnencrypted _ checksum) -> + assertEqual "v6 unencrypted addendum checksum should be zero" 0 checksum + Right other -> + assertFailure ("unexpected addendum constructor: " ++ show other) + +testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA :: Assertion +testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA = do + let secretBytes = B.pack (0 : replicate 31 1) + pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) + unknown = UnknownSKey (runPut (put (MPI (os2ip secretBytes)))) + case reinterpretUnknownSKeyForPKPayload pkp unknown of + Left err -> + assertFailure ("reinterpretUnknownSKeyForPKPayload should decode Ed25519 key: " ++ err) + Right skey -> + assertEqual + "reinterpretUnknownSKeyForPKPayload should return typed EdDSA secret key" + (EdDSAPrivateKey Ed25519 secretBytes) + skey + +testFromPrimaryKeyPktToTKUnknownRejectsSubkey :: Assertion +testFromPrimaryKeyPktToTKUnknownRejectsSubkey = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume + case packets of + (SecretKeyPkt pkp _ : _) -> + case fromPrimaryKeyPktToTKUnknown (PublicSubkeyPkt pkp) of + Left err -> + assertBool + "fromPrimaryKeyPktToTKUnknown should report non-primary packet tags" + ("expected primary key packet" `isInfixOf` err) + Right _ -> + assertFailure "fromPrimaryKeyPktToTKUnknown should reject subkey packets" + _ -> + assertFailure "unencrypted.seckey did not begin with a secret key packet" diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -19,7 +19,14 @@ 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.Serialize + ( armorPayloadsOfType + , parsePkts + , parsePktsEither + , recommendedArmorType + , singleClearSignedBlock + , singleArmorPayloadOfType + ) import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig, payloadForSigWith) import Codec.Encryption.OpenPGP.Signatures ( renderSignError @@ -64,7 +71,7 @@ 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.Either (isLeft, isRight) import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE import Test.Tasty (TestTree, testGroup) @@ -167,6 +174,15 @@ "typed signature payload coercions" testSignatureDataKindsCoercions , testCase + "typed armor payload helpers centralize block selection" + testTypedArmorPayloadHelpers + , testCase + "recommendedArmorType infers canonical armor labels from packets" + testRecommendedArmorType + , testCase + "singleClearSignedBlock validates cleartext signature envelopes" + testSingleClearSignedBlock + , testCase "canonical text signature payload normalization" testCanonicalTextSigPayloadNormalization , testCase @@ -1560,6 +1576,86 @@ "fromPktEitherSomeSignatureV rejects non-signature packets" (not (isRight (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 "")))) +testTypedArmorPayloadHelpers :: Assertion +testTypedArmorPayloadHelpers = do + let armors = + [ Armor ArmorPublicKeyBlock [] "public-one" + , Armor ArmorMessage [] "message-one" + , Armor ArmorPublicKeyBlock [] "public-two" + ] + publicPayloads = map BL.toStrict (armorPayloadsOfType ArmorPublicKeyBlock armors) + assertEqual + "armorPayloadsOfType returns all matching typed blocks in order" + ["public-one", "public-two"] + publicPayloads + assertEqual + "singleArmorPayloadOfType returns the sole matching message payload" + (Right "message-one") + (fmap BL.toStrict (singleArmorPayloadOfType ArmorMessage armors)) + assertBool + "singleArmorPayloadOfType fails when no typed blocks exist" + (isLeft (singleArmorPayloadOfType ArmorPrivateKeyBlock armors)) + assertBool + "singleArmorPayloadOfType fails when multiple typed blocks exist" + (isLeft (singleArmorPayloadOfType ArmorPublicKeyBlock armors)) +testRecommendedArmorType :: Assertion +testRecommendedArmorType = do + secretArmors <- loadArmor "v4-encrypted-secret.pgp.aa" + publicArmors <- loadArmor "v4-encrypted.rev.aa" + secretPayload <- + case singleArmorPayloadOfType ArmorPrivateKeyBlock secretArmors of + Left err -> assertFailure err >> fail err + Right payload -> pure payload + publicPayload <- + case singleArmorPayloadOfType ArmorPublicKeyBlock publicArmors of + Left err -> assertFailure err >> fail err + Right payload -> pure payload + let secretPkts = parsePkts secretPayload + publicPkts = parsePkts publicPayload + firstPkt label pkts = + case pkts of + [] -> assertFailure (label ++ " should contain at least one packet") >> fail "missing packet" + pkt:_ -> pure pkt + firstSecret <- firstPkt "secret armor fixture" secretPkts + firstPublic <- firstPkt "public armor fixture" publicPkts + let sig = SignaturePkt (SigV4 BinarySig RSA SHA256 [] [] 0 (NE.fromList [MPI 1])) + assertEqual "recommendedArmorType rejects empty packet streams" Nothing (recommendedArmorType []) + assertEqual + "recommendedArmorType maps secret-key packets to private key armor" + (Just ArmorPrivateKeyBlock) + (recommendedArmorType [firstSecret]) + assertEqual + "recommendedArmorType maps public-key packets to public key armor" + (Just ArmorPublicKeyBlock) + (recommendedArmorType [firstPublic]) + assertEqual + "recommendedArmorType maps signature packets to signature armor" + (Just ArmorSignature) + (recommendedArmorType [sig]) + assertEqual + "recommendedArmorType defaults non-key/signature packets to message armor" + (Just ArmorMessage) + (recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"]) +testSingleClearSignedBlock :: Assertion +testSingleClearSignedBlock = do + let clearSigned = + ClearSigned + [("Hash", "SHA256")] + "signed cleartext payload\n" + (Armor ArmorSignature [("Version", "test-suite")] "detached-signature") + assertEqual + "singleClearSignedBlock extracts cleartext and signature payloads" + (Right ([("Hash", "SHA256")], "signed cleartext payload\n", "detached-signature")) + (singleClearSignedBlock [clearSigned]) + assertBool + "singleClearSignedBlock rejects absent clear-signed blocks" + (isLeft (singleClearSignedBlock [Armor ArmorMessage [] "payload"])) + assertBool + "singleClearSignedBlock rejects multiple clear-signed blocks" + (isLeft (singleClearSignedBlock [clearSigned, clearSigned])) + assertBool + "singleClearSignedBlock rejects non-signature inner armor blocks" + (isLeft (singleClearSignedBlock [ClearSigned [] "payload" (Armor ArmorMessage [] "not-signature")])) testSignerTimelineSoftPrimaryRevocation :: Assertion testSignerTimelineSoftPrimaryRevocation = do (signer, signingKey) <- loadUnencryptedRsaSigner @@ -1843,5 +1939,3 @@ ("Ed25519 SigV4 verification with Ed25519 key algorithm failed: " ++ renderVerificationError err) Right _ -> pure () - - diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -7,12 +7,12 @@ 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 + , parseTKsEither , parseTKs , parseTKsWithWireRep , parseUnknownTKs @@ -21,6 +21,9 @@ ( PktParseError(..) , WireRepInput(..) , conduitParsePktsWithWireRep + , dearmorIfAsciiArmored + , dearmorIfAsciiArmoredLenient + , looksLikeAsciiArmor , parsePkts , parsePktsEither , parsePktsWithWireRep @@ -45,8 +48,10 @@ , authSecretSubkeyRejectedReason , authSecretSubkeyUIDs , authSecretSubkeyValue + , conduitToSomeTKsDroppingEither , conduitToAuthSecretSubkeysAt , conduitToAuthSecretSubkeysAtReport + , conduitToSomeTKsEither , conduitToPublicTKs , conduitToSecretTKs , conduitToTKs @@ -54,14 +59,15 @@ , conduitToUnknownTKs ) import Data.Conduit.Serialization.Binary (conduitGet) -import Data.List (nub, sortOn) +import Data.Either (lefts, rights) +import Data.List (isInfixOf, nub, sortOn) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (catMaybes) 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 @@ -101,9 +107,18 @@ "pubring as typed TKs" (testParseTKsTypedUtil "pubring.gpg") , testCase + "pubring parseTKsEither preserves typed parse outcomes" + (testParseTKsEitherUtil "pubring.gpg") + , testCase "typed TKUnknown conduit partitioning" (testConduitToTKsTypedUtil "pubring.gpg") , testCase + "typed TK conduit either reports values without silent drops on valid input" + (testConduitToSomeTKsEitherUtil "pubring.gpg") + , testCase + "typed TK dropping conduit either preserves valid typed results" + (testConduitToSomeTKsDroppingEitherUtil "pubring.gpg") + , testCase "auth-capable secret-subkey conduit filters revoked/expired/auth flags" testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth , testCase @@ -131,6 +146,18 @@ "wire provenance tracks original ASCII armor" testWireRepRefTracksArmorProvenance , testCase + "dearmorIfAsciiArmored rejects multi-block armored inputs" + testDearmorRejectsMultipleBlocks + , testCase + "dearmorIfAsciiArmoredLenient accepts BOM-prefixed armor" + testDearmorLenientAcceptsBomPrefixedArmor + , testCase + "looksLikeAsciiArmor centralizes armor prefix detection" + testLooksLikeAsciiArmor + , testCase + "wireRepRefFromInput surfaces malformed armored decode errors" + testWireRepRefRejectsMalformedArmoredInput + , testCase "tksFromWireRep matches any source in TKUnknown provenance list" testTksFromWireRepMatchesAnySource , testCase @@ -240,6 +267,20 @@ (length typed) (length typedPublic + length typedSecret) +testParseTKsEitherUtil :: FilePath -> Assertion +testParseTKsEitherUtil fn = do + lbs <- readFixtureLazy fn + let packets = parsePkts lbs + typed = parseTKs True packets + typedEither = parseTKsEither True packets + assertEqual + "parseTKsEither right results should match parseTKs" + typed + (rights typedEither) + assertBool + "parseTKsEither should have no conversion failures for canonical pubring fixture" + (null (lefts typedEither)) + testConduitToTKsTypedUtil :: FilePath -> Assertion testConduitToTKsTypedUtil fn = do lbs <- readFixtureLazy fn @@ -261,6 +302,36 @@ (length allTyped) (length publicTyped + length secretTyped) +testConduitToSomeTKsEitherUtil :: FilePath -> Assertion +testConduitToSomeTKsEitherUtil fn = do + lbs <- readFixtureLazy fn + results <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSomeTKsEither DC..| CL.consume + let typedFromEither = catMaybes (rights results) + assertBool + "conduitToSomeTKsEither should not report failures for canonical pubring fixture" + (null (lefts results)) + assertEqual + "conduitToSomeTKsEither right values should match conduitToTKs semantics" + (parseTKs True (parsePkts lbs)) + typedFromEither + +testConduitToSomeTKsDroppingEitherUtil :: FilePath -> Assertion +testConduitToSomeTKsDroppingEitherUtil fn = do + lbs <- readFixtureLazy fn + results <- + DC.runConduitRes $ + CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSomeTKsDroppingEither DC..| CL.consume + let typedFromEither = catMaybes (rights results) + assertBool + "conduitToSomeTKsDroppingEither should not report failures for canonical pubring fixture" + (null (lefts results)) + assertEqual + "conduitToSomeTKsDroppingEither right values should match tolerant parseTKs semantics" + (parseTKs False (parsePkts lbs)) + typedFromEither + testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth :: Assertion testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth = do (signer, signingKey) <- loadUnencryptedRsaSigner @@ -963,6 +1034,62 @@ "dearmored payload should parse into packets" (not (null (parsePktsWithWireRep src payload))) +testDearmorRejectsMultipleBlocks :: Assertion +testDearmorRejectsMultipleBlocks = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + case dearmorIfAsciiArmored (armored <> "\n" <> armored) of + Left err -> + assertBool + "multi-block rejection error should mention expected single block" + ("expected exactly one" `isInfixOf` err) + Right _ -> + assertFailure "dearmorIfAsciiArmored unexpectedly accepted multi-block armor input" + +testDearmorLenientAcceptsBomPrefixedArmor :: Assertion +testDearmorLenientAcceptsBomPrefixedArmor = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + let bomPrefixed = BL.pack [0xef, 0xbb, 0xbf] <> armored + case dearmorIfAsciiArmored bomPrefixed of + Right (False, _) -> pure () + Right (True, _) -> + assertFailure + "strict dearmorIfAsciiArmored unexpectedly treated BOM-prefixed input as armored" + Left err -> + assertFailure ("strict dearmorIfAsciiArmored failed unexpectedly: " ++ err) + case dearmorIfAsciiArmoredLenient bomPrefixed of + Left err -> + assertFailure ("lenient dearmor should decode BOM-prefixed armor: " ++ err) + Right (wasArmored, payload) -> do + assertBool "lenient dearmor should report armored input" wasArmored + assertBool "lenient dearmor payload should parse as packets" (not (null (parsePkts payload))) + +testLooksLikeAsciiArmor :: Assertion +testLooksLikeAsciiArmor = do + let armoredPrefix = "\n\t -----BEGIN PGP MESSAGE-----\nYWJj\n" + partialPrefix = "-----BEGIN PG" + binaryPrefix = BL.pack [0x99, 0x01, 0x02, 0x03] + assertBool + "looksLikeAsciiArmor accepts canonical armored headers with leading whitespace" + (looksLikeAsciiArmor armoredPrefix) + assertBool + "looksLikeAsciiArmor rejects partial armored headers" + (not (looksLikeAsciiArmor partialPrefix)) + assertBool + "looksLikeAsciiArmor rejects binary packet prefixes" + (not (looksLikeAsciiArmor binaryPrefix)) + +testWireRepRefRejectsMalformedArmoredInput :: Assertion +testWireRepRefRejectsMalformedArmoredInput = do + let malformed = + "-----BEGIN PGP MESSAGE-----\n" <> + "not base64 and no checksum\n" <> + "-----END PGP MESSAGE-----\n" + case wireRepRefFromInput Nothing malformed of + Left _ -> pure () + Right _ -> + assertFailure + "wireRepRefFromInput unexpectedly accepted malformed ASCII-armored input" + testTksFromWireRepMatchesAnySource :: Assertion testTksFromWireRepMatchesAnySource = do lbs <- readFixtureLazy "pubring.gpg" @@ -1111,16 +1238,12 @@ armored <- readFixtureLazy "v6-secret.pgp.aa" secretTk <- do - armors <- - case AA.decodeLazy armored of + payload <- + case dearmorIfAsciiArmored 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 + Right (_, bs) -> pure bs + case parseUnknownTKs True (parsePkts payload) of (tk:_) -> pure tk [] -> assertFailure "v6-secret.pgp.aa should parse to at least one TKUnknown" >> fail "unreachable" secretTyped <- @@ -1230,5 +1353,3 @@ other -> assertFailure ("Expected one TKUnknown with a retained v6 revocation signature, got " ++ show other) - -