-- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing
-- Copyright © 2012-2018  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
module Data.Conduit.OpenPGP.Keyring
  ( conduitToTKs
  , conduitToTKsDropping
  , sinkKeyringMap
  ) where

import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.IxSet.Typed (empty, insert)

import Codec.Encryption.OpenPGP.KeyringParser
  ( anyTK
  , finalizeParsing
  , parseAChunk
  )
import Codec.Encryption.OpenPGP.Ontology (isTrustPkt)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Keyring.Instances ()

data Phase
  = MainKey
  | Revs
  | Uids
  | UAts
  | Subs
  | SkippingBroken
  deriving (Eq, Ord, Show)

conduitToTKs :: Monad m => ConduitT Pkt TK m ()
conduitToTKs = conduitToTKs' True

conduitToTKsDropping :: Monad m => ConduitT Pkt TK m ()
conduitToTKsDropping = conduitToTKs' False

fakecmAccum ::
     Monad m
  => (accum -> (accum, [b]))
  -> (a -> accum -> (accum, [b]))
  -> accum
  -> ConduitT a b m ()
fakecmAccum finalizer f = loop
  where
    loop accum = await >>= maybe (mapM_ yield (snd (finalizer accum))) go
      where
        go a = do
          let (accum', bs) = f a accum
          mapM_ yield bs
          loop accum'

conduitToTKs' :: Monad m => Bool -> ConduitT Pkt TK m ()
conduitToTKs' intolerant =
  CL.filter notTrustPacket .| CL.map (: []) .|
  fakecmAccum
    finalizeParsing
    (parseAChunk (anyTK intolerant))
    ([], Just (Nothing, anyTK intolerant)) .|
  CL.catMaybes
  where
    notTrustPacket = not . isTrustPkt

sinkKeyringMap :: Monad m => ConduitT TK Void m Keyring
sinkKeyringMap = CL.fold (flip insert) empty