-- 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 :: SignaturePayload -> Maybe TrailerCapableSignaturePayload
trailerCapableSignaturePayload SignaturePayload
sig =
  case SignaturePayload -> SomeSignaturePayload
toSomeSignaturePayload SignaturePayload
sig of
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV4Data {}) ->
      TrailerCapableSignaturePayload
-> Maybe TrailerCapableSignaturePayload
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV4 -> TrailerCapableSignaturePayload
TrailerCapableSignaturePayloadV4 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV4
payload)
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV6Data {}) ->
      TrailerCapableSignaturePayload
-> Maybe TrailerCapableSignaturePayload
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV6 -> TrailerCapableSignaturePayload
TrailerCapableSignaturePayloadV6 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV6
payload)
    SomeSignaturePayload
_ -> Maybe TrailerCapableSignaturePayload
forall a. Maybe a
Nothing

trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType
trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType
trailerCapableSigType (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data SigType
st PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
_ [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)) = SigType
st
trailerCapableSigType (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data SigType
st PubKeyAlgorithm
_ HashAlgorithm
_ SignatureSalt
_ [SigSubPacket]
_ [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)) = SigType
st

trailerCapableSubpacketLists ::
     TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket])
trailerCapableSubpacketLists :: TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket])
trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
h [SigSubPacket]
u Word16
_ NonEmpty MPI
_)) =
  ([SigSubPacket]
h, [SigSubPacket]
u)
trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ SignatureSalt
_ [SigSubPacket]
h [SigSubPacket]
u Word16
_ NonEmpty MPI
_)) =
  ([SigSubPacket]
h, [SigSubPacket]
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 :: SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
expected SignaturePayload
sig =
  case SignaturePayload -> Maybe TrailerCapableSignaturePayload
trailerCapableSignaturePayload SignaturePayload
sig of
    Just TrailerCapableSignaturePayload
trailerCapable -> TrailerCapableSignaturePayload -> SigType
trailerCapableSigType TrailerCapableSignaturePayload
trailerCapable SigType -> SigType -> Bool
forall a. Eq a => a -> a -> Bool
== SigType
expected
    Maybe TrailerCapableSignaturePayload
_ -> Bool
False

isCertRevocationSig :: SignaturePayload -> Bool
isCertRevocationSig :: SignaturePayload -> Bool
isCertRevocationSig = SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
CertRevocationSig

isRevokerP :: SignaturePayload -> Bool
isRevokerP :: SignaturePayload -> Bool
isRevokerP SignaturePayload
sig =
  case SignaturePayload -> Maybe TrailerCapableSignaturePayload
trailerCapableSignaturePayload SignaturePayload
sig of
    Just TrailerCapableSignaturePayload
trailerCapable
      | TrailerCapableSignaturePayload -> SigType
trailerCapableSigType TrailerCapableSignaturePayload
trailerCapable SigType -> SigType -> Bool
forall a. Eq a => a -> a -> Bool
== SigType
SignatureDirectlyOnAKey ->
          let ([SigSubPacket]
h, [SigSubPacket]
u) = TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket])
trailerCapableSubpacketLists TrailerCapableSignaturePayload
trailerCapable
           in [SigSubPacket] -> [SigSubPacket] -> Bool
hasRevokerSubpackets [SigSubPacket]
h [SigSubPacket]
u
    Maybe TrailerCapableSignaturePayload
_ -> Bool
False

hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool
hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool
hasRevokerSubpackets [SigSubPacket]
h [SigSubPacket]
u = (SigSubPacket -> Bool) -> [SigSubPacket] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SigSubPacket -> Bool
isRevocationKeySSP [SigSubPacket]
h Bool -> Bool -> Bool
&& (SigSubPacket -> Bool) -> [SigSubPacket] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SigSubPacket -> Bool
isIssuerSSP [SigSubPacket]
u

isPKBindingSig :: SignaturePayload -> Bool
isPKBindingSig :: SignaturePayload -> Bool
isPKBindingSig = SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
PrimaryKeyBindingSig

isSKBindingSig :: SignaturePayload -> Bool
isSKBindingSig :: SignaturePayload -> Bool
isSKBindingSig = SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
SubkeyBindingSig

isSubkeyRevocation :: SignaturePayload -> Bool
isSubkeyRevocation :: SignaturePayload -> Bool
isSubkeyRevocation = SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
SubkeyRevocationSig

isSubkeyBindingSig :: SignaturePayload -> Bool
isSubkeyBindingSig :: SignaturePayload -> Bool
isSubkeyBindingSig = SigType -> SignaturePayload -> Bool
isSigTypeFor SigType
SubkeyBindingSig

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

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

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

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

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

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

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

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

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