-- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing
-- Copyright Ⓒ 2012  Clint Adams
-- This software is released under the terms of the Expat (MIT) license.
-- (See the LICENSE file).

module Data.Conduit.OpenPGP.Keyring (
   conduitToTKs
 , sinkKeyringMap
) where

import qualified Data.ByteString as B
import Data.Conduit

import Data.Map (Map)
import qualified Data.Map as Map

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

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

conduitToTKs :: Resource m => Conduit Packet m TK
conduitToTKs = conduitState (MainKey, NoTK) push close
    where
        push state input = case (state, input) of
                               ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, TPK pkp [] [] [] []) []
                               ((MainKey, _), SecretKey pkp ska) -> return $ StateProducing (Revs, TSK (SecretKey pkp ska) [] [] [] []) []
                               ((Revs, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (Revs, TPK pkp (revs ++ [s]) uids uats subs) []
                               ((Revs, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs [(u, [])] uats subs) []
                               ((Uids, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (Uids, TPK pkp revs (addUidSig s uids) uats subs) []
                               ((Uids, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs (uids ++ [(u, [])]) uats subs) []
                               ((Uids, TPK pkp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TPK pkp revs uids [(u, [])] subs) []
                               ((Uids, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats [(p, SigVOther 0 B.empty, Nothing)]) []
                               ((Uids, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]
                               ((UAts, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (UAts, TPK pkp revs uids (addUAtSig s uats) subs) []
                               ((UAts, TPK pkp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TPK pkp revs uids (uats ++ [(u, [])]) subs) []
                               ((UAts, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs (uids ++ [(u, [])]) uats subs) []
                               ((UAts, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats [(p, SigVOther 0 B.empty, Nothing)]) []
                               ((UAts, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]
                               ((Subs, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats (subs ++ [(p, SigVOther 0 B.empty, Nothing)])) []
                               ((Subs, TPK pkp revs uids uats subs), Signature s) -> case sType s of
                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, TPK pkp revs uids uats (setBSig s subs)) []
                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, TPK pkp revs uids uats (setRSig s subs)) []
                                                                                        otherwise -> error $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input
                               ((Subs, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]
                               ((Revs, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (Revs, TSK skp (revs ++ [s]) uids uats subs) []
                               ((Revs, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs [(u, [])] uats subs) []
                               ((Uids, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (Uids, TSK skp revs (addUidSig s uids) uats subs) []
                               ((Uids, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs (uids ++ [(u, [])]) uats subs) []
                               ((Uids, TSK skp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TSK skp revs uids [(u, [])] subs) []
                               ((Uids, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]) []
                               ((Uids, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]
                               ((UAts, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (UAts, TSK skp revs uids (addUAtSig s uats) subs) []
                               ((UAts, TSK skp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TSK skp revs uids (uats ++ [(u, [])]) subs) []
                               ((UAts, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs (uids ++ [(u, [])]) uats subs) []
                               ((UAts, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]) []
                               ((UAts, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]
                               ((Subs, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats (subs ++ [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) []
                               ((Subs, TSK skp revs uids uats subs), Signature s) -> case sType s of
                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, TSK skp revs uids uats (setBSig s subs)) []
                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, TSK skp revs uids uats (setRSig s subs)) []
                                                                                        otherwise -> error $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input
                               ((Subs, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]
                               ((_,_), Trust _) -> return $ StateProducing state []
                               otherwise -> error $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input
        close (_, 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, b, r) -> (p, s, r)) (last subs)]
        setRSig s subs = init subs ++ [(\(p, b, r) -> (p, b, Just s)) (last subs)]
        sType (SigV3 st _ _ _ _ _ _) = st
        sType (SigV4 st _ _ _ _ _ _) = st


sinkKeyringMap :: Resource m => Sink TK m (Map EightOctetKeyId TK)
sinkKeyringMap = sinkState Map.empty push close
    where
        push :: Resource m => Map EightOctetKeyId TK -> TK -> ResourceT m (SinkStateResult (Map EightOctetKeyId TK) TK (Map EightOctetKeyId TK))
        push state input = return $ StateProcessing $ Map.insert (eok input) input state
        close state = return state
        eok (TPK pkp _ _ _ _) = eightOctetKeyID pkp
        eok (TSK (SecretKey p s) _ _ _ _) = eightOctetKeyID p