-- 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 (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}
            ,
                [ VerificationPolicy
-> (Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification)
-> Pkt
-> PktStreamContext
-> Maybe UTCTime
-> Either VerificationError Verification
verifySigWith
                    VerificationPolicy
defaultVerificationPolicy
                    (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