    -- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing
    -- Copyright © 2012-2014  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 qualified Data.ByteString as B
    import Data.Conduit
    import qualified Data.Conduit.List as CL
    import Data.IxSet (empty, insert)
    import Data.Foldable (traverse_)

    import Codec.Encryption.OpenPGP.Internal (sigType)
    import Codec.Encryption.OpenPGP.Types
    import Data.Conduit.OpenPGP.Keyring.Instances ()

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

    conduitToTKs :: MonadResource m => Conduit Pkt m TK
    conduitToTKs = conduitToTKs' True

    conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK
    conduitToTKsDropping = conduitToTKs' False

    fakecmAccum :: Monad m => (a -> (Phase, Maybe TK) -> ((Phase, Maybe TK), [TK])) -> (Phase, Maybe TK) -> Conduit a m TK
    fakecmAccum f =
        loop
      where
        loop accum =
            await >>= maybe (finalyield accum) go
          where
            go a = do
                let (accum', bs) = f a accum
                Prelude.mapM_ yield bs
                loop accum'
            finalyield = traverse_ yield . snd

    conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK
    conduitToTKs' intolerant = fakecmAccum push (MainKey, Nothing)
        where
            push i s = case (s, i) of
                           ((MainKey, _), PublicKeyPkt pkp) -> ((Revs, Just (TK pkp Nothing [] [] [] [])), [])
                           ((MainKey, _), SecretKeyPkt pkp ska) -> ((Revs, Just (TK pkp (Just ska) [] [] [] [])), [])
                           ((MainKey, _), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [])
                           ((MainKey, _), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [])
                           ((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp Nothing (revs ++ [sp]) uids uats subs)), [])
                           ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)), [])
                           ((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp Nothing revs (addUidSig sp uids) uats subs)), [])
                           ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), [])
                           ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)), [])
                           ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])), [])
                           ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])
                           ((Uids, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])
                           ((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp Nothing revs uids (addUAtSig sp uats) subs)), [])
                           ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)), [])
                           ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), [])
                           ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])), [])
                           ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])
                           ((UAts, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])
                           ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)]))), [])
                           ((Subs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> case sigType sp of
                                                                                    Just SubkeyBindingSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setBSig sp subs))), [])
                                                                                    Just SubkeyRevocationSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setRSig sp subs))), [])
                                                                                    _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i
                           ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])
                           ((Subs, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])
                           ((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp mska (revs ++ [sp]) uids uats subs)), [])
                           ((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs [(u, [])] uats subs)), [])
                           ((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp mska revs (addUidSig sp uids) uats subs)), [])
                           ((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), [])
                           ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids [(u, [])] subs)), [])
                           ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), [])
                           ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [TK pkp mska revs uids uats subs])
                           ((Uids, Just (TK pkp mska revs uids uats subs)), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [TK pkp mska revs uids uats subs])
                           ((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp mska revs uids (addUAtSig sp uats) subs)), [])
                           ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)), [])
                           ((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), [])
                           ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), [])
                           ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p ss) -> ((Revs, Just (TK p (Just ss) [] [] [] [])), [TK pkp mska revs uids uats subs])
                           ((UAts, Just (TK pkp mska revs uids uats subs)), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [TK pkp mska revs uids uats subs])
                           ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)]))), [])
                           ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> case sigType sp of
                                                                                    Just SubkeyBindingSig -> ((Subs, Just (TK pkp mska revs uids uats (setBSig sp subs))), [])
                                                                                    Just SubkeyRevocationSig -> ((Subs, Just (TK pkp mska revs uids uats (setRSig sp subs))), [])
                                                                                    _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i
                           ((Subs, Just tk), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [tk])
                           ((Subs, Just tk), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [tk])
                           ((SkippingBroken, _), PublicKeyPkt pkp) -> ((Revs, Just (TK pkp Nothing [] [] [] [])), [])
                           ((SkippingBroken, _), SecretKeyPkt pkp ska) -> ((Revs, Just (TK pkp (Just ska) [] [] [] [])), [])
                           ((SkippingBroken, _), _) -> (s, [])
                           ((_,_), TrustPkt _) -> (s, [])
                           _ -> dropOrError intolerant s $ "Unexpected packet: " ++ show (fst s) ++ "/" ++ show i
            addUidSig s uids = init uids ++ [(\(u, us) -> (u, us ++ [s])) (last uids)]
            addUAtSig s uats = init uats ++ [(\(u, us) -> (u, us ++ [s])) (last uats)]
            setBSig s subs = init subs ++ [(\(p, _, r) -> (p, s, r)) (last subs)]
            setRSig s subs = init subs ++ [(\(p, b, _) -> (p, b, Just s)) (last subs)]
            dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ((Phase, Maybe TK), [TK])
            dropOrError True _ e = error e
            dropOrError False s _ = (s, [])

    sinkKeyringMap :: MonadResource m => Sink TK m Keyring
    sinkKeyringMap = CL.fold (flip insert) empty