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

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

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

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

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

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

keyStateAt :: UTCTime -> TK k -> KeyState
keyStateAt ct tk =
    baseState
        { keyStateValid =
            keyStateValid baseState && bindingStateAllowsValidation
        }
  where
    baseState =
        keyStateFromSelfSignaturesAt
            ct
            (keyPktPKPayload (tk ^. tkPrimaryKey))
            relevantSelfSignatures
    relevantSelfSignatures =
        filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs)
            ++ filter
                (isSelfCertificationFor primaryKey)
                (concatMap snd (tk ^. tkUIDs))
            ++ filter
                (isSelfCertificationFor primaryKey)
                (concatMap snd (tk ^. tkUAts))
    selfCertificationGroups =
        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 = keyPktPKPayload (tk ^. tkPrimaryKey)

effectiveKeyPreferencesAt
    :: 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
    :: 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 = keyPktPKPayload (tk ^. tkPrimaryKey)

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

effectiveUIDPreferencesAtTimestamp
    :: 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
    :: UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt ct tk =
    snd
        <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates)
  where
    primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey)
    directKeySigs =
        filter
            ( \sig ->
                isDirectKeySelfSigFor primaryKey sig
                    && signatureEffectiveAt ct sig
            )
            (tk ^. tkRevs)
    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 _ (OtherSigSub subpacketType _)) =
    subpacketType == 39
isPreferenceSubpacket _ = False

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

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

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

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

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

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

getKeyExpirationTimesFromSignature
    :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature sig =
    map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $
        filter isKET (signatureHashedSubpackets sig)
