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
  , 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.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)

conduitToUnknownTKs :: Monad m => ConduitT Pkt TKUnknown m ()
conduitToUnknownTKs =
  conduitToTKsEither .|
  conduitDropErrorsAndNothings

conduitToTKs :: Monad m => ConduitT Pkt SomeTK m ()
conduitToTKs =
  conduitToUnknownTKs .|
  CL.mapMaybe (either (const Nothing) Just . fromUnknownToTK)

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