Keyring.hs

-- 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
  ( conduitToUnknownTKs
  , TypedTKConduitError(..)
  , conduitToSomeTKsEither
  , conduitToSomeTKsDropping
  , conduitToSomeTKsDroppingEither
  , conduitToTKs
  , conduitToPublicTKs
  , conduitToPublicViewTKs
  , conduitToSecretTKs
  , AuthSecretSubkeyUID(..)
  , AuthSecretSubkeyAtTime(..)
  , AuthSecretSubkeyRejectionReason(..)
  , AuthSecretSubkeyRejectedAtTime(..)
  , AuthSecretSubkeysAtReport(..)
  , authSecretSubkeysAt
  , authSecretSubkeysAtReport
  , conduitToAuthSecretSubkeysAt
  , conduitToAuthSecretSubkeysAtReport
  , conduitToTKsDropping
  , 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.Bifunctor (first)
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
  ( KeyringChunkParseError(..)
  , anyTK
  , anyTKWithWireRep
  , finalizeParsingEither
  , parseAChunkEither
  )
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 ()

data Phase
  = MainKey
  | Revs
  | Uids
  | UAts
  | Subs
  | 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 . 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 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 someTKToPublicViewTK
{-# DEPRECATED conduitToPublicViewTKs "Use conduitToSomeTKsEither and perform explicit projection." #-}

conduitToSecretTKs :: Monad m => ConduitT Pkt (TK 'SecretTK) m ()
conduitToSecretTKs =
  conduitToTKs .|
  CL.mapMaybe someTKToSecretTK
{-# DEPRECATED conduitToSecretTKs "Use conduitToSomeTKsEither and perform explicit projection/filtering." #-}

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
  => 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

-- | 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 ()
conduitToTKsDroppingEither = conduitToTKsEither' False

conduitToTKsWithWireRep :: Monad m => ConduitT PktWithWireRep TKWithWireRep m ()
conduitToTKsWithWireRep =
  conduitToTKsWithWireRepEither .|
  conduitDropErrorsAndNothings
{-# DEPRECATED conduitToTKsWithWireRep "Use conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-}

conduitToTKsWithWireRepEither ::
     Monad m
  => ConduitT
      PktWithWireRep
      (Either KeyringChunkParseError (Maybe TKWithWireRep))
      m
      ()
conduitToTKsWithWireRepEither = conduitToTKsWithWireRepEither' True

conduitToTKsDroppingWithWireRep ::
     Monad m => ConduitT PktWithWireRep TKWithWireRep m ()
conduitToTKsDroppingWithWireRep =
  conduitToTKsDroppingWithWireRepEither .|
  conduitDropErrorsAndNothings
{-# DEPRECATED conduitToTKsDroppingWithWireRep "Use conduitToTKsDroppingWithWireRepEither or conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-}

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 (Either e b) m ()
fakecmAccumEither finalizer f initialAccum = loop initialAccum
  where
    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'

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 (: []) .|
  fakecmAccumEither
    finalizeParsingEither
    (parseAChunkEither (anyTK intolerant))
    ([], Just (Nothing, anyTK intolerant))
  where
    notTrustPacket = not . isTrustPkt

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)