hOpenPGP-3.2: Codec/Encryption/OpenPGP/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
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)