module Data.Conduit.OpenPGP.Keyring (
conduitToTKs
, conduitToTKsDropping
, sinkKeyringMap
) where
import qualified Data.ByteString as B
import Data.Conduit
import qualified Data.Conduit.Util as CU
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 Pkt m TK
conduitToTKs = conduitToTKs' True
conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK
conduitToTKsDropping = conduitToTKs' False
conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK
conduitToTKs' intolerant = CU.conduitState (MainKey, Nothing) push close
where
push state input = case (state, input) of
((MainKey, _), PublicKeyPkt pkp) -> return $ CU.StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) []
((MainKey, _), SecretKeyPkt pkp ska) -> return $ CU.StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) []
((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) []
((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) []
((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) []
((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) []
((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) []
((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ CU.StateProducing (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) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) []
((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) []
((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) []
((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ CU.StateProducing (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) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> return $ CU.StateProducing (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 s) -> case sType s of
SubkeyBindingSig -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setBSig s subs))) []
SubkeyRevocationSig -> return $ CU.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)), PublicKeyPkt p) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs]
((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) []
((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) []
((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) []
((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) []
((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) []
((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) []
((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) []
((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) []
((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) []
((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) []
((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)]))) []
((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> case sType s of
SubkeyBindingSig -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats (setBSig s subs))) []
SubkeyRevocationSig -> return $ CU.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)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs]
((_,_), TrustPkt _) -> return $ CU.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 -> CU.ConduitStateResult (Phase, Maybe TK) Pkt TK
dropOrError True _ e = error e
dropOrError False s _ = CU.StateProducing s []
sinkKeyringMap :: MonadResource m => Sink TK m Keyring
sinkKeyringMap = CU.sinkState Map.empty push close
where
push :: MonadResource m => Keyring -> TK -> m (CU.SinkStateResult Keyring TK Keyring)
push state input = return . CU.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 (PublicSubkeyPkt pkp) = pkp
pl (SecretSubkeyPkt pkp _) = pkp
newset eok i s = Set.insert i (oldset eok s)
oldset = Map.findWithDefault Set.empty