Filter.hs

-- Filter.hs: OpenPGP (RFC4880) packet filtering
-- Copyright © 2014-2020  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE GADTs #-}

module Data.Conduit.OpenPGP.Filter
  ( conduitPktFilter
  , conduitPktWithExtraFilter
  , conduitTKFilter
  , FilterPredicates(..)
  ) where

import Control.Monad.Trans.Reader (Reader, runReader)
import Data.Conduit (ConduitT)
import qualified Data.Conduit.List as CL
import Data.Void (Void)

import Codec.Encryption.OpenPGP.Types

data FilterPredicates r a
  = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys
  | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets
  | RFilterPredicate (Reader a Bool) -- ^ generic filter predicate
  | RPairFilterPredicate (Reader (r, a) Bool) -- ^ generic filter predicate with additional context

conduitPktFilter ::
     Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m ()
conduitPktFilter = CL.filter . superPredicate

superPredicate :: FilterPredicates Void Pkt -> Pkt -> Bool
superPredicate (RPFilterPredicate e) p = runReader e p
superPredicate (RFilterPredicate e) p = runReader e p
superPredicate _ _ = False -- do not match incorrect type of packet

conduitTKFilter :: Monad m => FilterPredicates Void TK -> ConduitT TK TK m ()
conduitTKFilter = CL.filter . superTKPredicate

superTKPredicate :: FilterPredicates Void TK -> TK -> Bool
superTKPredicate (RTKFilterPredicate e) = runReader e
superTKPredicate (RFilterPredicate e) = runReader e

conduitPktWithExtraFilter ::
     Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m ()
conduitPktWithExtraFilter extra = CL.filter . superPairPredicate extra

superPairPredicate :: r -> FilterPredicates r a -> a -> Bool
superPairPredicate r (RPairFilterPredicate e) p = runReader e (r, p)