-- 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 (Phase -> Phase -> Bool
(Phase -> Phase -> Bool) -> (Phase -> Phase -> Bool) -> Eq Phase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Phase -> Phase -> Bool
== :: Phase -> Phase -> Bool
$c/= :: Phase -> Phase -> Bool
/= :: Phase -> Phase -> Bool
Eq, Eq Phase
Eq Phase =>
(Phase -> Phase -> Ordering)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Phase)
-> (Phase -> Phase -> Phase)
-> Ord Phase
Phase -> Phase -> Bool
Phase -> Phase -> Ordering
Phase -> Phase -> Phase
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Phase -> Phase -> Ordering
compare :: Phase -> Phase -> Ordering
$c< :: Phase -> Phase -> Bool
< :: Phase -> Phase -> Bool
$c<= :: Phase -> Phase -> Bool
<= :: Phase -> Phase -> Bool
$c> :: Phase -> Phase -> Bool
> :: Phase -> Phase -> Bool
$c>= :: Phase -> Phase -> Bool
>= :: Phase -> Phase -> Bool
$cmax :: Phase -> Phase -> Phase
max :: Phase -> Phase -> Phase
$cmin :: Phase -> Phase -> Phase
min :: Phase -> Phase -> Phase
Ord, Int -> Phase -> ShowS
[Phase] -> ShowS
Phase -> String
(Int -> Phase -> ShowS)
-> (Phase -> String) -> ([Phase] -> ShowS) -> Show Phase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Phase -> ShowS
showsPrec :: Int -> Phase -> ShowS
$cshow :: Phase -> String
show :: Phase -> String
$cshowList :: [Phase] -> ShowS
showList :: [Phase] -> ShowS
Show)

conduitToTKs :: Monad m => ConduitT Pkt TK m ()
conduitToTKs :: forall (m :: * -> *). Monad m => ConduitT Pkt TK m ()
conduitToTKs = Bool -> ConduitT Pkt TK m ()
forall (m :: * -> *). Monad m => Bool -> ConduitT Pkt TK m ()
conduitToTKs' Bool
True

conduitToTKsDropping :: Monad m => ConduitT Pkt TK m ()
conduitToTKsDropping :: forall (m :: * -> *). Monad m => ConduitT Pkt TK m ()
conduitToTKsDropping = Bool -> ConduitT Pkt TK m ()
forall (m :: * -> *). Monad m => Bool -> ConduitT Pkt TK m ()
conduitToTKs' Bool
False

fakecmAccum ::
     Monad m
  => (accum -> (accum, [b]))
  -> (a -> accum -> (accum, [b]))
  -> accum
  -> ConduitT a b m ()
fakecmAccum :: forall (m :: * -> *) accum b a.
Monad m =>
(accum -> (accum, [b]))
-> (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m ()
fakecmAccum accum -> (accum, [b])
finalizer a -> accum -> (accum, [b])
f = accum -> ConduitT a b m ()
forall {m :: * -> *}. Monad m => accum -> ConduitT a b m ()
loop
  where
    loop :: accum -> ConduitT a b m ()
loop accum
accum = ConduitT a b m (Maybe a)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT a b m (Maybe a)
-> (Maybe a -> ConduitT a b m ()) -> ConduitT a b m ()
forall a b.
ConduitT a b m a -> (a -> ConduitT a b m b) -> ConduitT a b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT a b m ()
-> (a -> ConduitT a b m ()) -> Maybe a -> ConduitT a b m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((b -> ConduitT a b m ()) -> [b] -> ConduitT a b m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ b -> ConduitT a b m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ((accum, [b]) -> [b]
forall a b. (a, b) -> b
snd (accum -> (accum, [b])
finalizer accum
accum))) a -> ConduitT a b m ()
go
      where
        go :: a -> ConduitT a b m ()
go a
a = do
          let (accum
accum', [b]
bs) = a -> accum -> (accum, [b])
f a
a accum
accum
          (b -> ConduitT a b m ()) -> [b] -> ConduitT a b m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ b -> ConduitT a b m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [b]
bs
          accum -> ConduitT a b m ()
loop accum
accum'

conduitToTKs' :: Monad m => Bool -> ConduitT Pkt TK m ()
conduitToTKs' :: forall (m :: * -> *). Monad m => Bool -> ConduitT Pkt TK m ()
conduitToTKs' Bool
intolerant =
  (Pkt -> Bool) -> ConduitT Pkt Pkt m ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter Pkt -> Bool
notTrustPacket ConduitT Pkt Pkt m ()
-> ConduitT Pkt TK m () -> ConduitT Pkt TK m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Pkt -> [Pkt]) -> ConduitT Pkt [Pkt] m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (Pkt -> [Pkt] -> [Pkt]
forall a. a -> [a] -> [a]
: []) ConduitT Pkt [Pkt] m ()
-> ConduitT [Pkt] TK m () -> ConduitT Pkt TK m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
  (([(Maybe TK, [Pkt])],
  Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK)))
 -> (([(Maybe TK, [Pkt])],
      Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))),
     [Maybe TK]))
-> ([Pkt]
    -> ([(Maybe TK, [Pkt])],
        Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK)))
    -> (([(Maybe TK, [Pkt])],
         Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))),
        [Maybe TK]))
-> ([(Maybe TK, [Pkt])],
    Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK)))
-> ConduitT [Pkt] (Maybe TK) m ()
forall (m :: * -> *) accum b a.
Monad m =>
(accum -> (accum, [b]))
-> (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m ()
fakecmAccum
    ([(Maybe TK, [Pkt])],
 Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK)))
-> (([(Maybe TK, [Pkt])],
     Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))),
    [Maybe TK])
forall s r.
Monoid s =>
([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsing
    (Parser [Pkt] (Maybe TK)
-> [Pkt]
-> ([(Maybe TK, [Pkt])],
    Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK)))
-> (([(Maybe TK, [Pkt])],
     Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))),
    [Maybe TK])
forall s r.
(Monoid s, Show s) =>
Parser s r
-> s
-> ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
parseAChunk (Bool -> Parser [Pkt] (Maybe TK)
anyTK Bool
intolerant))
    ([], (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))
-> Maybe (Maybe (Maybe TK -> Maybe TK), Parser [Pkt] (Maybe TK))
forall a. a -> Maybe a
Just (Maybe (Maybe TK -> Maybe TK)
forall a. Maybe a
Nothing, Bool -> Parser [Pkt] (Maybe TK)
anyTK Bool
intolerant)) ConduitT [Pkt] (Maybe TK) m ()
-> ConduitT (Maybe TK) TK m () -> ConduitT [Pkt] TK m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
  ConduitT (Maybe TK) TK m ()
forall (m :: * -> *) a. Monad m => ConduitT (Maybe a) a m ()
CL.catMaybes
  where
    notTrustPacket :: Pkt -> Bool
notTrustPacket = Bool -> Bool
not (Bool -> Bool) -> (Pkt -> Bool) -> Pkt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkt -> Bool
isTrustPkt

sinkKeyringMap :: Monad m => ConduitT TK Void m Keyring
sinkKeyringMap :: forall (m :: * -> *). Monad m => ConduitT TK Void m Keyring
sinkKeyringMap = (Keyring -> TK -> Keyring) -> Keyring -> ConduitT TK Void m Keyring
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold ((TK -> Keyring -> Keyring) -> Keyring -> TK -> Keyring
forall a b c. (a -> b -> c) -> b -> a -> c
flip TK -> Keyring -> Keyring
forall (ixs :: [*]) a.
Indexable ixs a =>
a -> IxSet ixs a -> IxSet ixs a
insert) Keyring
forall (ixs :: [*]) a. Indexable ixs a => IxSet ixs a
empty