Subpackets.hs

-- Subpackets.hs: Type-safe subpacket builders with phantom types
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Codec.Encryption.OpenPGP.Subpackets
    ( -- * Safe subpacket construction
      SafeSubpacket
    , mkSafeSubpacket
    , safePayload
    , safeSubpacket

      -- * Critical subpacket handling
    , CriticalSubpacket
    , mkCritical
    , canBeCritical

      -- * Text normalization mode
    , TextNormalizationMode (..)

      -- * Builder API for signature composition
    , SigBuilder
    , LegalSubpacket (..)
    , legalSubpacket
    , singleLegalSub
    , consLegalSub
    , listToLegalSubs
    , sbSigType
    , sbPubKeyAlgo
    , sbHashAlgo
    , sbHashedSubs
    , sbUnhashedSubs
    , sbSalt
    , sbTextNormMode
    , buildSigV4
    , buildSigV6
    , sigBuilderInit
    , sigBuilderInitTyped
    , sigBuilderInitRuntime
    , sigBuilderInitV6
    , sigBuilderInitV6Typed
    , sigBuilderInitV6Runtime
    , addHashedSubs
    , addUnhashedSubs
    , KnownPubKeyAlgorithm (..)

      -- * Private key wrapper (algorithm-specific)
    , PrivateKeyFor (..)

      -- * Subpacket list utilities
    , HashedSubpackets
    , UnhashedSubpackets
    , consHashedSub
    , singleHashedSub
    , singleUnhashedSub
    , listToHashedSubs
    , listToUnhashedSubs
    ) where

import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy (..))
import Data.Word (Word16)

import Codec.Encryption.OpenPGP.Policy
    ( HashAlgoAllowedFor
    , HashAlgorithmW (..)
    , OpenPGPRFC
    , OpenPGPRFCW (..)
    , SomeHashAlgorithmW (..)
    , SomeOpenPGPRFCW (..)
    , demoteHashAlgorithmW
    , deprecatedHashAlgorithms
    , policyForRFC
    , policyGenerationDeprecations
    , promoteHashAlgorithm
    , promoteOpenPGPRFC
    )
import Codec.Encryption.OpenPGP.Types
    ( EightOctetKeyId
    , Fingerprint
    , HashAlgorithm
    , Hashed
    , MPI
    , SigSubPacket (..)
    , SigSubPacketPayload (..)
    , SigType
    , SignaturePayload (..)
    , SignatureSalt
    , SubpacketList (..)
    , ThirtyTwoBitTimeStamp
    , Unhashed
    , V4Sig
    , V6Sig
    )
import Codec.Encryption.OpenPGP.Types.Internal.Base
    ( IssuerFingerprintVersion (..)
    , PubKeyAlgorithm (..)
    )

-- | Type alias for readability: hashed subpacket list
type HashedSubpackets v = SubpacketList Hashed v

-- | Type alias for readability: unhashed subpacket list
type UnhashedSubpackets v = SubpacketList Unhashed v

{- | A subpacket that has passed basic safety checks
(does not guarantee it's critical-safe; use CriticalSubpacket for that)
-}
newtype SafeSubpacket = SafeSubpacket SigSubPacket
    deriving (Eq, Ord, Show)

{- | Create a safe subpacket from a payload and criticality flag
Basic validation that the payload is well-formed
-}
mkSafeSubpacket
    :: Bool -> SigSubPacketPayload -> Either String SafeSubpacket
mkSafeSubpacket crit payload = do
    -- Validate criticality constraints: some subpackets should never be critical
    if crit && not (canBeCritical payload)
        then
            Left $
                "Subpacket type cannot be marked critical: " ++ show payload
        else Right (SafeSubpacket (SigSubPacket crit payload))

-- | Extract the payload from a safe subpacket
safePayload :: SafeSubpacket -> SigSubPacketPayload
safePayload (SafeSubpacket (SigSubPacket _ payload)) = payload

-- | Extract the underlying SigSubPacket from a safe subpacket
safeSubpacket :: SafeSubpacket -> SigSubPacket
safeSubpacket (SafeSubpacket ssp) = ssp

{- | A subpacket that is guaranteed to be both well-formed AND can be safely marked critical
Used to prevent accidentally marking non-critical-safe types as critical
-}
newtype CriticalSubpacket = CriticalSubpacket SigSubPacket
    deriving (Eq, Ord, Show)

{- | Create a critical subpacket only if the payload type allows it
RFC9580 section 5.2.3.5: only certain subpacket types can be marked critical
-}
mkCritical
    :: SigSubPacketPayload -> Either String CriticalSubpacket
mkCritical payload
    | canBeCritical payload =
        Right $ CriticalSubpacket (SigSubPacket True payload)
    | otherwise =
        Left $ "Cannot mark as critical: " ++ payloadType payload
  where
    payloadType (SigCreationTime _) = "SigCreationTime"
    payloadType (SigExpirationTime _) = "SigExpirationTime"
    payloadType (ExportableCertification _) = "ExportableCertification"
    payloadType (TrustSignature {}) = "TrustSignature"
    payloadType (RegularExpression _) = "RegularExpression"
    payloadType (Revocable _) = "Revocable"
    payloadType (KeyExpirationTime _) = "KeyExpirationTime"
    payloadType (PreferredSymmetricAlgorithms _) = "PreferredSymmetricAlgorithms"
    payloadType (RevocationKey {}) = "RevocationKey"
    payloadType (Issuer _) = "Issuer"
    payloadType (NotationData {}) = "NotationData"
    payloadType (PreferredHashAlgorithms _) = "PreferredHashAlgorithms"
    payloadType (PreferredCompressionAlgorithms _) = "PreferredCompressionAlgorithms"
    payloadType (KeyServerPreferences _) = "KeyServerPreferences"
    payloadType (PreferredKeyServer _) = "PreferredKeyServer"
    payloadType (PrimaryUserId _) = "PrimaryUserId"
    payloadType (PolicyURL _) = "PolicyURL"
    payloadType (KeyFlags _) = "KeyFlags"
    payloadType (SignersUserId _) = "SignersUserId"
    payloadType (ReasonForRevocation {}) = "ReasonForRevocation"
    payloadType (Features _) = "Features"
    payloadType (SignatureTarget {}) = "SignatureTarget"
    payloadType (EmbeddedSignature _) = "EmbeddedSignature"
    payloadType (IssuerFingerprint {}) = "IssuerFingerprint"
    payloadType (UserDefinedSigSub _ _) = "UserDefinedSigSub"
    payloadType (OtherSigSub _ _) = "OtherSigSub"
    payloadType (IntendedRecipient _ _) = "IntendedRecipient"
    payloadType (PreferredAEADCiphersuites _) = "PreferredAEADCiphersuites"

-- | RFC9580 §5.2.3.5 lists which subpacket types can be marked critical
canBeCritical :: SigSubPacketPayload -> Bool
canBeCritical KeyFlags {} = True
canBeCritical IssuerFingerprint {} = True
canBeCritical EmbeddedSignature {} = True
-- Future-proofing: unknown critical types are allowed to be critical
canBeCritical UserDefinedSigSub {} = True
canBeCritical OtherSigSub {} = True
canBeCritical _ = False

{- | Wrapper GADT for algorithm-specific private keys
Encodes the algorithm at the type level to ensure type-safe key/builder matching
-}
data PrivateKeyFor (algo :: PubKeyAlgorithm) where
    RSAPrivateKey :: RSATypes.PrivateKey -> PrivateKeyFor 'RSA
    Ed25519PrivateKey :: Ed25519.SecretKey -> PrivateKeyFor 'Ed25519
    Ed448PrivateKey :: Ed448.SecretKey -> PrivateKeyFor 'Ed448
    DSAPrivateKey :: DSA.PrivateKey -> PrivateKeyFor 'DSA
    ECDSAPrivateKey :: ECDSA.PrivateKey -> PrivateKeyFor 'ECDSA

class KnownPubKeyAlgorithm (algo :: PubKeyAlgorithm) where
    demotePubKeyAlgorithmT :: Proxy algo -> PubKeyAlgorithm

instance KnownPubKeyAlgorithm 'RSA where
    demotePubKeyAlgorithmT _ = RSA

instance KnownPubKeyAlgorithm 'DSA where
    demotePubKeyAlgorithmT _ = DSA

instance KnownPubKeyAlgorithm 'ECDSA where
    demotePubKeyAlgorithmT _ = ECDSA

instance KnownPubKeyAlgorithm 'EdDSALegacy where
    demotePubKeyAlgorithmT _ = EdDSALegacy

instance KnownPubKeyAlgorithm 'Ed25519 where
    demotePubKeyAlgorithmT _ = Ed25519

instance KnownPubKeyAlgorithm 'Ed448 where
    demotePubKeyAlgorithmT _ = Ed448

{- | Legal subpackets encoded by placement and signature-version constraints.
This expands compile-time legality beyond bare hashed/unhashed staging.
-}
data LegalSubpacket (h :: Type) (v :: Type) where
    -- RFC9580: signature creation time is a hashed subpacket.
    LegalSigCreationTime
        :: ThirtyTwoBitTimeStamp -> LegalSubpacket Hashed v
    -- v4 signatures use an issuer fingerprint subpacket with version marker 4 in hashed area.
    LegalIssuerFingerprintV4
        :: Fingerprint -> LegalSubpacket Hashed V4Sig
    -- v6 signatures use an issuer fingerprint subpacket with version marker 6 in hashed area.
    LegalIssuerFingerprintV6
        :: Fingerprint -> LegalSubpacket Hashed V6Sig
    -- Legacy issuer key ID subpacket is accepted only in v4 and only unhashed.
    LegalIssuerV4 :: EightOctetKeyId -> LegalSubpacket Unhashed V4Sig

legalSubpacket :: LegalSubpacket h v -> SigSubPacket
legalSubpacket (LegalSigCreationTime ts) = SigSubPacket False (SigCreationTime ts)
legalSubpacket (LegalIssuerFingerprintV4 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 fp)
legalSubpacket (LegalIssuerFingerprintV6 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 fp)
legalSubpacket (LegalIssuerV4 keyId) = SigSubPacket False (Issuer keyId)

singleLegalSub :: LegalSubpacket h v -> SubpacketList h v
singleLegalSub = SubpacketList . (: []) . legalSubpacket

consLegalSub
    :: LegalSubpacket h v -> SubpacketList h v -> SubpacketList h v
consLegalSub legal (SubpacketList sps) = SubpacketList (legalSubpacket legal : sps)

listToLegalSubs :: [LegalSubpacket h v] -> SubpacketList h v
listToLegalSubs = SubpacketList . fmap legalSubpacket

-- | Construct a single hashed subpacket into a hashed subpacket list
singleHashedSub :: SigSubPacket -> HashedSubpackets v
singleHashedSub sp = SubpacketList [sp]

-- | Construct a single unhashed subpacket into an unhashed subpacket list
singleUnhashedSub :: SigSubPacket -> UnhashedSubpackets v
singleUnhashedSub sp = SubpacketList [sp]

-- | Prepend a subpacket to a hashed subpacket list
consHashedSub
    :: SigSubPacket -> HashedSubpackets v -> HashedSubpackets v
consHashedSub sp (SubpacketList sps) = SubpacketList (sp : sps)

{- | Controls how text payload is normalized for CanonicalTextSig.

RFC 9580 §5.2.1.2 requires only CRLF normalization for type 0x01
signatures.  Trailing-whitespace stripping is only mandated by
§7 (Cleartext Signature Framework).  Use 'CleartextCompat' for
GnuPG-compatible behaviour when producing cleartext-armored
signatures; use 'RFC9580Strict' for inline text signatures.
-}
data TextNormalizationMode
    = {- | CRLF normalization only; no trailing-whitespace stripping.
      Correct for inline type 0x01 document signatures.
      -}
      RFC9580Strict
    | {- | CRLF normalization *plus* per-line trailing-whitespace stripping.
      Required by the Cleartext Signature Framework (RFC 9580 §7).
      -}
      CleartextCompat
    deriving (Eq, Show)

{- | Staged signature builder that enforces completion order

Usage pattern:
  builder <- sigBuilderInit SigTypeBinary RSA SHA256
  builder' <- addHashedSubs hashedList builder
  finalPayload <- buildSigV4 sigMPIs (addUnhashedSubs unhashedList builder')
-}
data
    SigBuilder
        (hashedness :: Type)
        (v :: Type)
        (algo :: PubKeyAlgorithm)
    = SigBuilder
    { sbSigType :: SigType
    , sbHashAlgo :: HashAlgorithm
    , sbHashedSubs :: [SigSubPacket]
    , sbUnhashedSubs :: [SigSubPacket]
    , sbSalt :: BuilderSalt v
    , sbTextNormMode :: TextNormalizationMode
    {- ^ Normalization mode for CanonicalTextSig payloads.
    Defaults to 'CleartextCompat' for backward compatibility.
    -}
    }

type family BuilderSalt (v :: Type) where
    BuilderSalt V4Sig = ()
    BuilderSalt V6Sig = SignatureSalt

sbPubKeyAlgo
    :: forall hashedness v algo
     . KnownPubKeyAlgorithm algo
    => SigBuilder hashedness v algo -> PubKeyAlgorithm
sbPubKeyAlgo _ = demotePubKeyAlgorithmT (Proxy @algo)

{- | Initialize a builder for a v4 signature
Starts with no subpackets and must call addHashedSubs and addUnhashedSubs
-}
sigBuilderInit
    :: forall algo
     . KnownPubKeyAlgorithm algo
    => SigType
    -> HashAlgorithm
    -> SigBuilder Hashed V4Sig algo
sigBuilderInit st ha =
    SigBuilder
        { sbSigType = st
        , sbHashAlgo = ha
        , sbHashedSubs = []
        , sbUnhashedSubs = []
        , sbSalt = ()
        , sbTextNormMode = CleartextCompat
        }

-- | Initialize a builder for a v4 signature with compile-time RFC/hash policy enforcement.
sigBuilderInitTyped
    :: forall algo rfc h
     . (HashAlgoAllowedFor rfc h, KnownPubKeyAlgorithm algo)
    => OpenPGPRFCW rfc
    -> SigType
    -> HashAlgorithmW h
    -> SigBuilder Hashed V4Sig algo
sigBuilderInitTyped _ st hashW =
    sigBuilderInit @algo st (demoteHashAlgorithmW hashW)

{- | Initialize a v4 builder from runtime RFC/hash inputs with policy validation
and witness promotion at the API boundary.
-}
sigBuilderInitRuntime
    :: forall algo
     . KnownPubKeyAlgorithm algo
    => OpenPGPRFC
    -> SigType
    -> HashAlgorithm
    -> Either String (SigBuilder Hashed V4Sig algo)
sigBuilderInitRuntime rfc st ha =
    withGenerationHashWitness
        rfc
        ha
        (\rfcW hashW -> sigBuilderInitTyped @algo rfcW st hashW)

-- | Initialize a builder for a v6 signature
sigBuilderInitV6
    :: forall algo
     . KnownPubKeyAlgorithm algo
    => SigType
    -> HashAlgorithm
    -> SignatureSalt
    -> SigBuilder Hashed V6Sig algo
sigBuilderInitV6 st ha salt =
    SigBuilder
        { sbSigType = st
        , sbHashAlgo = ha
        , sbHashedSubs = []
        , sbUnhashedSubs = []
        , sbSalt = salt
        , sbTextNormMode = CleartextCompat
        }

-- | Initialize a builder for a v6 signature with compile-time RFC/hash policy enforcement.
sigBuilderInitV6Typed
    :: forall algo rfc h
     . (HashAlgoAllowedFor rfc h, KnownPubKeyAlgorithm algo)
    => OpenPGPRFCW rfc
    -> SigType
    -> HashAlgorithmW h
    -> SignatureSalt
    -> SigBuilder Hashed V6Sig algo
sigBuilderInitV6Typed _ st hashW salt =
    sigBuilderInitV6 @algo st (demoteHashAlgorithmW hashW) salt

{- | Initialize a v6 builder from runtime RFC/hash inputs with policy validation
and witness promotion at the API boundary.
-}
sigBuilderInitV6Runtime
    :: forall algo
     . KnownPubKeyAlgorithm algo
    => OpenPGPRFC
    -> SigType
    -> HashAlgorithm
    -> SignatureSalt
    -> Either String (SigBuilder Hashed V6Sig algo)
sigBuilderInitV6Runtime rfc st ha salt =
    withGenerationHashWitness
        rfc
        ha
        (\rfcW hashW -> sigBuilderInitV6Typed @algo rfcW st hashW salt)

withGenerationHashWitness
    :: OpenPGPRFC
    -> HashAlgorithm
    -> ( forall rfc h
          . HashAlgoAllowedFor rfc h
         => OpenPGPRFCW rfc -> HashAlgorithmW h -> a
       )
    -> Either String a
withGenerationHashWitness rfc ha mk
    | ha
        `elem` deprecatedHashAlgorithms
            (policyGenerationDeprecations (policyForRFC rfc)) =
        Left (hashPolicyDisallowedMessage rfc ha)
    | otherwise =
        case promoteHashAlgorithm ha of
            Nothing ->
                Left (hashNotTypedBuilderMessage ha)
            Just (SomeHashAlgorithmW hashW) ->
                case promoteOpenPGPRFC rfc of
                    SomeOpenPGPRFCW RFC2440W ->
                        Right $
                            case hashW of
                                DeprecatedMD5W -> mk RFC2440W DeprecatedMD5W
                                SHA1W -> mk RFC2440W SHA1W
                                RIPEMD160W -> mk RFC2440W RIPEMD160W
                                SHA256W -> mk RFC2440W SHA256W
                                SHA384W -> mk RFC2440W SHA384W
                                SHA512W -> mk RFC2440W SHA512W
                                SHA224W -> mk RFC2440W SHA224W
                                SHA3_256W -> mk RFC2440W SHA3_256W
                                SHA3_512W -> mk RFC2440W SHA3_512W
                    SomeOpenPGPRFCW RFC4880W ->
                        case hashW of
                            SHA1W -> Right (mk RFC4880W SHA1W)
                            RIPEMD160W -> Right (mk RFC4880W RIPEMD160W)
                            SHA256W -> Right (mk RFC4880W SHA256W)
                            SHA384W -> Right (mk RFC4880W SHA384W)
                            SHA512W -> Right (mk RFC4880W SHA512W)
                            SHA224W -> Right (mk RFC4880W SHA224W)
                            SHA3_256W -> Right (mk RFC4880W SHA3_256W)
                            SHA3_512W -> Right (mk RFC4880W SHA3_512W)
                            DeprecatedMD5W ->
                                Left (hashPolicyDisallowedMessage rfc ha)
                    SomeOpenPGPRFCW RFC9580W ->
                        case hashW of
                            SHA256W -> Right (mk RFC9580W SHA256W)
                            SHA384W -> Right (mk RFC9580W SHA384W)
                            SHA512W -> Right (mk RFC9580W SHA512W)
                            SHA224W -> Right (mk RFC9580W SHA224W)
                            SHA3_256W -> Right (mk RFC9580W SHA3_256W)
                            SHA3_512W -> Right (mk RFC9580W SHA3_512W)
                            DeprecatedMD5W ->
                                Left (hashPolicyDisallowedMessage rfc ha)
                            SHA1W ->
                                Left (hashPolicyDisallowedMessage rfc ha)
                            RIPEMD160W ->
                                Left (hashPolicyDisallowedMessage rfc ha)

hashPolicyDisallowedMessage
    :: OpenPGPRFC -> HashAlgorithm -> String
hashPolicyDisallowedMessage rfc ha =
    "signature hash algorithm disallowed by RFC policy ("
        ++ show rfc
        ++ "): "
        ++ show ha

hashNotTypedBuilderMessage :: HashAlgorithm -> String
hashNotTypedBuilderMessage ha =
    "signature hash algorithm is not supported by typed builder API: "
        ++ show ha

{- | Add hashed subpackets to a builder
Must be called before addUnhashedSubs
-}
addHashedSubs
    :: HashedSubpackets v
    -> SigBuilder Hashed v algo
    -> SigBuilder Unhashed v algo
addHashedSubs (SubpacketList sps) builder = builder {sbHashedSubs = sps}

{- | Add unhashed subpackets to a builder
Must be called after addHashedSubs
-}
addUnhashedSubs
    :: UnhashedSubpackets v
    -> SigBuilder Unhashed v algo
    -> SigBuilder Unhashed v algo
addUnhashedSubs (SubpacketList sps) builder = builder {sbUnhashedSubs = sps}

-- | Build a v4 signature from a completed builder and MPI values
buildSigV4
    :: KnownPubKeyAlgorithm algo
    => SigBuilder Unhashed V4Sig algo
    -> Word16
    -> NonEmpty MPI
    -> SignaturePayload
buildSigV4 builder hashLeft mpis =
    SigV4
        (sbSigType builder)
        (sbPubKeyAlgo builder)
        (sbHashAlgo builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        hashLeft
        mpis

-- | Build a v6 signature from a completed builder and MPI values
buildSigV6
    :: KnownPubKeyAlgorithm algo
    => SigBuilder Unhashed V6Sig algo
    -> Word16
    -> NonEmpty MPI
    -> SignaturePayload
buildSigV6 builder hashLeft mpis =
    SigV6
        (sbSigType builder)
        (sbPubKeyAlgo builder)
        (sbHashAlgo builder)
        (sbSalt builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        hashLeft
        mpis

{- | Convert a list to a hashed subpacket list
Used to bridge between list-based and phantom-typed APIs
-}
listToHashedSubs :: [SigSubPacket] -> HashedSubpackets v
listToHashedSubs sps = SubpacketList sps

{- | Convert a list to an unhashed subpacket list
Used to bridge between list-based and phantom-typed APIs
-}
listToUnhashedSubs :: [SigSubPacket] -> UnhashedSubpackets v
listToUnhashedSubs sps = SubpacketList sps