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

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 -> TKUnknown -> Bool
isTKTimeValid ct = keyStateValid . keyStateAt ct

keyStateAt :: UTCTime -> TKUnknown -> KeyState
keyStateAt ct tk =
  baseState {keyStateValid = keyStateValid baseState && bindingStateAllowsValidation}
  where
    baseState =
      keyStateFromSelfSignaturesAt ct (tk ^. tkuKey . _1) relevantSelfSignatures
    relevantSelfSignatures =
      filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkuRevs) ++
      filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUIDs)) ++
      filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUAts))
    selfCertificationGroups =
      map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUIDs) ++
      map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUAts)
    hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups
    hasAnyActiveSelfCertification =
      any (selfCertificationGroupActiveAt ct) selfCertificationGroups
    bindingStateAllowsValidation =
      not hasAnySelfCertification || hasAnyActiveSelfCertification
    primaryKey = tk ^. tkuKey . _1

effectiveKeyPreferencesAt :: UTCTime -> TKUnknown -> 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 -> TKUnknown -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAt ct uid tk
  | not (keyStateValid (keyStateAt ct tk)) = Nothing
  | otherwise = do
      sigs <- lookup uid (tk ^. tkuUIDs)
      cert <- latestActiveSelfCertificationAt ct (filter (isSelfSignatureFor primaryKey) sigs)
      let prefs = preferencePayloadsFromSignature cert
      if null prefs
        then Nothing
        else Just prefs
  where
    primaryKey = tk ^. tkuKey . _1

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

effectiveUIDPreferencesAtTimestamp ::
     ThirtyTwoBitTimeStamp -> Text -> TKUnknown -> 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 -> TKUnknown -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt ct tk =
  snd <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates)
  where
    primaryKey = tk ^. tkuKey . _1
    directKeySigs =
      filter
        (\sig -> isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig)
        (tk ^. tkuRevs)
    uidSelfCerts =
      mapMaybe
        (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd)
        (tk ^. tkuUIDs)
    uatSelfCerts =
      mapMaybe
        (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd)
        (tk ^. tkuUAts)
    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)