Verify.hs

-- Verify.hs: OpenPGP (RFC9580) signature verification
-- 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 #-}

module Data.Conduit.OpenPGP.Verify
    ( VerificationMode (..)
    , VerificationModeW (..)
    , conduitVerify
    , verifyPacketsBatch
    , verifyPacketsWithModeTyped
    , verifyPacketsWithMode
    ) where

import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Time.Clock (UTCTime)

import Codec.Encryption.OpenPGP.Internal
    ( PktStreamContext (..)
    , emptyPSC
    )
import Codec.Encryption.OpenPGP.Policy
    ( defaultVerificationPolicy
    )
import Codec.Encryption.OpenPGP.Signatures
    ( VerificationError (..)
    , verifyAgainstKeyring
    , verifySigWith
    )
import Codec.Encryption.OpenPGP.Types

data VerificationMode
    = VerificationStreaming
    | VerificationBatch
    deriving (Eq, Show)

data VerificationModeW (mode :: VerificationMode) where
    VerificationStreamingW
        :: VerificationModeW 'VerificationStreaming
    VerificationBatchW :: VerificationModeW 'VerificationBatch

conduitVerify
    :: Monad m
    => PublicKeyring
    -> Maybe UTCTime
    -> ConduitT Pkt (Either VerificationError Verification) m ()
conduitVerify kr mt =
    CL.concatMapAccum
        (\pkt state -> pushPacketTyped kr mt pkt state)
        emptyPSC

verifyPacketsBatch
    :: PublicKeyring
    -> Maybe UTCTime
    -> [Pkt]
    -> [Either VerificationError Verification]
verifyPacketsBatch kr mt =
    verifyPacketsBatchTyped kr mt

verifyPacketsBatchTyped
    :: PublicKeyring
    -> Maybe UTCTime
    -> [Pkt]
    -> [Either VerificationError Verification]
verifyPacketsBatchTyped kr mt =
    reverse . snd . foldl' step (emptyPSC, [])
  where
    step (state, outputs) pkt =
        let (nextState, newOutputs) = pushPacketTyped kr mt pkt state
         in (nextState, reverse newOutputs ++ outputs)

verifyPacketsWithMode
    :: Monad m
    => VerificationMode
    -> PublicKeyring
    -> Maybe UTCTime
    -> ConduitT Pkt (Either VerificationError Verification) m ()
verifyPacketsWithMode VerificationStreaming kr mt =
    verifyPacketsWithModeTyped VerificationStreamingW kr mt
verifyPacketsWithMode VerificationBatch kr mt =
    verifyPacketsWithModeTyped VerificationBatchW kr mt

verifyPacketsWithModeTyped
    :: Monad m
    => VerificationModeW mode
    -> PublicKeyring
    -> Maybe UTCTime
    -> ConduitT Pkt (Either VerificationError Verification) m ()
verifyPacketsWithModeTyped modeW kr mt =
    case modeW of
        VerificationStreamingW -> conduitVerify kr mt
        VerificationBatchW -> CL.consume >>= mapM_ yield . verifyPacketsBatch kr mt

pushPacketTyped
    :: PublicKeyring
    -> Maybe UTCTime
    -> Pkt
    -> PktStreamContext
    -> (PktStreamContext, [Either VerificationError Verification])
pushPacketTyped _ _ ld@LiteralDataPkt {} state = (state {lastLD = ld}, [])
pushPacketTyped _ _ uid@(UserIdPkt _) state = (state {lastUIDorUAt = uid}, [])
pushPacketTyped _ _ uat@(UserAttributePkt _) state = (state {lastUIDorUAt = uat}, [])
pushPacketTyped _ _ pk@(PublicKeyPkt _) state = (state {lastPrimaryKey = pk}, [])
pushPacketTyped _ _ pk@(PublicSubkeyPkt _) state = (state {lastSubkey = pk}, [])
pushPacketTyped _ _ sk@(SecretKeyPkt _ _) state = (state {lastPrimaryKey = sk}, [])
pushPacketTyped _ _ sk@(SecretSubkeyPkt _ _) state = (state {lastSubkey = sk}, [])
pushPacketTyped kr mt sig@(SignaturePkt signature) state =
    case fromSignaturePayloadVerifiableSignatureV signature of
        Just _ ->
            ( state {lastSig = sig}
            ,
                [ verifySigWith
                    defaultVerificationPolicy
                    (verifyAgainstKeyring kr)
                    sig
                    state
                    mt
                ]
            )
        Nothing -> (state, [])
pushPacketTyped _ _ (OtherPacketPkt t _) state
    | t < 40 =
        (state, [Left (UnknownCriticalPacketInStream t)])
pushPacketTyped _ _ (BrokenPacketPkt err t _) state
    | t < 40 =
        (state, [Left (BrokenCriticalPacketInStream t err)])
pushPacketTyped _ _ pkt@(OnePassSignaturePkt _) state
    | isOpeningOnePassSignature pkt = (state, [])
pushPacketTyped _ _ _ state = (state, [])

data VerifiableSignatureV where
    VerifiableSignatureV4
        :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV
    VerifiableSignatureV6
        :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV

fromSignaturePayloadVerifiableSignatureV
    :: SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV sigPayload =
    case toSomeSignaturePayload sigPayload of
        SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
            Just (VerifiableSignatureV4 payload)
        SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
            Just (VerifiableSignatureV6 payload)
        _ -> Nothing

isOpeningOnePassSignature :: Pkt -> Bool
isOpeningOnePassSignature
    ( OnePassSignaturePkt
            (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False))
        ) =
        True
isOpeningOnePassSignature
    ( OnePassSignaturePkt
            (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False))
        ) =
        True
isOpeningOnePassSignature _ = False