WIP: encapsulation of KeyDB.

8 files changed, 85 insertions, 40 deletions

diff --git a/kiki.cabal b/kiki.cabal
index da5e0c7..dc3e1fd 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -75,7 +75,8 @@ library
                      FunctorToMaybe,
                      GnuPGAgent,
                      ByteStringUtil,
-                     IntMapClass
+                     IntMapClass,
+                     KeyDB
     other-modules:   TimeUtil,
                      ControlMaybe,
                      Compat,
diff --git a/kiki.hs b/kiki.hs
index 762825f..2379e74 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -58,6 +58,7 @@ import qualified SSHKey as SSH
 import qualified DNSKey as DNS
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
 import Kiki
+import KeyDB
 import Network.Socket (SockAddr)
 import FunctorToMaybe
 
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
new file mode 100644
index 0000000..f5a4357
--- /dev/null
+++ b/lib/KeyDB.hs
@@ -0,0 +1,58 @@
+module KeyDB
+    {-
+    ( TrustMap
+    , SigAndTrust
+    , SubKey(..)
+    , KeyData(..)
+    , KeyDB
+    , emptyKeyDB
+    , keyData
+    , transmute
+    ) -} where
+
+import Control.Monad
+import Data.Functor
+import qualified Data.Map.Strict as Map
+import Data.OpenPGP
+
+import FunctorToMaybe
+import KeyRing.Types
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
+data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
+
+-- | This is a GPG Identity which includes a master key and all its UIDs and
+-- subkeys and associated signatures.
+data KeyData = KeyData
+    { keyMappedPacket :: MappedPacket                               -- main key
+    , keySigAndTrusts :: [SigAndTrust]                              -- sigs on main key
+    , keyUids         :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
+    , keySubKeys      :: (Map.Map KeyKey SubKey)                    -- subkeys
+    } deriving Show
+
+
+data KeyDB = KeyDB
+    { byKeyKey :: Map.Map KeyKey KeyData
+    } deriving Show
+
+emptyKeyDB :: KeyDB
+emptyKeyDB = KeyDB { byKeyKey = Map.empty }
+
+keyData :: KeyDB -> [KeyData]
+keyData db = Map.elems (byKeyKey db)
+
+
+transmute :: (Monad m, Monad kiki, Traversable kiki) =>
+       ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
+       -> (KeyData -> [opcode])                                    -- ^ instructions
+       -> KeyDB                                                    -- ^ initial state
+       -> m (kiki (KeyDB, [info]))
+transmute perform update db = do
+    let performAll kd = foldM (\kkd op -> join <$> mapM (`perform` op) kkd)
+                              (pure (kd,[]))
+                              (update kd)
+    r <- sequenceA <$> mapM performAll (byKeyKey db)
+    return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk }
+                           , concatMap snd $ Map.elems bkk )
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 3b9afd7..1d52dd1 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -89,6 +89,7 @@ import           KeyRing.BuildKeyDB          (Hostnames(..),
                                               usageFromFilter)
 
 import KeyRing.Types
+import KeyDB
 import PacketTranscoder
 import Transforms
 
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 943578f..8af8198 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -72,6 +72,7 @@ import           ScanningParser
 import           TimeUtil
 
 import           KeyRing.Types
+import           KeyDB
 import           Transforms
 import           PacketTranscoder
 import           GnuPGAgent
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 0797dab..3c1f0a5 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -1,8 +1,10 @@
-{-# LANGUAGE DeriveFunctor   #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE PatternSynonyms   #-}
 module KeyRing.Types where
 
 import           Data.Char (isLower,toLower)
+import           Data.Functor
 import           Data.List (groupBy,find)
 import           Data.Map as Map (Map)
 import qualified Data.Map as Map
@@ -272,7 +274,7 @@ data KikiCondition a = KikiSuccess a
     | NoWorkingKey
     | AgentConnectionFailure
     | OperationCanceled
- deriving ( Functor, Show )
+ deriving ( Functor, Foldable, Traversable, Show )
 
 instance FunctorToMaybe KikiCondition where
     functorToMaybe (KikiSuccess a) = Just a
@@ -287,6 +289,11 @@ instance Applicative KikiCondition where
                             Left err -> err
             Left err -> err
 
+instance Monad KikiCondition where
+    return = pure
+    KikiSuccess a >>= f = f a
+    kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f")
+
 uncamel :: String -> String
 uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
   where
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 579640a..e5c4eb4 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -48,6 +48,7 @@ import           CommandLine
 import           DotLock
 import           GnuPGAgent                 (Query (..))
 import           KeyRing hiding (pemFromPacket)
+import           KeyDB
 
 withAgent :: [PassphraseSpec] -> [PassphraseSpec]
 withAgent [] = [PassphraseAgent]
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 3e13b1a..0a3a9a6 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -9,12 +9,14 @@ import Control.Applicative
 import Control.Arrow
 import Control.Monad
 import Data.Char
+import Data.Functor
 import Data.List
 import Data.Maybe
 import Data.Ord
 import Data.OpenPGP
 import Data.OpenPGP.Util
 import Data.Word
+import KeyDB
 import KeyRing.Types
 import FunctorToMaybe
 import GnuPGAgent ( key_nbits )
@@ -38,27 +40,6 @@ import qualified Data.Text as T ( Text, unpack, pack,
 import Data.Text.Encoding ( encodeUtf8 )
 import Data.Bits              ((.|.), (.&.), Bits)
 
-type TrustMap = Map.Map FilePath Packet
-type SigAndTrust = ( MappedPacket
-                   , TrustMap     ) -- trust packets
-data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
-
--- | This is a GPG Identity which includes a master key and all its UIDs and
--- subkeys and associated signatures.
-data KeyData = KeyData
-    { keyMappedPacket :: MappedPacket                               -- main key
-    , keySigAndTrusts :: [SigAndTrust]                              -- sigs on main key
-    , keyUids         :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
-    , keySubKeys      :: (Map.Map KeyKey SubKey)                    -- subkeys
-    } deriving Show
-
-data KeyDB = KeyDB
-    { byKeyKey :: Map.Map KeyKey KeyData
-    } deriving Show
-
-emptyKeyDB :: KeyDB
-emptyKeyDB = KeyDB { byKeyKey = Map.empty }
-
 
 data KeyRingRuntime = KeyRingRuntime
     { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub'
@@ -765,7 +746,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
 
 -- TODO: Use fingerprint to narrow candidates.
 candidateSignerKeys :: KeyDB -> Packet -> [Packet]
-candidateSignerKeys db sig = map keyPacket $ Map.elems (byKeyKey db)
+candidateSignerKeys db sig = map keyPacket $ keyData db
 
 performManipulations ::
                 (PacketDecrypter)
@@ -775,18 +756,14 @@ performManipulations ::
                 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
 performManipulations doDecrypt rt wk manip = do
     let db = rtKeyDB rt
-        performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
-    r <- Traversable.mapM performAll (byKeyKey db)
-    try (sequenceA r) $ \db -> do
-    return $ KikiSuccess ( rt { rtKeyDB = (rtKeyDB rt) { byKeyKey = fmap fst db } }
-                         , concatMap snd $ Map.elems db)
+    r <- transmute perform (manip rt) db
+    return $ r <&> \(db,rs) -> (rt { rtKeyDB = db }, rs)
  where
-    perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
-    perform kd (InducerSignature uid subpaks) = do
-        try kd $ \(kd,report) -> do
+    perform :: (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
+    perform (kd,report) (InducerSignature uid subpaks) = do
         flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
         wkun' <- doDecrypt wk'
-        try wkun' $ \wkun -> do    
+        try wkun' $ \wkun -> do
         let flgs = if keykey (keyPacket kd) == keykey wkun
                     then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
                     else []
@@ -799,7 +776,7 @@ performManipulations doDecrypt rt wk manip = do
             selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
                                    . (== keykey whosign)
                                    . keykey)) vs
-            keys = map keyPacket $ Map.elems (byKeyKey $ rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig
+            keys = map keyPacket $ keyData (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig
             overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig])
             vs :: [ ( Packet -- signature
                    , Maybe SignatureOver -- Nothing means non-verified
@@ -825,8 +802,7 @@ performManipulations doDecrypt rt wk manip = do
         -- XXX: Shouldn't this signature generation show up in the KikiReport ?
         return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
 
-    perform kd (SubKeyDeletion topk subk) = do
-        try kd $ \(kd,report) -> do
+    perform (kd,report) (SubKeyDeletion topk subk) = do
         let kk = keykey $ packet $ keyMappedPacket kd
             kd' | kk /= topk = kd
                 | otherwise  = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
@@ -839,8 +815,7 @@ performManipulations doDecrypt rt wk manip = do
         return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
 
     -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
-    perform kd (SubKeyRenaming srctag dsttag) = do
-        try kd $ \(kd,report) -> do
+    perform (kd,report) (SubKeyRenaming srctag dsttag) = do
         flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
         subkeys' <- traverse (freshenOne wk') (keySubKeys kd)
         let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport))