Expirations.hs

-- Expirations.hs: OpenPGP (RFC9580) expiration checking
-- Copyright © 2014-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.Expirations
    ( KeyState (..)
    , keyStateAt
    , effectiveKeyPreferencesAt
    , effectiveUIDPreferencesAt
    , effectiveKeyPreferencesAtTimestamp
    , effectiveUIDPreferencesAtTimestamp
    , isTKTimeValid
    , isPKTimeValidWithSelfSignatures
    , getKeyExpirationTimesFromSignature
    , isCertificationSig
    , signatureCreationTime
    , signatureExpirationTime
    , signatureExpirationDuration
    , firstSignatureExpirationDuration
    , signatureEffectiveAt
    , addDurationToTime
    , newestByCreationTime
    , keyFlagsFromSignature
    , effectiveKeyFlagsAt
    , effectiveSubkeyFlagsAt
    , effectiveFeaturesAt
    ) where

import Control.Error.Util (hush)
import Control.Lens ((&), (^.))
import Data.List (find, maximumBy)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock (UTCTime, addUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Internal (issuer, issuerFP)
import Codec.Encryption.OpenPGP.Ontology (isKET)
import Codec.Encryption.OpenPGP.SignatureQualities
    ( sigCT
    , sigType
    , signatureHashedSubpacketsKnown
    )
import Codec.Encryption.OpenPGP.Types

{- | Type class for extracting PK payload from subkeys.
This is needed because TKKeyPkt k varies by key kind.
-}
class TKSubkeyPKPayload (k :: TKKind) where
    tkSubkeyPKPayload :: TKKeyPkt k -> SomePKPayload

instance TKSubkeyPKPayload 'PublicTK where
    tkSubkeyPKPayload = keyPktPKPayload

instance TKSubkeyPKPayload 'SecretTK where
    tkSubkeyPKPayload = keyPktPKPayload

instance TKSubkeyPKPayload 'MixedTK where
    tkSubkeyPKPayload (SomeKeyPkt kp) = keyPktPKPayload kp

data KeyState
    = KeyState
    { keyStateValid :: Bool
    , keyStateSelfSignaturesKnown :: Bool
    , keyStateHasEffectiveSelfSignature :: Bool
    , keyStateExpirationTime :: Maybe UTCTime
    }
    deriving (Eq, Show)

-- this assumes that all key expiration time subpackets are valid
isTKTimeValid :: TKPrimaryPKPayload k => UTCTime -> TK k -> Bool
isTKTimeValid ct = keyStateValid . keyStateAt ct

keyStateAt :: TKPrimaryPKPayload k => UTCTime -> TK k -> KeyState
keyStateAt ct tk =
    baseState
        { keyStateValid =
            keyStateValid baseState && bindingStateAllowsValidation
        }
  where
    baseState =
        keyStateFromSelfSignaturesAt
            ct
            (tkPrimaryPKPayload tk)
            relevantSelfSignatures
    relevantSelfSignatures =
        concat
            [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkDirectKeySigs)
            , filter
                (isSelfCertificationFor primaryKey)
                (concatMap snd (tk ^. tkUIDs))
            , filter
                (isSelfCertificationFor primaryKey)
                (concatMap snd (tk ^. tkUAts))
            ]
    selfCertificationGroups =
        concat
            [ map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUIDs)
            , map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUAts)
            ]
    hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups
    hasAnyActiveSelfCertification =
        any (selfCertificationGroupActiveAt ct) selfCertificationGroups
    bindingStateAllowsValidation =
        not hasAnySelfCertification || hasAnyActiveSelfCertification
    primaryKey = tkPrimaryPKPayload tk

effectiveKeyPreferencesAt
    :: TKPrimaryPKPayload k
    => UTCTime -> TK k -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAt ct tk
    | not (keyStateValid (keyStateAt ct tk)) = Nothing
    | otherwise = do
        sig <- latestEffectivePreferenceCarrierAt ct tk
        let prefs = preferencePayloadsFromSignature sig
        if null prefs
            then Nothing
            else Just prefs

effectiveUIDPreferencesAt
    :: TKPrimaryPKPayload k
    => UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAt ct uid tk
    | not (keyStateValid (keyStateAt ct tk)) = Nothing
    | otherwise = do
        sigs <- lookup uid (tk ^. tkUIDs)
        cert <-
            latestActiveSelfCertificationAt
                ct
                (filter (isSelfSignatureFor primaryKey) sigs)
        let prefs = preferencePayloadsFromSignature cert
        if null prefs
            then Nothing
            else Just prefs
  where
    primaryKey = tkPrimaryPKPayload tk

effectiveKeyPreferencesAtTimestamp
    :: TKPrimaryPKPayload k
    => ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAtTimestamp ts =
    effectiveKeyPreferencesAt
        (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts)))

effectiveUIDPreferencesAtTimestamp
    :: TKPrimaryPKPayload k
    => ThirtyTwoBitTimeStamp
    -> Text
    -> TK k
    -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAtTimestamp ts uid =
    effectiveUIDPreferencesAt
        (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts)))
        uid

isPKTimeValidWithSelfSignatures
    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool
isPKTimeValidWithSelfSignatures ct pkp sigs =
    keyStateValid (keyStateFromSelfSignaturesAt ct pkp sigs)

keyStateFromSelfSignaturesAt
    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState
keyStateFromSelfSignaturesAt ct pkp sigs =
    KeyState
        { keyStateValid =
            ct >= keyCreationTime
                && selfSignatureStateAllowsValidation
                && maybe True (ct <) keyExpirationTime
        , keyStateSelfSignaturesKnown =
            maybe False (const True) latestKnownSelfSignature
        , keyStateHasEffectiveSelfSignature =
            maybe False (signatureEffectiveAt ct) latestKnownSelfSignature
        , keyStateExpirationTime = keyExpirationTime
        }
  where
    keyCreationTime = _timestamp pkp & posixSecondsToUTCTime . realToFrac
    knownSelfSignatures = filter (signatureCreatedAtOrBefore ct) sigs
    selfSignatureStateAllowsValidation =
        maybe
            (null sigs)
            (signatureEffectiveAt ct)
            latestKnownSelfSignature
    latestKnownSelfSignature =
        snd
            <$> newestByCreationTime
                (mapMaybeSignatureCreationTime knownSelfSignatures)
    keyExpirationTime = effectiveKeyExpirationTime ct pkp sigs

effectiveKeyExpirationTime
    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime
effectiveKeyExpirationTime ct pkp sigs =
    signatureExpirationDurationToUTCTime pkp
        =<< latestKnownExpirationDuration ct sigs

latestKnownExpirationDuration
    :: UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration
latestKnownExpirationDuration ct sigs =
    latestKnownSelfSignatureExpirationDuration ct
        =<< ( snd
                <$> newestByCreationTime
                    ( mapMaybeSignatureCreationTime
                        (filter (signatureCreatedAtOrBefore ct) sigs)
                    )
            )

latestKnownSelfSignatureExpirationDuration
    :: UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration
latestKnownSelfSignatureExpirationDuration ct sig
    | signatureEffectiveAt ct sig =
        listToMaybe (getKeyExpirationTimesFromSignature sig)
    | otherwise = Nothing

signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt ct sig =
    maybe False (<= ct) (signatureCreationTime sig)
        && maybe True (ct <) (signatureExpirationTime sig)

signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore ct sig =
    maybe False (<= ct) (signatureCreationTime sig)

signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime =
    fmap
        (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp)
        . sigCT

signatureExpirationTime :: SignaturePayload -> Maybe UTCTime
signatureExpirationTime sig =
    addDurationToTime
        <$> signatureCreationTime sig
        <*> signatureExpirationDuration sig

signatureExpirationDuration
    :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration sig =
    signatureHashedSubpacketsKnown sig
        >>= firstSignatureExpirationDuration

firstSignatureExpirationDuration
    :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration =
    foldr
        ( \subpacket acc ->
            case subpacket of
                SigSubPacket _ (SigExpirationTime duration) -> Just duration
                _ -> acc
        )
        Nothing

signatureExpirationDurationToUTCTime
    :: SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime
signatureExpirationDurationToUTCTime _ (ThirtyTwoBitDuration 0) = Nothing
signatureExpirationDurationToUTCTime pkp duration =
    Just $
        addDurationToTime
            (_timestamp pkp & posixSecondsToUTCTime . realToFrac)
            duration

addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime baseTime duration =
    addUTCTime
        (fromIntegral (unThirtyTwoBitDuration duration))
        baseTime

newestByCreationTime :: [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime [] = Nothing
newestByCreationTime xs = Just (maximumBy (comparing fst) xs)

mapMaybeSignatureCreationTime
    :: [SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime =
    foldr
        ( \sig acc ->
            case signatureCreationTime sig of
                Just ct -> (ct, sig) : acc
                Nothing -> acc
        )
        []

selfCertificationGroupActiveAt
    :: UTCTime -> [SignaturePayload] -> Bool
selfCertificationGroupActiveAt ct sigs =
    maybe
        False
        (const True)
        (latestActiveSelfCertificationAt ct sigs)

latestActiveSelfCertificationAt
    :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt ct sigs =
    case latestKnownSelfCertification of
        Nothing -> Nothing
        Just certification ->
            if signatureEffectiveAt ct certification
                && not
                    ( any
                        (\revocation -> revokesCertificationAt ct revocation certification)
                        certRevocations
                    )
                then Just certification
                else Nothing
  where
    latestKnownSelfCertification =
        snd
            <$> newestByCreationTime
                (mapMaybeSignatureCreationTime knownCertifications)
    knownCertifications =
        filter
            ( \sig -> isCertificationSig sig && signatureCreatedAtOrBefore ct sig
            )
            sigs
    certRevocations =
        filter (\sig -> isCertRevocationForTime ct sig) sigs

latestEffectivePreferenceCarrierAt
    :: TKPrimaryPKPayload k => UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt ct tk =
    snd
        <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates)
  where
    primaryKey = tkPrimaryPKPayload tk
    directKeySigs =
        filter
            ( \sig ->
                isDirectKeySelfSigFor primaryKey sig
                    && signatureEffectiveAt ct sig
            )
            (tk ^. tkDirectKeySigs)
    uidSelfCerts =
        mapMaybe
            ( latestActiveSelfCertificationAt ct
                . filter (isSelfSignatureFor primaryKey)
                . snd
            )
            (tk ^. tkUIDs)
    uatSelfCerts =
        mapMaybe
            ( latestActiveSelfCertificationAt ct
                . filter (isSelfSignatureFor primaryKey)
                . snd
            )
            (tk ^. tkUAts)
    candidates = directKeySigs ++ uidSelfCerts ++ uatSelfCerts

preferencePayloadsFromSignature
    :: SignaturePayload -> [SigSubPacketPayload]
preferencePayloadsFromSignature =
    map
        (\(SigSubPacket _ payload) -> payload)
        . filter isPreferenceSubpacket
        . signatureHashedSubpackets

signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets sig =
    maybe [] id (signatureHashedSubpacketsKnown sig)

isPreferenceSubpacket :: SigSubPacket -> Bool
isPreferenceSubpacket (SigSubPacket _ (PreferredSymmetricAlgorithms _)) = True
isPreferenceSubpacket (SigSubPacket _ (PreferredHashAlgorithms _)) = True
isPreferenceSubpacket (SigSubPacket _ (PreferredCompressionAlgorithms _)) = True
isPreferenceSubpacket (SigSubPacket _ (KeyServerPreferences _)) = True
isPreferenceSubpacket (SigSubPacket _ (PreferredKeyServer _)) = True
isPreferenceSubpacket (SigSubPacket _ (Features _)) = True
isPreferenceSubpacket (SigSubPacket _ (PreferredAEADCiphersuites _)) = True
isPreferenceSubpacket (SigSubPacket _ (OtherSigSub subpacketType _)) =
    subpacketType == 39
isPreferenceSubpacket _ = False

revokesCertificationAt
    :: UTCTime -> SignaturePayload -> SignaturePayload -> Bool
revokesCertificationAt ct revocation certification =
    signatureEffectiveAt ct revocation
        && case ( signatureCreationTime certification
                , signatureCreationTime revocation
                ) of
            (Just certificationTime, Just revocationTime) -> certificationTime < revocationTime
            _ -> False

isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool
isCertRevocationForTime ct sig =
    sigType sig == Just CertRevocationSig
        && signatureCreatedAtOrBefore ct sig

isCertificationSig :: SignaturePayload -> Bool
isCertificationSig sig =
    sigType sig
        `elem` [ Just GenericCert
               , Just PersonaCert
               , Just CasualCert
               , Just PositiveCert
               ]

isDirectKeySelfSigFor
    :: SomePKPayload -> SignaturePayload -> Bool
isDirectKeySelfSigFor pkp sig =
    sigType sig == Just DirectKeySignature
        && isSelfSignatureFor pkp sig

isSelfCertificationFor
    :: SomePKPayload -> SignaturePayload -> Bool
isSelfCertificationFor pkp sig =
    isCertificationSig sig && isSelfSignatureFor pkp sig

isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor pkp sig =
    ( ((== fingerprint pkp) <$> issuerFP (SignaturePkt sig))
        == Just True
    )
        || ( ((==) <$> issuer (SignaturePkt sig) <*> hush (eightOctetKeyID pkp))
                == Just True
           )

getKeyExpirationTimesFromSignature
    :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature sig =
    mapMaybe
        ( \(SigSubPacket _ payload) ->
            case payload of
                KeyExpirationTime x -> Just x
                _ -> Nothing
        )
        (signatureHashedSubpackets sig)

-- | Extract KeyFlags from a single signature's hashed subpackets.
keyFlagsFromSignature :: SignaturePayload -> Maybe (Set KeyFlag)
keyFlagsFromSignature sig =
    case signatureHashedSubpacketsKnown sig of
        Nothing -> Nothing
        Just subpackets ->
            foldr
                ( \(SigSubPacket _ payload) acc ->
                    case payload of
                        KeyFlags flags -> Just (maybe flags (Set.union flags) acc)
                        _ -> acc
                )
                Nothing
                subpackets

{- | Get effective key flags for the primary key at a given timestamp.
Finds the latest effective self-signature (direct key sig, UID self-cert, or UAT self-cert)
and extracts KeyFlags from its hashed subpackets.
Returns Nothing if no effective self-signature exists or if no KeyFlags subpacket is present.
-}
effectiveKeyFlagsAt
    :: TKPrimaryPKPayload k
    => UTCTime -> TK k -> Maybe (Set KeyFlag)
effectiveKeyFlagsAt ct tk = do
    sig <- latestEffectivePreferenceCarrierAt ct tk
    keyFlagsFromSignature sig

{- | Get effective key flags for a subkey at a given timestamp.
Finds the subkey by fingerprint, then finds the latest effective
subkey binding signature and extracts KeyFlags from its hashed subpackets.
-}
effectiveSubkeyFlagsAt
    :: forall k
     . (TKPrimaryPKPayload k, TKSubkeyPKPayload k)
    => UTCTime -> TK k -> Fingerprint -> Maybe (Set KeyFlag)
effectiveSubkeyFlagsAt ct tk fp = do
    (_, bindingSigs) <-
        find
            (\(kp, _) -> fingerprint (tkSubkeyPKPayload @k kp) == fp)
            (tk ^. tkSubs)
    bindingSig <-
        latestEffectiveSubkeyBindingSignatureAt ct bindingSigs
    keyFlagsFromSignature bindingSig

{- | Get effective features for the primary key at a given timestamp.
Finds the latest effective self-signature and extracts Features from its hashed subpackets.
-}
effectiveFeaturesAt
    :: TKPrimaryPKPayload k
    => UTCTime -> TK k -> Maybe (Set FeatureFlag)
effectiveFeaturesAt ct tk = do
    sig <- latestEffectivePreferenceCarrierAt ct tk
    featuresFromSignature sig

-- | Extract Features from a single signature's hashed subpackets.
featuresFromSignature
    :: SignaturePayload -> Maybe (Set FeatureFlag)
featuresFromSignature sig =
    case signatureHashedSubpacketsKnown sig of
        Nothing -> Nothing
        Just subpackets ->
            foldr
                ( \(SigSubPacket _ payload) acc ->
                    case payload of
                        Features flags -> Just (maybe flags (Set.union flags) acc)
                        _ -> acc
                )
                Nothing
                subpackets

{- | Find the latest effective subkey binding signature at a given timestamp.
This is similar to the function in Encrypt.hs but uses UTCTime instead of ThirtyTwoBitTimeStamp.
-}
latestEffectiveSubkeyBindingSignatureAt
    :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignatureAt ct sigs =
    case filter (isEffectiveSubkeyBindingSignatureAt ct) sigs of
        [] -> Nothing
        candidates ->
            Just
                (maximumBy (comparing signatureCreationTimeOrZero) candidates)

-- | Check if a signature is an effective subkey binding signature at the given time.
isEffectiveSubkeyBindingSignatureAt
    :: UTCTime -> SignaturePayload -> Bool
isEffectiveSubkeyBindingSignatureAt ct sig =
    isSubkeyBindingSig sig
        && maybe
            False
            ( \created ->
                created <= ct
                    && maybe
                        True
                        ( \duration ->
                            if unThirtyTwoBitDuration duration == 0
                                then True
                                else
                                    ct
                                        < addUTCTime
                                            (fromIntegral (unThirtyTwoBitDuration duration))
                                            created
                        )
                        (signatureExpirationDuration sig)
            )
            (signatureCreationTime sig)

-- | Check if a signature is a subkey binding signature.
isSubkeyBindingSig :: SignaturePayload -> Bool
isSubkeyBindingSig sig = sigType sig == Just SubkeyBindingSig

-- | Get signature creation time or zero if not present.
signatureCreationTimeOrZero :: SignaturePayload -> UTCTime
signatureCreationTimeOrZero sig =
    fromMaybe (posixSecondsToUTCTime 0) (signatureCreationTime sig)