reorganized cross_merge to use runKeyring

2 files changed, 100 insertions, 44 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 089b25a..7073e43 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1,15 +1,18 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
 module KeyRing where
 
 import System.Environment
 import Control.Monad
-import Control.Applicative
 import Data.Maybe
 import Data.Char
-import System.Directory ( getHomeDirectory, doesFileExist )
-import Control.Arrow    ( first, second )
+import Data.List
+import Control.Applicative ( (<$>) )
+import System.Directory    ( getHomeDirectory, doesFileExist )
+import Control.Arrow       ( first, second )
+
+import DotLock
 
 data HomeDir =
     HomeDir { homevar :: String
@@ -23,12 +26,77 @@ home = HomeDir
     , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
     }
 
-data KeyRing
+data InputFile = HomeSec | HomePub | ArgFile FilePath
+
+data KeyRingRuntime = KeyRingRuntime
+                        { rtPubring :: FilePath
+                        , rtSecring :: FilePath
+                        , rtRings :: [FilePath]
+                        , rtWallets :: [FilePath]
+                        , rtGrip :: Maybe String
+                        }
+
+data KeyRingData a = KeyRingData
+    { filesToLock :: [InputFile]
+    , homeSpec :: Maybe String
+    , kaction :: KeyRingRuntime -> IO a
+    , keyringFiles :: [FilePath]
+    , walletFiles :: [FilePath]
+    }
 
 todo = error "unimplemented"
 
-loadKeys :: (Maybe FilePath) -> IO KeyRing
-loadKeys = todo
+data KikiResult = KikiSuccess | FailedToLock [FilePath]
+
+{-
+newtype KeyRing a = KeyRing
+    { krAction :: KeyRingData b -> IO a
+    }
+-}
+
+empty = KeyRingData { filesToLock = []
+                    , homeSpec = Nothing
+                    , kaction = \KeyRingRuntime {} -> return ()
+                    , keyringFiles = []
+                    , walletFiles = []
+                    }
+
+{-
+runKeyRing :: KeyRing () -> IO a
+runKeyRing keyring = krAction keyring empty
+-}
+
+
+runKeyRing :: KeyRingData a -> IO KikiResult
+runKeyRing keyring = do
+    (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
+    let tolocks = map resolve (filesToLock keyring)
+                  where resolve (ArgFile f) = f
+                        resolve HomePub     = pubring
+                        resolve HomeSec     = secring
+    lks <- forM tolocks $ \f -> do
+        lk <- dotlock_create f 0
+        v <- flip (maybe $ return Nothing) lk $ \lk -> do
+                e <- dotlock_take lk (-1)
+                if e==0 then return $ Just lk
+                        else dotlock_destroy lk >> return Nothing
+        return (v,f)
+    let (lked, map snd -> failed) = partition (isJust . fst) lks
+        ret = if null failed then KikiSuccess else FailedToLock failed
+
+    case ret of
+      KikiSuccess -> kaction keyring KeyRingRuntime
+                        { rtPubring = pubring
+                        , rtSecring = secring
+                        , rtRings = secring:pubring:keyringFiles keyring
+                        , rtWallets = walletFiles keyring
+                        , rtGrip = grip0
+                        }
+      _ -> return undefined
+
+    forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
+                                         dotlock_destroy lk
+    return ret
 
 parseOptionFile fname = do
     xs <- fmap lines (readFile fname)
diff --git a/kiki.hs b/kiki.hs
index e4c0dc4..ab3faf5 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1269,7 +1269,7 @@ sortByHint fname f = sortBy (comparing gethint)
 keyMappedPacket (KeyData k _ _ _) = k
 keyPacket (KeyData k _ _ _) = packet k
 
-writeOutKeyrings :: Map.Map FilePath DotLock -> KeyDB -> IO ()
+writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
 writeOutKeyrings lkmap db = do
     let ks = Map.elems db
         fs = Map.keys (foldr unionfiles Map.empty ks)
@@ -1307,44 +1307,34 @@ writeOutKeyrings lkmap db = do
         L.writeFile f (encode m)
 
 cross_merge doDecrypt homespec keyrings wallets f = do
+
+        let it = KeyRingData
+                    { filesToLock = HomeSec:HomePub:map ArgFile keyrings
+                    , homeSpec = homespec
+                    , keyringFiles = keyrings
+                    , walletFiles = wallets
+                    , kaction = go
+                    }
+        runKeyRing it
+ where
+    go rt = do
         let readp n = fmap (n,) (readPacketsFromFile n)
             readw wk n = fmap (n,) (readPacketsFromWallet wk n)
 
-        let relock keyrings = do
-                (fsns,failed_locks) <- lockFiles keyrings
-                (wsns,failed_wlocks) <- lockFiles wallets
-                forM_ (failed_locks++failed_wlocks) $ \f -> warn $ "Failed to lock: " ++ f
-                return (fsns,wsns,failed_locks,failed_wlocks)
-            sec_n:_ = keyrings
-
-        (homedir,secring,pubring,grip0) <- getHomeDir homespec
-
-        (fsns0,wsns0,failed_locks0,failed_wlocks0) <- relock [secring,pubring]
-        db00 <- do
-            ms0 <- mapM readp (map snd fsns0++failed_locks0)
-            return $ foldl' (uncurry . merge) Map.empty ms0
-
-        (fsns,wsns,failed_locks,failed_wlocks) <- relock keyrings
-        wsns <- return $ wsns0 ++ wsns
-        failed_locks <- return $ failed_locks0 ++ failed_locks
-        failed_wlocks <- return $ failed_wlocks0 ++ failed_wlocks
-
-        -- let (lks,fs) = unzip fsns
-        -- forM_ fs $ \f -> warn $ "locked: " ++ f
-        let pass n (fsns,failed_locks) = do
-                ms <- mapM readp (map snd fsns++failed_locks)
-                let db0 = foldl' (uncurry . merge) db00 ms
+        let pass n  = do
+                ms <- mapM readp (rtRings rt)
+                let db0 = foldl' (uncurry . merge) Map.empty ms
                     fstkey = listToMaybe $ mapMaybe isSecringKey ms 
                               where isSecringKey (fn,Message ps)
-                                        | fn==sec_n = listToMaybe ps
+                                        | fn== rtSecring rt = listToMaybe ps
                                     isSecringKey _  = Nothing
-                    grip = grip0 `mplus` (fingerprint <$> fstkey)
+                    grip = rtGrip rt `mplus` (fingerprint <$> fstkey)
                     wk = listToMaybe $ do
                             fp <- maybeToList grip
                             elm <- Map.toList db0
                             guard $ matchSpec (KeyGrip fp) elm
                             return $ keyPacket (snd elm)
-                wms <- mapM (readw wk) (map snd wsns++failed_wlocks)
+                wms <- mapM (readw wk) (rtWallets rt)
                 let -- db1= foldl' (uncurry . merge_) db0 wms
                     ts = do
                         maybeToList wk
@@ -1373,7 +1363,7 @@ cross_merge doDecrypt homespec keyrings wallets f = do
                         return (tag,mp)
 
                 -- export wallet keys
-                forM_ wsns $ \(_,n) -> do
+                forM_ (rtWallets rt) $ \n -> do
                     let cs' = do
                         (nw,mp) <- cs
                         -- let fns = Map.keys (locations mp)
@@ -1389,19 +1379,17 @@ cross_merge doDecrypt homespec keyrings wallets f = do
 
                 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
                 ------------------------------- from external tools. 
-                (db',_) <- f (sec_n,grip) db pubring
+                (db',_) <- f (rtSecring rt,grip) db (rtPubring rt)
                 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
-                let lk = (fsns,failed_locks) -- 
+                let lk = (rtRings rt,[])
                 -------------------------------
-                maybe (if n==0 then pass 1 lk else return (lk,db))
+                maybe (if n==0 then pass 1 else return (lk,db))
                       (return . (lk,))
                       db'
-        ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks)
-        let lkmap = Map.fromList $ map swap fsns
+        ((fsns,failed_locks),db) <- pass 0
+
+        let lkmap = Map.fromList $ map (,()) fsns
         writeOutKeyrings lkmap db
-        unlockFiles fsns
-        unlockFiles wsns
-        return ()
 
 
 {-