-- 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 :: TKKeyPkt 'PublicTK -> SomePKPayload
tkSubkeyPKPayload = KeyPkt 'PublicPkt -> SomePKPayload
TKKeyPkt 'PublicTK -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload

instance TKSubkeyPKPayload 'SecretTK where
    tkSubkeyPKPayload :: TKKeyPkt 'SecretTK -> SomePKPayload
tkSubkeyPKPayload = KeyPkt 'SecretPkt -> SomePKPayload
TKKeyPkt 'SecretTK -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload

instance TKSubkeyPKPayload 'MixedTK where
    tkSubkeyPKPayload :: TKKeyPkt 'MixedTK -> SomePKPayload
tkSubkeyPKPayload (SomeKeyPkt KeyPkt k
kp) = KeyPkt k -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload KeyPkt k
kp

data KeyState
    = KeyState
    { KeyState -> Bool
keyStateValid :: Bool
    , KeyState -> Bool
keyStateSelfSignaturesKnown :: Bool
    , KeyState -> Bool
keyStateHasEffectiveSelfSignature :: Bool
    , KeyState -> Maybe UTCTime
keyStateExpirationTime :: Maybe UTCTime
    }
    deriving (KeyState -> KeyState -> Bool
(KeyState -> KeyState -> Bool)
-> (KeyState -> KeyState -> Bool) -> Eq KeyState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyState -> KeyState -> Bool
== :: KeyState -> KeyState -> Bool
$c/= :: KeyState -> KeyState -> Bool
/= :: KeyState -> KeyState -> Bool
Eq, Int -> KeyState -> ShowS
[KeyState] -> ShowS
KeyState -> String
(Int -> KeyState -> ShowS)
-> (KeyState -> String) -> ([KeyState] -> ShowS) -> Show KeyState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyState -> ShowS
showsPrec :: Int -> KeyState -> ShowS
$cshow :: KeyState -> String
show :: KeyState -> String
$cshowList :: [KeyState] -> ShowS
showList :: [KeyState] -> ShowS
Show)

-- this assumes that all key expiration time subpackets are valid
isTKTimeValid :: TKPrimaryPKPayload k => UTCTime -> TK k -> Bool
isTKTimeValid :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Bool
isTKTimeValid UTCTime
ct = KeyState -> Bool
keyStateValid (KeyState -> Bool) -> (TK k -> KeyState) -> TK k -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> TK k -> KeyState
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> KeyState
keyStateAt UTCTime
ct

keyStateAt :: TKPrimaryPKPayload k => UTCTime -> TK k -> KeyState
keyStateAt :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> KeyState
keyStateAt UTCTime
ct TK k
tk =
    KeyState
baseState
        { keyStateValid =
            keyStateValid baseState && bindingStateAllowsValidation
        }
  where
    baseState :: KeyState
baseState =
        UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState
keyStateFromSelfSignaturesAt
            UTCTime
ct
            (TK k -> SomePKPayload
forall (k :: TKKind). TKPrimaryPKPayload k => TK k -> SomePKPayload
tkPrimaryPKPayload TK k
tk)
            [SignaturePayload]
relevantSelfSignatures
    relevantSelfSignatures :: [SignaturePayload]
relevantSelfSignatures =
        [[SignaturePayload]] -> [SignaturePayload]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (SomePKPayload -> SignaturePayload -> Bool
isDirectKeySelfSigFor SomePKPayload
primaryKey) (TK k
tk TK k
-> Getting [SignaturePayload] (TK k) [SignaturePayload]
-> [SignaturePayload]
forall s a. s -> Getting a s a -> a
^. Getting [SignaturePayload] (TK k) [SignaturePayload]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([SignaturePayload] -> f [SignaturePayload]) -> TK k -> f (TK k)
tkDirectKeySigs)
            , (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (SomePKPayload -> SignaturePayload -> Bool
isSelfCertificationFor SomePKPayload
primaryKey)
                (((Text, [SignaturePayload]) -> [SignaturePayload])
-> [(Text, [SignaturePayload])] -> [SignaturePayload]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd (TK k
tk TK k
-> Getting
     [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs))
            , (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (SomePKPayload -> SignaturePayload -> Bool
isSelfCertificationFor SomePKPayload
primaryKey)
                ((([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload])
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [SignaturePayload]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd (TK k
tk TK k
-> Getting
     [([UserAttrSubPacket], [SignaturePayload])]
     (TK k)
     [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [([UserAttrSubPacket], [SignaturePayload])]
  (TK k)
  [([UserAttrSubPacket], [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([([UserAttrSubPacket], [SignaturePayload])]
 -> f [([UserAttrSubPacket], [SignaturePayload])])
-> TK k -> f (TK k)
tkUAts))
            ]
    selfCertificationGroups :: [[SignaturePayload]]
selfCertificationGroups =
        [[[SignaturePayload]]] -> [[SignaturePayload]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ ((Text, [SignaturePayload]) -> [SignaturePayload])
-> [(Text, [SignaturePayload])] -> [[SignaturePayload]]
forall a b. (a -> b) -> [a] -> [b]
map ((SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
primaryKey) ([SignaturePayload] -> [SignaturePayload])
-> ((Text, [SignaturePayload]) -> [SignaturePayload])
-> (Text, [SignaturePayload])
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd) (TK k
tk TK k
-> Getting
     [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs)
            , (([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload])
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [[SignaturePayload]]
forall a b. (a -> b) -> [a] -> [b]
map ((SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
primaryKey) ([SignaturePayload] -> [SignaturePayload])
-> (([UserAttrSubPacket], [SignaturePayload])
    -> [SignaturePayload])
-> ([UserAttrSubPacket], [SignaturePayload])
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd) (TK k
tk TK k
-> Getting
     [([UserAttrSubPacket], [SignaturePayload])]
     (TK k)
     [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [([UserAttrSubPacket], [SignaturePayload])]
  (TK k)
  [([UserAttrSubPacket], [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([([UserAttrSubPacket], [SignaturePayload])]
 -> f [([UserAttrSubPacket], [SignaturePayload])])
-> TK k -> f (TK k)
tkUAts)
            ]
    hasAnySelfCertification :: Bool
hasAnySelfCertification = ([SignaturePayload] -> Bool) -> [[SignaturePayload]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SignaturePayload -> Bool) -> [SignaturePayload] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SignaturePayload -> Bool
isCertificationSig) [[SignaturePayload]]
selfCertificationGroups
    hasAnyActiveSelfCertification :: Bool
hasAnyActiveSelfCertification =
        ([SignaturePayload] -> Bool) -> [[SignaturePayload]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime -> [SignaturePayload] -> Bool
selfCertificationGroupActiveAt UTCTime
ct) [[SignaturePayload]]
selfCertificationGroups
    bindingStateAllowsValidation :: Bool
bindingStateAllowsValidation =
        Bool -> Bool
not Bool
hasAnySelfCertification Bool -> Bool -> Bool
|| Bool
hasAnyActiveSelfCertification
    primaryKey :: SomePKPayload
primaryKey = TK k -> SomePKPayload
forall (k :: TKKind). TKPrimaryPKPayload k => TK k -> SomePKPayload
tkPrimaryPKPayload TK k
tk

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

effectiveUIDPreferencesAt
    :: TKPrimaryPKPayload k
    => UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAt :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAt UTCTime
ct Text
uid TK k
tk
    | Bool -> Bool
not (KeyState -> Bool
keyStateValid (UTCTime -> TK k -> KeyState
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> KeyState
keyStateAt UTCTime
ct TK k
tk)) = Maybe [SigSubPacketPayload]
forall a. Maybe a
Nothing
    | Bool
otherwise = do
        sigs <- Text -> [(Text, [SignaturePayload])] -> Maybe [SignaturePayload]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
uid (TK k
tk TK k
-> Getting
     [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs)
        cert <-
            latestActiveSelfCertificationAt
                ct
                (filter (isSelfSignatureFor primaryKey) sigs)
        let prefs = SignaturePayload -> [SigSubPacketPayload]
preferencePayloadsFromSignature SignaturePayload
cert
        if null prefs
            then Nothing
            else Just prefs
  where
    primaryKey :: SomePKPayload
primaryKey = TK k -> SomePKPayload
forall (k :: TKKind). TKPrimaryPKPayload k => TK k -> SomePKPayload
tkPrimaryPKPayload TK k
tk

effectiveKeyPreferencesAtTimestamp
    :: TKPrimaryPKPayload k
    => ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAtTimestamp :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAtTimestamp ThirtyTwoBitTimeStamp
ts =
    UTCTime -> TK k -> Maybe [SigSubPacketPayload]
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAt
        (NominalDiffTime -> UTCTime
posixSecondsToUTCTime (Word32 -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp
ts)))

effectiveUIDPreferencesAtTimestamp
    :: TKPrimaryPKPayload k
    => ThirtyTwoBitTimeStamp
    -> Text
    -> TK k
    -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAtTimestamp :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
ThirtyTwoBitTimeStamp
-> Text -> TK k -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAtTimestamp ThirtyTwoBitTimeStamp
ts Text
uid =
    UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]
effectiveUIDPreferencesAt
        (NominalDiffTime -> UTCTime
posixSecondsToUTCTime (Word32 -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp
ts)))
        Text
uid

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

keyStateFromSelfSignaturesAt
    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState
keyStateFromSelfSignaturesAt :: UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState
keyStateFromSelfSignaturesAt UTCTime
ct SomePKPayload
pkp [SignaturePayload]
sigs =
    KeyState
        { keyStateValid :: Bool
keyStateValid =
            UTCTime
ct UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
keyCreationTime
                Bool -> Bool -> Bool
&& Bool
selfSignatureStateAllowsValidation
                Bool -> Bool -> Bool
&& Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (UTCTime
ct UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) Maybe UTCTime
keyExpirationTime
        , keyStateSelfSignaturesKnown :: Bool
keyStateSelfSignaturesKnown =
            Bool
-> (SignaturePayload -> Bool) -> Maybe SignaturePayload -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> SignaturePayload -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe SignaturePayload
latestKnownSelfSignature
        , keyStateHasEffectiveSelfSignature :: Bool
keyStateHasEffectiveSelfSignature =
            Bool
-> (SignaturePayload -> Bool) -> Maybe SignaturePayload -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct) Maybe SignaturePayload
latestKnownSelfSignature
        , keyStateExpirationTime :: Maybe UTCTime
keyStateExpirationTime = Maybe UTCTime
keyExpirationTime
        }
  where
    keyCreationTime :: UTCTime
keyCreationTime = SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp SomePKPayload
pkp ThirtyTwoBitTimeStamp
-> (ThirtyTwoBitTimeStamp -> UTCTime) -> UTCTime
forall a b. a -> (a -> b) -> b
& NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (ThirtyTwoBitTimeStamp -> NominalDiffTime)
-> ThirtyTwoBitTimeStamp
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThirtyTwoBitTimeStamp -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    knownSelfSignatures :: [SignaturePayload]
knownSelfSignatures = (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore UTCTime
ct) [SignaturePayload]
sigs
    selfSignatureStateAllowsValidation :: Bool
selfSignatureStateAllowsValidation =
        Bool
-> (SignaturePayload -> Bool) -> Maybe SignaturePayload -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            ([SignaturePayload] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignaturePayload]
sigs)
            (UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct)
            Maybe SignaturePayload
latestKnownSelfSignature
    latestKnownSelfSignature :: Maybe SignaturePayload
latestKnownSelfSignature =
        (UTCTime, SignaturePayload) -> SignaturePayload
forall a b. (a, b) -> b
snd
            ((UTCTime, SignaturePayload) -> SignaturePayload)
-> Maybe (UTCTime, SignaturePayload) -> Maybe SignaturePayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTCTime, SignaturePayload)] -> Maybe (UTCTime, SignaturePayload)
forall a. [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime
                ([SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime [SignaturePayload]
knownSelfSignatures)
    keyExpirationTime :: Maybe UTCTime
keyExpirationTime = UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime
effectiveKeyExpirationTime UTCTime
ct SomePKPayload
pkp [SignaturePayload]
sigs

effectiveKeyExpirationTime
    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime
effectiveKeyExpirationTime :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime
effectiveKeyExpirationTime UTCTime
ct SomePKPayload
pkp [SignaturePayload]
sigs =
    SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime
signatureExpirationDurationToUTCTime SomePKPayload
pkp
        (ThirtyTwoBitDuration -> Maybe UTCTime)
-> Maybe ThirtyTwoBitDuration -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration
latestKnownExpirationDuration UTCTime
ct [SignaturePayload]
sigs

latestKnownExpirationDuration
    :: UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration
latestKnownExpirationDuration :: UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration
latestKnownExpirationDuration UTCTime
ct [SignaturePayload]
sigs =
    UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration
latestKnownSelfSignatureExpirationDuration UTCTime
ct
        (SignaturePayload -> Maybe ThirtyTwoBitDuration)
-> Maybe SignaturePayload -> Maybe ThirtyTwoBitDuration
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ( (UTCTime, SignaturePayload) -> SignaturePayload
forall a b. (a, b) -> b
snd
                ((UTCTime, SignaturePayload) -> SignaturePayload)
-> Maybe (UTCTime, SignaturePayload) -> Maybe SignaturePayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTCTime, SignaturePayload)] -> Maybe (UTCTime, SignaturePayload)
forall a. [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime
                    ( [SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime
                        ((SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore UTCTime
ct) [SignaturePayload]
sigs)
                    )
            )

latestKnownSelfSignatureExpirationDuration
    :: UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration
latestKnownSelfSignatureExpirationDuration :: UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration
latestKnownSelfSignatureExpirationDuration UTCTime
ct SignaturePayload
sig
    | UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct SignaturePayload
sig =
        [ThirtyTwoBitDuration] -> Maybe ThirtyTwoBitDuration
forall a. [a] -> Maybe a
listToMaybe (SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature SignaturePayload
sig)
    | Bool
otherwise = Maybe ThirtyTwoBitDuration
forall a. Maybe a
Nothing

signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct SignaturePayload
sig =
    Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
ct) (SignaturePayload -> Maybe UTCTime
signatureCreationTime SignaturePayload
sig)
        Bool -> Bool -> Bool
&& Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (UTCTime
ct UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) (SignaturePayload -> Maybe UTCTime
signatureExpirationTime SignaturePayload
sig)

signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore UTCTime
ct SignaturePayload
sig =
    Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
ct) (SignaturePayload -> Maybe UTCTime
signatureCreationTime SignaturePayload
sig)

signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime =
    (ThirtyTwoBitTimeStamp -> UTCTime)
-> Maybe ThirtyTwoBitTimeStamp -> Maybe UTCTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (ThirtyTwoBitTimeStamp -> NominalDiffTime)
-> ThirtyTwoBitTimeStamp
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Word32 -> NominalDiffTime)
-> (ThirtyTwoBitTimeStamp -> Word32)
-> ThirtyTwoBitTimeStamp
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp)
        (Maybe ThirtyTwoBitTimeStamp -> Maybe UTCTime)
-> (SignaturePayload -> Maybe ThirtyTwoBitTimeStamp)
-> SignaturePayload
-> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
sigCT

signatureExpirationTime :: SignaturePayload -> Maybe UTCTime
signatureExpirationTime :: SignaturePayload -> Maybe UTCTime
signatureExpirationTime SignaturePayload
sig =
    UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime
        (UTCTime -> ThirtyTwoBitDuration -> UTCTime)
-> Maybe UTCTime -> Maybe (ThirtyTwoBitDuration -> UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignaturePayload -> Maybe UTCTime
signatureCreationTime SignaturePayload
sig
        Maybe (ThirtyTwoBitDuration -> UTCTime)
-> Maybe ThirtyTwoBitDuration -> Maybe UTCTime
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration SignaturePayload
sig

signatureExpirationDuration
    :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration SignaturePayload
sig =
    SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig
        Maybe [SigSubPacket]
-> ([SigSubPacket] -> Maybe ThirtyTwoBitDuration)
-> Maybe ThirtyTwoBitDuration
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration

firstSignatureExpirationDuration
    :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration =
    (SigSubPacket
 -> Maybe ThirtyTwoBitDuration -> Maybe ThirtyTwoBitDuration)
-> Maybe ThirtyTwoBitDuration
-> [SigSubPacket]
-> Maybe ThirtyTwoBitDuration
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \SigSubPacket
subpacket Maybe ThirtyTwoBitDuration
acc ->
            case SigSubPacket
subpacket of
                SigSubPacket Bool
_ (SigExpirationTime ThirtyTwoBitDuration
duration) -> ThirtyTwoBitDuration -> Maybe ThirtyTwoBitDuration
forall a. a -> Maybe a
Just ThirtyTwoBitDuration
duration
                SigSubPacket
_ -> Maybe ThirtyTwoBitDuration
acc
        )
        Maybe ThirtyTwoBitDuration
forall a. Maybe a
Nothing

signatureExpirationDurationToUTCTime
    :: SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime
signatureExpirationDurationToUTCTime :: SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime
signatureExpirationDurationToUTCTime SomePKPayload
_ (ThirtyTwoBitDuration Word32
0) = Maybe UTCTime
forall a. Maybe a
Nothing
signatureExpirationDurationToUTCTime SomePKPayload
pkp ThirtyTwoBitDuration
duration =
    UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$
        UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime
            (SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp SomePKPayload
pkp ThirtyTwoBitTimeStamp
-> (ThirtyTwoBitTimeStamp -> UTCTime) -> UTCTime
forall a b. a -> (a -> b) -> b
& NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (ThirtyTwoBitTimeStamp -> NominalDiffTime)
-> ThirtyTwoBitTimeStamp
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThirtyTwoBitTimeStamp -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac)
            ThirtyTwoBitDuration
duration

addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime UTCTime
baseTime ThirtyTwoBitDuration
duration =
    NominalDiffTime -> UTCTime -> UTCTime
addUTCTime
        (Word32 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ThirtyTwoBitDuration -> Word32
unThirtyTwoBitDuration ThirtyTwoBitDuration
duration))
        UTCTime
baseTime

newestByCreationTime :: [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime :: forall a. [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime [] = Maybe (UTCTime, a)
forall a. Maybe a
Nothing
newestByCreationTime [(UTCTime, a)]
xs = (UTCTime, a) -> Maybe (UTCTime, a)
forall a. a -> Maybe a
Just (((UTCTime, a) -> (UTCTime, a) -> Ordering)
-> [(UTCTime, a)] -> (UTCTime, a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((UTCTime, a) -> UTCTime)
-> (UTCTime, a) -> (UTCTime, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, a) -> UTCTime
forall a b. (a, b) -> a
fst) [(UTCTime, a)]
xs)

mapMaybeSignatureCreationTime
    :: [SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime :: [SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime =
    (SignaturePayload
 -> [(UTCTime, SignaturePayload)] -> [(UTCTime, SignaturePayload)])
-> [(UTCTime, SignaturePayload)]
-> [SignaturePayload]
-> [(UTCTime, SignaturePayload)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \SignaturePayload
sig [(UTCTime, SignaturePayload)]
acc ->
            case SignaturePayload -> Maybe UTCTime
signatureCreationTime SignaturePayload
sig of
                Just UTCTime
ct -> (UTCTime
ct, SignaturePayload
sig) (UTCTime, SignaturePayload)
-> [(UTCTime, SignaturePayload)] -> [(UTCTime, SignaturePayload)]
forall a. a -> [a] -> [a]
: [(UTCTime, SignaturePayload)]
acc
                Maybe UTCTime
Nothing -> [(UTCTime, SignaturePayload)]
acc
        )
        []

selfCertificationGroupActiveAt
    :: UTCTime -> [SignaturePayload] -> Bool
selfCertificationGroupActiveAt :: UTCTime -> [SignaturePayload] -> Bool
selfCertificationGroupActiveAt UTCTime
ct [SignaturePayload]
sigs =
    Bool
-> (SignaturePayload -> Bool) -> Maybe SignaturePayload -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        Bool
False
        (Bool -> SignaturePayload -> Bool
forall a b. a -> b -> a
const Bool
True)
        (UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt UTCTime
ct [SignaturePayload]
sigs)

latestActiveSelfCertificationAt
    :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt UTCTime
ct [SignaturePayload]
sigs =
    case Maybe SignaturePayload
latestKnownSelfCertification of
        Maybe SignaturePayload
Nothing -> Maybe SignaturePayload
forall a. Maybe a
Nothing
        Just SignaturePayload
certification ->
            if UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct SignaturePayload
certification
                Bool -> Bool -> Bool
&& Bool -> Bool
not
                    ( (SignaturePayload -> Bool) -> [SignaturePayload] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
                        (\SignaturePayload
revocation -> UTCTime -> SignaturePayload -> SignaturePayload -> Bool
revokesCertificationAt UTCTime
ct SignaturePayload
revocation SignaturePayload
certification)
                        [SignaturePayload]
certRevocations
                    )
                then SignaturePayload -> Maybe SignaturePayload
forall a. a -> Maybe a
Just SignaturePayload
certification
                else Maybe SignaturePayload
forall a. Maybe a
Nothing
  where
    latestKnownSelfCertification :: Maybe SignaturePayload
latestKnownSelfCertification =
        (UTCTime, SignaturePayload) -> SignaturePayload
forall a b. (a, b) -> b
snd
            ((UTCTime, SignaturePayload) -> SignaturePayload)
-> Maybe (UTCTime, SignaturePayload) -> Maybe SignaturePayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTCTime, SignaturePayload)] -> Maybe (UTCTime, SignaturePayload)
forall a. [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime
                ([SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime [SignaturePayload]
knownCertifications)
    knownCertifications :: [SignaturePayload]
knownCertifications =
        (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter
            ( \SignaturePayload
sig -> SignaturePayload -> Bool
isCertificationSig SignaturePayload
sig Bool -> Bool -> Bool
&& UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore UTCTime
ct SignaturePayload
sig
            )
            [SignaturePayload]
sigs
    certRevocations :: [SignaturePayload]
certRevocations =
        (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SignaturePayload
sig -> UTCTime -> SignaturePayload -> Bool
isCertRevocationForTime UTCTime
ct SignaturePayload
sig) [SignaturePayload]
sigs

latestEffectivePreferenceCarrierAt
    :: TKPrimaryPKPayload k => UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt UTCTime
ct TK k
tk =
    (UTCTime, SignaturePayload) -> SignaturePayload
forall a b. (a, b) -> b
snd
        ((UTCTime, SignaturePayload) -> SignaturePayload)
-> Maybe (UTCTime, SignaturePayload) -> Maybe SignaturePayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTCTime, SignaturePayload)] -> Maybe (UTCTime, SignaturePayload)
forall a. [(UTCTime, a)] -> Maybe (UTCTime, a)
newestByCreationTime ([SignaturePayload] -> [(UTCTime, SignaturePayload)]
mapMaybeSignatureCreationTime [SignaturePayload]
candidates)
  where
    primaryKey :: SomePKPayload
primaryKey = TK k -> SomePKPayload
forall (k :: TKKind). TKPrimaryPKPayload k => TK k -> SomePKPayload
tkPrimaryPKPayload TK k
tk
    directKeySigs :: [SignaturePayload]
directKeySigs =
        (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter
            ( \SignaturePayload
sig ->
                SomePKPayload -> SignaturePayload -> Bool
isDirectKeySelfSigFor SomePKPayload
primaryKey SignaturePayload
sig
                    Bool -> Bool -> Bool
&& UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt UTCTime
ct SignaturePayload
sig
            )
            (TK k
tk TK k
-> Getting [SignaturePayload] (TK k) [SignaturePayload]
-> [SignaturePayload]
forall s a. s -> Getting a s a -> a
^. Getting [SignaturePayload] (TK k) [SignaturePayload]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([SignaturePayload] -> f [SignaturePayload]) -> TK k -> f (TK k)
tkDirectKeySigs)
    uidSelfCerts :: [SignaturePayload]
uidSelfCerts =
        ((Text, [SignaturePayload]) -> Maybe SignaturePayload)
-> [(Text, [SignaturePayload])] -> [SignaturePayload]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            ( UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt UTCTime
ct
                ([SignaturePayload] -> Maybe SignaturePayload)
-> ((Text, [SignaturePayload]) -> [SignaturePayload])
-> (Text, [SignaturePayload])
-> Maybe SignaturePayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
primaryKey)
                ([SignaturePayload] -> [SignaturePayload])
-> ((Text, [SignaturePayload]) -> [SignaturePayload])
-> (Text, [SignaturePayload])
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd
            )
            (TK k
tk TK k
-> Getting
     [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] (TK k) [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs)
    uatSelfCerts :: [SignaturePayload]
uatSelfCerts =
        (([UserAttrSubPacket], [SignaturePayload])
 -> Maybe SignaturePayload)
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [SignaturePayload]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            ( UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestActiveSelfCertificationAt UTCTime
ct
                ([SignaturePayload] -> Maybe SignaturePayload)
-> (([UserAttrSubPacket], [SignaturePayload])
    -> [SignaturePayload])
-> ([UserAttrSubPacket], [SignaturePayload])
-> Maybe SignaturePayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
primaryKey)
                ([SignaturePayload] -> [SignaturePayload])
-> (([UserAttrSubPacket], [SignaturePayload])
    -> [SignaturePayload])
-> ([UserAttrSubPacket], [SignaturePayload])
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd
            )
            (TK k
tk TK k
-> Getting
     [([UserAttrSubPacket], [SignaturePayload])]
     (TK k)
     [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [([UserAttrSubPacket], [SignaturePayload])]
  (TK k)
  [([UserAttrSubPacket], [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([([UserAttrSubPacket], [SignaturePayload])]
 -> f [([UserAttrSubPacket], [SignaturePayload])])
-> TK k -> f (TK k)
tkUAts)
    candidates :: [SignaturePayload]
candidates = [SignaturePayload]
directKeySigs [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ [SignaturePayload]
uidSelfCerts [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ [SignaturePayload]
uatSelfCerts

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

signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets SignaturePayload
sig =
    [SigSubPacket]
-> ([SigSubPacket] -> [SigSubPacket])
-> Maybe [SigSubPacket]
-> [SigSubPacket]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [SigSubPacket] -> [SigSubPacket]
forall a. a -> a
id (SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig)

isPreferenceSubpacket :: SigSubPacket -> Bool
isPreferenceSubpacket :: SigSubPacket -> Bool
isPreferenceSubpacket (SigSubPacket Bool
_ (PreferredSymmetricAlgorithms [SymmetricAlgorithm]
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (PreferredHashAlgorithms [HashAlgorithm]
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (PreferredCompressionAlgorithms [CompressionAlgorithm]
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (KeyServerPreferences Set KSPFlag
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (PreferredKeyServer KeyServer
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (Features Set FeatureFlag
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (PreferredAEADCiphersuites [(SymmetricAlgorithm, AEADAlgorithm)]
_)) = Bool
True
isPreferenceSubpacket (SigSubPacket Bool
_ (OtherSigSub Word8
subpacketType KeyServer
_)) =
    Word8
subpacketType Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
39
isPreferenceSubpacket SigSubPacket
_ = Bool
False

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

isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool
isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool
isCertRevocationForTime UTCTime
ct SignaturePayload
sig =
    SignaturePayload -> Maybe SigType
sigType SignaturePayload
sig Maybe SigType -> Maybe SigType -> Bool
forall a. Eq a => a -> a -> Bool
== SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
CertRevocationSig
        Bool -> Bool -> Bool
&& UTCTime -> SignaturePayload -> Bool
signatureCreatedAtOrBefore UTCTime
ct SignaturePayload
sig

isCertificationSig :: SignaturePayload -> Bool
isCertificationSig :: SignaturePayload -> Bool
isCertificationSig SignaturePayload
sig =
    SignaturePayload -> Maybe SigType
sigType SignaturePayload
sig
        Maybe SigType -> [Maybe SigType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
GenericCert
               , SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
PersonaCert
               , SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
CasualCert
               , SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
PositiveCert
               ]

isDirectKeySelfSigFor
    :: SomePKPayload -> SignaturePayload -> Bool
isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool
isDirectKeySelfSigFor SomePKPayload
pkp SignaturePayload
sig =
    SignaturePayload -> Maybe SigType
sigType SignaturePayload
sig Maybe SigType -> Maybe SigType -> Bool
forall a. Eq a => a -> a -> Bool
== SigType -> Maybe SigType
forall a. a -> Maybe a
Just SigType
DirectKeySignature
        Bool -> Bool -> Bool
&& SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
pkp SignaturePayload
sig

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

isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool
isSelfSignatureFor SomePKPayload
pkp SignaturePayload
sig =
    ( ((Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp) (Fingerprint -> Bool) -> Maybe Fingerprint -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pkt -> Maybe Fingerprint
issuerFP (SignaturePayload -> Pkt
SignaturePkt SignaturePayload
sig))
        Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    )
        Bool -> Bool -> Bool
|| ( (EightOctetKeyId -> EightOctetKeyId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (EightOctetKeyId -> EightOctetKeyId -> Bool)
-> Maybe EightOctetKeyId -> Maybe (EightOctetKeyId -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pkt -> Maybe EightOctetKeyId
issuer (SignaturePayload -> Pkt
SignaturePkt SignaturePayload
sig) Maybe (EightOctetKeyId -> Bool)
-> Maybe EightOctetKeyId -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either KeyIdError EightOctetKeyId -> Maybe EightOctetKeyId
forall a b. Either a b -> Maybe b
hush (SomePKPayload -> Either KeyIdError EightOctetKeyId
eightOctetKeyID SomePKPayload
pkp))
                Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
           )

getKeyExpirationTimesFromSignature
    :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature SignaturePayload
sig =
    (SigSubPacket -> Maybe ThirtyTwoBitDuration)
-> [SigSubPacket] -> [ThirtyTwoBitDuration]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \(SigSubPacket Bool
_ SigSubPacketPayload
payload) ->
            case SigSubPacketPayload
payload of
                KeyExpirationTime ThirtyTwoBitDuration
x -> ThirtyTwoBitDuration -> Maybe ThirtyTwoBitDuration
forall a. a -> Maybe a
Just ThirtyTwoBitDuration
x
                SigSubPacketPayload
_ -> Maybe ThirtyTwoBitDuration
forall a. Maybe a
Nothing
        )
        (SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets SignaturePayload
sig)

-- | Extract KeyFlags from a single signature's hashed subpackets.
keyFlagsFromSignature :: SignaturePayload -> Maybe (Set KeyFlag)
keyFlagsFromSignature :: SignaturePayload -> Maybe (Set KeyFlag)
keyFlagsFromSignature SignaturePayload
sig =
    case SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig of
        Maybe [SigSubPacket]
Nothing -> Maybe (Set KeyFlag)
forall a. Maybe a
Nothing
        Just [SigSubPacket]
subpackets ->
            (SigSubPacket -> Maybe (Set KeyFlag) -> Maybe (Set KeyFlag))
-> Maybe (Set KeyFlag) -> [SigSubPacket] -> Maybe (Set KeyFlag)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \(SigSubPacket Bool
_ SigSubPacketPayload
payload) Maybe (Set KeyFlag)
acc ->
                    case SigSubPacketPayload
payload of
                        KeyFlags Set KeyFlag
flags -> Set KeyFlag -> Maybe (Set KeyFlag)
forall a. a -> Maybe a
Just (Set KeyFlag
-> (Set KeyFlag -> Set KeyFlag)
-> Maybe (Set KeyFlag)
-> Set KeyFlag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set KeyFlag
flags (Set KeyFlag -> Set KeyFlag -> Set KeyFlag
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set KeyFlag
flags) Maybe (Set KeyFlag)
acc)
                        SigSubPacketPayload
_ -> Maybe (Set KeyFlag)
acc
                )
                Maybe (Set KeyFlag)
forall a. Maybe a
Nothing
                [SigSubPacket]
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 :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe (Set KeyFlag)
effectiveKeyFlagsAt UTCTime
ct TK k
tk = do
    sig <- UTCTime -> TK k -> Maybe SignaturePayload
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt UTCTime
ct TK k
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 :: forall (k :: TKKind).
(TKPrimaryPKPayload k, TKSubkeyPKPayload k) =>
UTCTime -> TK k -> Fingerprint -> Maybe (Set KeyFlag)
effectiveSubkeyFlagsAt UTCTime
ct TK k
tk Fingerprint
fp = do
    (_, bindingSigs) <-
        ((TKKeyPkt k, [SignaturePayload]) -> Bool)
-> [(TKKeyPkt k, [SignaturePayload])]
-> Maybe (TKKeyPkt k, [SignaturePayload])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
            (\(TKKeyPkt k
kp, [SignaturePayload]
_) -> SomePKPayload -> Fingerprint
fingerprint (forall (k :: TKKind).
TKSubkeyPKPayload k =>
TKKeyPkt k -> SomePKPayload
tkSubkeyPKPayload @k TKKeyPkt k
kp) Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
fp)
            (TK k
tk TK k
-> Getting
     [(TKKeyPkt k, [SignaturePayload])]
     (TK k)
     [(TKKeyPkt k, [SignaturePayload])]
-> [(TKKeyPkt k, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(TKKeyPkt k, [SignaturePayload])]
  (TK k)
  [(TKKeyPkt k, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(TKKeyPkt k, [SignaturePayload])]
 -> f [(TKKeyPkt k, [SignaturePayload])])
-> TK k -> f (TK k)
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 :: forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe (Set FeatureFlag)
effectiveFeaturesAt UTCTime
ct TK k
tk = do
    sig <- UTCTime -> TK k -> Maybe SignaturePayload
forall (k :: TKKind).
TKPrimaryPKPayload k =>
UTCTime -> TK k -> Maybe SignaturePayload
latestEffectivePreferenceCarrierAt UTCTime
ct TK k
tk
    featuresFromSignature sig

-- | Extract Features from a single signature's hashed subpackets.
featuresFromSignature
    :: SignaturePayload -> Maybe (Set FeatureFlag)
featuresFromSignature :: SignaturePayload -> Maybe (Set FeatureFlag)
featuresFromSignature SignaturePayload
sig =
    case SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig of
        Maybe [SigSubPacket]
Nothing -> Maybe (Set FeatureFlag)
forall a. Maybe a
Nothing
        Just [SigSubPacket]
subpackets ->
            (SigSubPacket
 -> Maybe (Set FeatureFlag) -> Maybe (Set FeatureFlag))
-> Maybe (Set FeatureFlag)
-> [SigSubPacket]
-> Maybe (Set FeatureFlag)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \(SigSubPacket Bool
_ SigSubPacketPayload
payload) Maybe (Set FeatureFlag)
acc ->
                    case SigSubPacketPayload
payload of
                        Features Set FeatureFlag
flags -> Set FeatureFlag -> Maybe (Set FeatureFlag)
forall a. a -> Maybe a
Just (Set FeatureFlag
-> (Set FeatureFlag -> Set FeatureFlag)
-> Maybe (Set FeatureFlag)
-> Set FeatureFlag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set FeatureFlag
flags (Set FeatureFlag -> Set FeatureFlag -> Set FeatureFlag
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set FeatureFlag
flags) Maybe (Set FeatureFlag)
acc)
                        SigSubPacketPayload
_ -> Maybe (Set FeatureFlag)
acc
                )
                Maybe (Set FeatureFlag)
forall a. Maybe a
Nothing
                [SigSubPacket]
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 :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignatureAt UTCTime
ct [SignaturePayload]
sigs =
    case (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (UTCTime -> SignaturePayload -> Bool
isEffectiveSubkeyBindingSignatureAt UTCTime
ct) [SignaturePayload]
sigs of
        [] -> Maybe SignaturePayload
forall a. Maybe a
Nothing
        [SignaturePayload]
candidates ->
            SignaturePayload -> Maybe SignaturePayload
forall a. a -> Maybe a
Just
                ((SignaturePayload -> SignaturePayload -> Ordering)
-> [SignaturePayload] -> SignaturePayload
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((SignaturePayload -> UTCTime)
-> SignaturePayload -> SignaturePayload -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SignaturePayload -> UTCTime
signatureCreationTimeOrZero) [SignaturePayload]
candidates)

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

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

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