Ontology.hs

-- Ontology.hs: OpenPGP (RFC9580) "is" functions
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

module Codec.Encryption.OpenPGP.Ontology
    ( -- * for signature payloads
      isCertRevocationSig
    , isRevokerP
    , isPKBindingSig
    , isSKBindingSig
    , isSubkeyBindingSig
    , isSubkeyRevocation
    , isTrustPkt

      -- * for signature subpackets
    , isCT
    , isIssuerSSP
    , isIssuerFPSSP
    , isKET
    , isKUF
    , isPHA
    , isRevocationKeySSP
    , isSigCreationTime
    ) where

import Control.Applicative ((<|>))
import Control.Lens (preview, _1)

import Codec.Encryption.OpenPGP.Types

{- | Test whether a 'SignaturePayload' has the given 'SigType'.
Returns 'False' for V3 and 'SigVOther' payloads; V3 signatures are excluded
from structural predicate checks since they lack subpacket support and are
not used in V4/V6 keyring contexts.
-}
isSigTypeFor :: SigType -> SignaturePayload -> Bool
isSigTypeFor expected sig =
    maybe False (== expected) $
        preview (_SigV4 . _1) sig <|> preview (_SigV6 . _1) sig

isCertRevocationSig :: SignaturePayload -> Bool
isCertRevocationSig = isSigTypeFor CertRevocationSig

isRevokerP :: SignaturePayload -> Bool
isRevokerP sig =
    case preview _SigV4 sig of
        Just (st, _, _, h, u, _, _) ->
            st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u
        Nothing ->
            case preview _SigV6 sig of
                Just (st, _, _, _, h, u, _, _) ->
                    st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u
                Nothing -> False

hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool
hasRevokerSubpackets h u = any isRevocationKeySSP h && any isIssuerSSP u

isPKBindingSig :: SignaturePayload -> Bool
isPKBindingSig = isSigTypeFor PrimaryKeyBindingSig

isSKBindingSig :: SignaturePayload -> Bool
isSKBindingSig = isSigTypeFor SubkeyBindingSig

isSubkeyRevocation :: SignaturePayload -> Bool
isSubkeyRevocation = isSigTypeFor SubkeyRevocationSig

isSubkeyBindingSig :: SignaturePayload -> Bool
isSubkeyBindingSig = isSigTypeFor SubkeyBindingSig

isTrustPkt :: Pkt -> Bool
isTrustPkt (TrustPkt _) = True
isTrustPkt _ = False

isCT :: SigSubPacket -> Bool
isCT (SigSubPacket _ (SigCreationTime _)) = True
isCT _ = False

isIssuerSSP :: SigSubPacket -> Bool
isIssuerSSP (SigSubPacket _ (Issuer _)) = True
isIssuerSSP _ = False

isIssuerFPSSP :: SigSubPacket -> Bool
isIssuerFPSSP (SigSubPacket _ (IssuerFingerprint _ _)) = True
isIssuerFPSSP _ = False

isKET :: SigSubPacket -> Bool
isKET (SigSubPacket _ (KeyExpirationTime _)) = True
isKET _ = False

isKUF :: SigSubPacket -> Bool
isKUF (SigSubPacket _ (KeyFlags _)) = True
isKUF _ = False

isPHA :: SigSubPacket -> Bool
isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True
isPHA _ = False

isRevocationKeySSP :: SigSubPacket -> Bool
isRevocationKeySSP (SigSubPacket _ RevocationKey {}) = True
isRevocationKeySSP _ = False

isSigCreationTime :: SigSubPacket -> Bool
isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True
isSigCreationTime _ = False