-- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing
-- Copyright © 2012  Clint Adams
-- This software is released under the terms of the ISC 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.Map as Map
import qualified Data.Set as Set

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID)
import Codec.Encryption.OpenPGP.Types

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

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

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

conduitToTKs' :: MonadResource m => Bool -> Conduit Packet m TK
conduitToTKs' intolerant = conduitState (MainKey, Nothing) push close
    where
        push state input = case (state, input) of
                               ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) []
                               ((MainKey, _), SecretKey pkp ska) -> return $ StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) []
                               ((Revs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) []
                               ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) []
                               ((Uids, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) []
                               ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) []
                               ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) []
                               ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) []
                               ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
                               ((UAts, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) []
                               ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) []
                               ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) []
                               ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) []
                               ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
                               ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkey p, SigVOther 0 B.empty, Nothing)]))) []
                               ((Subs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> case sType s of
                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setBSig s subs))) []
                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setRSig s subs))) []
                                                                                        _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input)
                               ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
                               ((Revs, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) []
                               ((Revs, Just (TK pkp mska revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) []
                               ((Uids, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) []
                               ((Uids, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) []
                               ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) []
                               ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) []
                               ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
                               ((UAts, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) []
                               ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) []
                               ((UAts, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) []
                               ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) []
                               ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
                               ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]))) []
                               ((Subs, Just (TK pkp mska revs uids uats subs)), Signature s) -> case sType s of
                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setBSig s subs))) []
                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setRSig s subs))) []
                                                                                        _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input)
                               ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
                               ((_,_), Trust _) -> return $ StateProducing state []
                               _ -> return (dropOrError intolerant state $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input)
        close (_, Nothing) = return []
        close (_, Just tk) = return [tk]
        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)]
        sType (SigV3 st _ _ _ _ _ _) = st
        sType (SigV4 st _ _ _ _ _ _) = st
        sType _ = error "This should never happen."
        dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ConduitStateResult (Phase, Maybe TK) Packet TK
        dropOrError True _ e = error e
        dropOrError False s _ = StateProducing s []

sinkKeyringMap :: MonadResource m => Sink TK m Keyring
sinkKeyringMap = sinkState Map.empty push close
    where
        push :: MonadResource m => Keyring -> TK -> m (SinkStateResult Keyring TK Keyring)
        push state input = return . StateProcessing $ foldl (\m x -> Map.insert x (newset x input m) m) state (eoks input)
        close = return
        eoks (TK pkp _ _ _ _ subs) = (eightOctetKeyID pkp):map (eightOctetKeyID . pl . \(x,_,_) -> x) subs
        pl (PublicSubkey pkp) = pkp
        pl (SecretSubkey pkp _) = pkp
        newset eok i s = Set.insert i (oldset eok s)
        oldset = Map.findWithDefault Set.empty