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 Data.Time.Clock (UTCTime)
import Data.List (foldl')

import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC)
import Codec.Encryption.OpenPGP.Signatures
  ( VerificationError(..)
  , verifyAgainstKeyring
  , verifySigWith
  )
import Codec.Encryption.OpenPGP.Types
import qualified Data.Conduit.List as CL

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 (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