From 8c065b516ee67fbab860b07d5e81919f7c774a05 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 12 Apr 2014 01:25:15 -0400 Subject: reorganized cross_merge to use runKeyring --- KeyRing.hs | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++------ kiki.hs | 62 +++++++++++++++++++---------------------------- 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 () {- -- cgit v1.2.3