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

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

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 Codec.Encryption.OpenPGP.Types

data TrailerCapableSignaturePayload where
  TrailerCapableSignaturePayloadV4 ::
       SignaturePayloadV 'SigPayloadV4 -> TrailerCapableSignaturePayload
  TrailerCapableSignaturePayloadV6 ::
       SignaturePayloadV 'SigPayloadV6 -> TrailerCapableSignaturePayload

trailerCapableSignaturePayload ::
     SignaturePayload -> Maybe TrailerCapableSignaturePayload
trailerCapableSignaturePayload sig =
  case toSomeSignaturePayload sig of
    SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
      Just (TrailerCapableSignaturePayloadV4 payload)
    SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
      Just (TrailerCapableSignaturePayloadV6 payload)
    _ -> Nothing

trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType
trailerCapableSigType (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) = st
trailerCapableSigType (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) = st

trailerCapableSubpacketLists ::
     TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket])
trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data _ _ _ h u _ _)) =
  (h, u)
trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ h u _ _)) =
  (h, u)

-- | 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 =
  case trailerCapableSignaturePayload sig of
    Just trailerCapable -> trailerCapableSigType trailerCapable == expected
    _ -> False

isCertRevocationSig :: SignaturePayload -> Bool
isCertRevocationSig = isSigTypeFor CertRevocationSig

isRevokerP :: SignaturePayload -> Bool
isRevokerP sig =
  case trailerCapableSignaturePayload sig of
    Just trailerCapable
      | trailerCapableSigType trailerCapable == SignatureDirectlyOnAKey ->
          let (h, u) = trailerCapableSubpacketLists trailerCapable
           in hasRevokerSubpackets h u
    _ -> 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