summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-12 01:25:15 -0400
committerjoe <joe@jerkface.net>2014-04-12 01:25:15 -0400
commit8c065b516ee67fbab860b07d5e81919f7c774a05 (patch)
treee87758a1b922aca25be0e09bfb8bd4d343b3acfa
parent2f9432b33bf5c8f9c89d8c8d3c255466fc3eb361 (diff)
reorganized cross_merge to use runKeyring
-rw-r--r--KeyRing.hs82
-rw-r--r--kiki.hs62
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 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE TupleSections #-} 2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ViewPatterns #-}
4module KeyRing where 4module KeyRing where
5 5
6import System.Environment 6import System.Environment
7import Control.Monad 7import Control.Monad
8import Control.Applicative
9import Data.Maybe 8import Data.Maybe
10import Data.Char 9import Data.Char
11import System.Directory ( getHomeDirectory, doesFileExist ) 10import Data.List
12import Control.Arrow ( first, second ) 11import Control.Applicative ( (<$>) )
12import System.Directory ( getHomeDirectory, doesFileExist )
13import Control.Arrow ( first, second )
14
15import DotLock
13 16
14data HomeDir = 17data HomeDir =
15 HomeDir { homevar :: String 18 HomeDir { homevar :: String
@@ -23,12 +26,77 @@ home = HomeDir
23 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] 26 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
24 } 27 }
25 28
26data KeyRing 29data InputFile = HomeSec | HomePub | ArgFile FilePath
30
31data KeyRingRuntime = KeyRingRuntime
32 { rtPubring :: FilePath
33 , rtSecring :: FilePath
34 , rtRings :: [FilePath]
35 , rtWallets :: [FilePath]
36 , rtGrip :: Maybe String
37 }
38
39data KeyRingData a = KeyRingData
40 { filesToLock :: [InputFile]
41 , homeSpec :: Maybe String
42 , kaction :: KeyRingRuntime -> IO a
43 , keyringFiles :: [FilePath]
44 , walletFiles :: [FilePath]
45 }
27 46
28todo = error "unimplemented" 47todo = error "unimplemented"
29 48
30loadKeys :: (Maybe FilePath) -> IO KeyRing 49data KikiResult = KikiSuccess | FailedToLock [FilePath]
31loadKeys = todo 50
51{-
52newtype KeyRing a = KeyRing
53 { krAction :: KeyRingData b -> IO a
54 }
55-}
56
57empty = KeyRingData { filesToLock = []
58 , homeSpec = Nothing
59 , kaction = \KeyRingRuntime {} -> return ()
60 , keyringFiles = []
61 , walletFiles = []
62 }
63
64{-
65runKeyRing :: KeyRing () -> IO a
66runKeyRing keyring = krAction keyring empty
67-}
68
69
70runKeyRing :: KeyRingData a -> IO KikiResult
71runKeyRing keyring = do
72 (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
73 let tolocks = map resolve (filesToLock keyring)
74 where resolve (ArgFile f) = f
75 resolve HomePub = pubring
76 resolve HomeSec = secring
77 lks <- forM tolocks $ \f -> do
78 lk <- dotlock_create f 0
79 v <- flip (maybe $ return Nothing) lk $ \lk -> do
80 e <- dotlock_take lk (-1)
81 if e==0 then return $ Just lk
82 else dotlock_destroy lk >> return Nothing
83 return (v,f)
84 let (lked, map snd -> failed) = partition (isJust . fst) lks
85 ret = if null failed then KikiSuccess else FailedToLock failed
86
87 case ret of
88 KikiSuccess -> kaction keyring KeyRingRuntime
89 { rtPubring = pubring
90 , rtSecring = secring
91 , rtRings = secring:pubring:keyringFiles keyring
92 , rtWallets = walletFiles keyring
93 , rtGrip = grip0
94 }
95 _ -> return undefined
96
97 forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
98 dotlock_destroy lk
99 return ret
32 100
33parseOptionFile fname = do 101parseOptionFile fname = do
34 xs <- fmap lines (readFile fname) 102 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)
1269keyMappedPacket (KeyData k _ _ _) = k 1269keyMappedPacket (KeyData k _ _ _) = k
1270keyPacket (KeyData k _ _ _) = packet k 1270keyPacket (KeyData k _ _ _) = packet k
1271 1271
1272writeOutKeyrings :: Map.Map FilePath DotLock -> KeyDB -> IO () 1272writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
1273writeOutKeyrings lkmap db = do 1273writeOutKeyrings lkmap db = do
1274 let ks = Map.elems db 1274 let ks = Map.elems db
1275 fs = Map.keys (foldr unionfiles Map.empty ks) 1275 fs = Map.keys (foldr unionfiles Map.empty ks)
@@ -1307,44 +1307,34 @@ writeOutKeyrings lkmap db = do
1307 L.writeFile f (encode m) 1307 L.writeFile f (encode m)
1308 1308
1309cross_merge doDecrypt homespec keyrings wallets f = do 1309cross_merge doDecrypt homespec keyrings wallets f = do
1310
1311 let it = KeyRingData
1312 { filesToLock = HomeSec:HomePub:map ArgFile keyrings
1313 , homeSpec = homespec
1314 , keyringFiles = keyrings
1315 , walletFiles = wallets
1316 , kaction = go
1317 }
1318 runKeyRing it
1319 where
1320 go rt = do
1310 let readp n = fmap (n,) (readPacketsFromFile n) 1321 let readp n = fmap (n,) (readPacketsFromFile n)
1311 readw wk n = fmap (n,) (readPacketsFromWallet wk n) 1322 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
1312 1323
1313 let relock keyrings = do 1324 let pass n = do
1314 (fsns,failed_locks) <- lockFiles keyrings 1325 ms <- mapM readp (rtRings rt)
1315 (wsns,failed_wlocks) <- lockFiles wallets 1326 let db0 = foldl' (uncurry . merge) Map.empty ms
1316 forM_ (failed_locks++failed_wlocks) $ \f -> warn $ "Failed to lock: " ++ f
1317 return (fsns,wsns,failed_locks,failed_wlocks)
1318 sec_n:_ = keyrings
1319
1320 (homedir,secring,pubring,grip0) <- getHomeDir homespec
1321
1322 (fsns0,wsns0,failed_locks0,failed_wlocks0) <- relock [secring,pubring]
1323 db00 <- do
1324 ms0 <- mapM readp (map snd fsns0++failed_locks0)
1325 return $ foldl' (uncurry . merge) Map.empty ms0
1326
1327 (fsns,wsns,failed_locks,failed_wlocks) <- relock keyrings
1328 wsns <- return $ wsns0 ++ wsns
1329 failed_locks <- return $ failed_locks0 ++ failed_locks
1330 failed_wlocks <- return $ failed_wlocks0 ++ failed_wlocks
1331
1332 -- let (lks,fs) = unzip fsns
1333 -- forM_ fs $ \f -> warn $ "locked: " ++ f
1334 let pass n (fsns,failed_locks) = do
1335 ms <- mapM readp (map snd fsns++failed_locks)
1336 let db0 = foldl' (uncurry . merge) db00 ms
1337 fstkey = listToMaybe $ mapMaybe isSecringKey ms 1327 fstkey = listToMaybe $ mapMaybe isSecringKey ms
1338 where isSecringKey (fn,Message ps) 1328 where isSecringKey (fn,Message ps)
1339 | fn==sec_n = listToMaybe ps 1329 | fn== rtSecring rt = listToMaybe ps
1340 isSecringKey _ = Nothing 1330 isSecringKey _ = Nothing
1341 grip = grip0 `mplus` (fingerprint <$> fstkey) 1331 grip = rtGrip rt `mplus` (fingerprint <$> fstkey)
1342 wk = listToMaybe $ do 1332 wk = listToMaybe $ do
1343 fp <- maybeToList grip 1333 fp <- maybeToList grip
1344 elm <- Map.toList db0 1334 elm <- Map.toList db0
1345 guard $ matchSpec (KeyGrip fp) elm 1335 guard $ matchSpec (KeyGrip fp) elm
1346 return $ keyPacket (snd elm) 1336 return $ keyPacket (snd elm)
1347 wms <- mapM (readw wk) (map snd wsns++failed_wlocks) 1337 wms <- mapM (readw wk) (rtWallets rt)
1348 let -- db1= foldl' (uncurry . merge_) db0 wms 1338 let -- db1= foldl' (uncurry . merge_) db0 wms
1349 ts = do 1339 ts = do
1350 maybeToList wk 1340 maybeToList wk
@@ -1373,7 +1363,7 @@ cross_merge doDecrypt homespec keyrings wallets f = do
1373 return (tag,mp) 1363 return (tag,mp)
1374 1364
1375 -- export wallet keys 1365 -- export wallet keys
1376 forM_ wsns $ \(_,n) -> do 1366 forM_ (rtWallets rt) $ \n -> do
1377 let cs' = do 1367 let cs' = do
1378 (nw,mp) <- cs 1368 (nw,mp) <- cs
1379 -- let fns = Map.keys (locations mp) 1369 -- let fns = Map.keys (locations mp)
@@ -1389,19 +1379,17 @@ cross_merge doDecrypt homespec keyrings wallets f = do
1389 1379
1390 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings 1380 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
1391 ------------------------------- from external tools. 1381 ------------------------------- from external tools.
1392 (db',_) <- f (sec_n,grip) db pubring 1382 (db',_) <- f (rtSecring rt,grip) db (rtPubring rt)
1393 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now. 1383 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
1394 let lk = (fsns,failed_locks) -- 1384 let lk = (rtRings rt,[])
1395 ------------------------------- 1385 -------------------------------
1396 maybe (if n==0 then pass 1 lk else return (lk,db)) 1386 maybe (if n==0 then pass 1 else return (lk,db))
1397 (return . (lk,)) 1387 (return . (lk,))
1398 db' 1388 db'
1399 ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks) 1389 ((fsns,failed_locks),db) <- pass 0
1400 let lkmap = Map.fromList $ map swap fsns 1390
1391 let lkmap = Map.fromList $ map (,()) fsns
1401 writeOutKeyrings lkmap db 1392 writeOutKeyrings lkmap db
1402 unlockFiles fsns
1403 unlockFiles wsns
1404 return ()
1405 1393
1406 1394
1407{- 1395{-