-- 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 (VerificationMode -> VerificationMode -> Bool
(VerificationMode -> VerificationMode -> Bool)
-> (VerificationMode -> VerificationMode -> Bool)
-> Eq VerificationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationMode -> VerificationMode -> Bool
== :: VerificationMode -> VerificationMode -> Bool
$c/= :: VerificationMode -> VerificationMode -> Bool
/= :: VerificationMode -> VerificationMode -> Bool
Eq, Int -> VerificationMode -> ShowS
[VerificationMode] -> ShowS
VerificationMode -> String
(Int -> VerificationMode -> ShowS)
-> (VerificationMode -> String)
-> ([VerificationMode] -> ShowS)
-> Show VerificationMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationMode -> ShowS
showsPrec :: Int -> VerificationMode -> ShowS
$cshow :: VerificationMode -> String
show :: VerificationMode -> String
$cshowList :: [VerificationMode] -> ShowS
showList :: [VerificationMode] -> ShowS
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 :: forall (m :: * -> *).
Monad m =>
PublicKeyring
-> Maybe UTCTime
-> ConduitT Pkt (Either VerificationError Verification) m ()
conduitVerify PublicKeyring
kr Maybe UTCTime
mt =
  (Pkt
 -> PktStreamContext
 -> (PktStreamContext, [Either VerificationError Verification]))
-> PktStreamContext
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall (m :: * -> *) a accum b.
Monad m =>
(a -> accum -> (accum, [b])) -> accum -> ConduitT a b m ()
CL.concatMapAccum (\Pkt
pkt PktStreamContext
state -> PublicKeyring
-> Maybe UTCTime
-> Pkt
-> PktStreamContext
-> (PktStreamContext, [Either VerificationError Verification])
pushPacketTyped PublicKeyring
kr Maybe UTCTime
mt Pkt
pkt PktStreamContext
state) PktStreamContext
emptyPSC

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

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

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

verifyPacketsWithModeTyped ::
     Monad m
  => VerificationModeW mode
  -> PublicKeyring
  -> Maybe UTCTime
  -> ConduitT Pkt (Either VerificationError Verification) m ()
verifyPacketsWithModeTyped :: forall (m :: * -> *) (mode :: VerificationMode).
Monad m =>
VerificationModeW mode
-> PublicKeyring
-> Maybe UTCTime
-> ConduitT Pkt (Either VerificationError Verification) m ()
verifyPacketsWithModeTyped VerificationModeW mode
modeW PublicKeyring
kr Maybe UTCTime
mt =
  case VerificationModeW mode
modeW of
    VerificationModeW mode
VerificationStreamingW -> PublicKeyring
-> Maybe UTCTime
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall (m :: * -> *).
Monad m =>
PublicKeyring
-> Maybe UTCTime
-> ConduitT Pkt (Either VerificationError Verification) m ()
conduitVerify PublicKeyring
kr Maybe UTCTime
mt
    VerificationModeW mode
VerificationBatchW -> ConduitT Pkt (Either VerificationError Verification) m [Pkt]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume ConduitT Pkt (Either VerificationError Verification) m [Pkt]
-> ([Pkt]
    -> ConduitT Pkt (Either VerificationError Verification) m ())
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall a b.
ConduitT Pkt (Either VerificationError Verification) m a
-> (a -> ConduitT Pkt (Either VerificationError Verification) m b)
-> ConduitT Pkt (Either VerificationError Verification) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either VerificationError Verification
 -> ConduitT Pkt (Either VerificationError Verification) m ())
-> [Either VerificationError Verification]
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Either VerificationError Verification
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ([Either VerificationError Verification]
 -> ConduitT Pkt (Either VerificationError Verification) m ())
-> ([Pkt] -> [Either VerificationError Verification])
-> [Pkt]
-> ConduitT Pkt (Either VerificationError Verification) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKeyring
-> Maybe UTCTime
-> [Pkt]
-> [Either VerificationError Verification]
verifyPacketsBatch PublicKeyring
kr Maybe UTCTime
mt

pushPacketTyped ::
     PublicKeyring
  -> Maybe UTCTime
  -> Pkt
  -> PktStreamContext
  -> (PktStreamContext, [Either VerificationError Verification])
pushPacketTyped :: PublicKeyring
-> Maybe UTCTime
-> Pkt
-> PktStreamContext
-> (PktStreamContext, [Either VerificationError Verification])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ ld :: Pkt
ld@LiteralDataPkt {} PktStreamContext
state = (PktStreamContext
state {lastLD = ld}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ uid :: Pkt
uid@(UserIdPkt Text
_) PktStreamContext
state = (PktStreamContext
state {lastUIDorUAt = uid}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ uat :: Pkt
uat@(UserAttributePkt [UserAttrSubPacket]
_) PktStreamContext
state = (PktStreamContext
state {lastUIDorUAt = uat}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ pk :: Pkt
pk@(PublicKeyPkt SomePKPayload
_) PktStreamContext
state = (PktStreamContext
state {lastPrimaryKey = pk}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ pk :: Pkt
pk@(PublicSubkeyPkt SomePKPayload
_) PktStreamContext
state = (PktStreamContext
state {lastSubkey = pk}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ sk :: Pkt
sk@(SecretKeyPkt SomePKPayload
_ SKAddendum
_) PktStreamContext
state = (PktStreamContext
state {lastPrimaryKey = sk}, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ sk :: Pkt
sk@(SecretSubkeyPkt SomePKPayload
_ SKAddendum
_) PktStreamContext
state = (PktStreamContext
state {lastSubkey = sk}, [])
pushPacketTyped PublicKeyring
kr Maybe UTCTime
mt sig :: Pkt
sig@(SignaturePkt SignaturePayload
signature) PktStreamContext
state =
  case SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV SignaturePayload
signature of
    Just VerifiableSignatureV
_ ->
      ( PktStreamContext
state {lastSig = sig}
      , [(Pkt
 -> Maybe UTCTime
 -> ByteString
 -> Either VerificationError Verification)
-> Pkt
-> PktStreamContext
-> Maybe UTCTime
-> Either VerificationError Verification
verifySigWith (PublicKeyring
-> Pkt
-> Maybe UTCTime
-> ByteString
-> Either VerificationError Verification
verifyAgainstKeyring PublicKeyring
kr) Pkt
sig PktStreamContext
state Maybe UTCTime
mt]
      )
    Maybe VerifiableSignatureV
Nothing -> (PktStreamContext
state, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ (OtherPacketPkt Word8
t ByteString
_) PktStreamContext
state | Word8
t Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
40 =
  (PktStreamContext
state, [VerificationError -> Either VerificationError Verification
forall a b. a -> Either a b
Left (Word8 -> VerificationError
UnknownCriticalPacketInStream Word8
t)])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ (BrokenPacketPkt String
err Word8
t ByteString
_) PktStreamContext
state | Word8
t Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
40 =
  (PktStreamContext
state, [VerificationError -> Either VerificationError Verification
forall a b. a -> Either a b
Left (Word8 -> String -> VerificationError
BrokenCriticalPacketInStream Word8
t String
err)])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ pkt :: Pkt
pkt@(OnePassSignaturePkt OnePassSignaturePayload
_) PktStreamContext
state
  | Pkt -> Bool
isOpeningOnePassSignature Pkt
pkt = (PktStreamContext
state, [])
pushPacketTyped PublicKeyring
_ Maybe UTCTime
_ Pkt
_ PktStreamContext
state = (PktStreamContext
state, [])

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

fromSignaturePayloadVerifiableSignatureV ::
     SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV :: SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV SignaturePayload
sigPayload =
  case SignaturePayload -> SomeSignaturePayload
toSomeSignaturePayload SignaturePayload
sigPayload of
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV4Data {}) ->
      VerifiableSignatureV -> Maybe VerifiableSignatureV
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV
VerifiableSignatureV4 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV4
payload)
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV6Data {}) ->
      VerifiableSignatureV -> Maybe VerifiableSignatureV
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV
VerifiableSignatureV6 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV6
payload)
    SomeSignaturePayload
_ -> Maybe VerifiableSignatureV
forall a. Maybe a
Nothing

isOpeningOnePassSignature :: Pkt -> Bool
isOpeningOnePassSignature :: Pkt -> Bool
isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 Word8
_ SigType
_ HashAlgorithm
_ PubKeyAlgorithm
_ EightOctetKeyId
_ Bool
False))) =
  Bool
True
isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 SigType
_ HashAlgorithm
_ PubKeyAlgorithm
_ SignatureSalt
_ ByteString
_ Bool
False))) =
  Bool
True
isOpeningOnePassSignature Pkt
_ = Bool
False