summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.cabal2
-rw-r--r--lib/KeyRing.hs60
2 files changed, 31 insertions, 31 deletions
diff --git a/kiki.cabal b/kiki.cabal
index 1b2d611..e75c1b0 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -27,7 +27,7 @@ Flag unixEnv
27 Default: False 27 Default: False
28 28
29Executable kiki 29Executable kiki
30 Ghc-Options: -W -Wall -Wno-name-shadowing 30 Ghc-Options: -W -Wall -Wno-name-shadowing -Wno-unused-matches
31 Main-is: kiki.hs 31 Main-is: kiki.hs
32 -- base >=4.6 due to use of readEither in KikiD.Message 32 -- base >=4.6 due to use of readEither in KikiD.Message
33 Build-Depends: base >=4.6.0.0, 33 Build-Depends: base >=4.6.0.0,
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index f172e87..cece862 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -14,16 +14,16 @@
14-- Typically, a client to this module would prepare a 'KeyRingOperation' 14-- Typically, a client to this module would prepare a 'KeyRingOperation'
15-- describing what he wants done, and then invoke 'runKeyRing' to make it 15-- describing what he wants done, and then invoke 'runKeyRing' to make it
16-- happen. 16-- happen.
17{-# LANGUAGE CPP #-} 17{-# LANGUAGE CPP #-}
18{-# LANGUAGE TupleSections #-} 18{-# LANGUAGE DeriveFunctor #-}
19{-# LANGUAGE ViewPatterns #-} 19{-# LANGUAGE DoAndIfThenElse #-}
20{-# LANGUAGE PatternGuards #-}
21{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE DoAndIfThenElse #-}
24{-# LANGUAGE PatternGuards #-}
25{-# LANGUAGE ForeignFunctionInterface #-} 20{-# LANGUAGE ForeignFunctionInterface #-}
26{-# LANGUAGE LambdaCase #-} 21{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE PatternGuards #-}
24{-# LANGUAGE ScopedTypeVariables #-}
25{-# LANGUAGE TupleSections #-}
26{-# LANGUAGE ViewPatterns #-}
27module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where 27module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where
28 28
29import System.Environment 29import System.Environment
@@ -1116,28 +1116,27 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
1116 ++ import_rs ++ internals_rs) 1116 ++ import_rs ++ internals_rs)
1117 1117
1118 1118
1119-- FIXME: try' should probably accept a list of KikiReportActions.
1120-- This would be useful for reporting on disk writes that have already
1121-- succeded prior to this termination.
1122try' :: Monad m => KikiCondition t -> (t -> m (KikiResult a)) -> m (KikiResult a)
1123try' v body =
1124 case functorToEither v of
1125 Left e -> return $ KikiResult e []
1126 Right wkun -> body wkun
1119 1127
1120-- | Load and update key files according to the specified 'KeyRingOperation'. 1128-- | Load and update key files according to the specified 'KeyRingOperation'.
1121runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) 1129runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
1122runKeyRing operation = do 1130runKeyRing operation = do
1123 -- get homedir and keyring files + fingerprint for working key 1131 -- get homedir and keyring files + fingerprint for working key
1124 homedir <- getHomeDir (opHome operation) 1132 homedir <- getHomeDir (opHome operation)
1125 1133 try' homedir $ \(_homedir, secring, pubring, grip0) -> do
1126 let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
1127 -- FIXME: try' should probably accept a list of KikiReportActions.
1128 -- This would be useful for reporting on disk writes that have already
1129 -- succeded prior to this termination.
1130 try' v body =
1131 case functorToEither v of
1132 Left e -> return $ KikiResult e []
1133 Right wkun -> body wkun
1134
1135 try' homedir $ \(homedir,secring,pubring,grip0) -> do
1136 let ctx = InputFileContext secring pubring 1134 let ctx = InputFileContext secring pubring
1137 tolocks = filesToLock operation ctx 1135 tolocks = filesToLock operation ctx
1138 secring <- return Nothing 1136 secring <- return Nothing
1139 pubring <- return Nothing 1137 pubring <- return Nothing
1140 lks <- forM tolocks $ \f -> do 1138 (locks :: [(Maybe DotLock, FilePath)]) <-
1139 forM tolocks $ \f -> do
1141 createDirectoryIfMissing True $ takeDirectory f 1140 createDirectoryIfMissing True $ takeDirectory f
1142 lk <- dotlock_create f 0 1141 lk <- dotlock_create f 0
1143 v <- flip (maybe $ return Nothing) lk $ \lk -> do 1142 v <- flip (maybe $ return Nothing) lk $ \lk -> do
@@ -1145,15 +1144,19 @@ runKeyRing operation = do
1145 if e==0 then return $ Just lk 1144 if e==0 then return $ Just lk
1146 else dotlock_destroy lk >> return Nothing 1145 else dotlock_destroy lk >> return Nothing
1147 return (v,f) 1146 return (v,f)
1148 let (lked, map snd -> failed_locks) = partition (isJust . fst) lks 1147 let (lked, map snd -> failed_locks) = partition (isJust . fst) locks
1149 ret <- 1148 ret <-
1150 if not $ null failed_locks 1149 if not $ null failed_locks
1151 then return $ KikiResult (FailedToLock failed_locks) [] 1150 then return $ KikiResult (FailedToLock failed_locks) []
1152 else do 1151 else realRunKeyRing ctx grip0 operation
1152 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
1153 return ret
1154
1153 1155
1154 -- merge all keyrings, PEM files, and wallets 1156realRunKeyRing :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiResult KeyRingRuntime)
1157realRunKeyRing ctx grip0 operation = do
1155 bresult <- buildKeyDB ctx grip0 operation 1158 bresult <- buildKeyDB ctx grip0 operation
1156 try' bresult $ \((db,grip,wk,hs,accs,transcode,unspilled),report_imports) -> do 1159 try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do
1157 1160
1158 externals_ret <- initializeMissingPEMFiles operation 1161 externals_ret <- initializeMissingPEMFiles operation
1159 ctx 1162 ctx
@@ -1161,7 +1164,7 @@ runKeyRing operation = do
1161 wk 1164 wk
1162 transcode 1165 transcode
1163 db 1166 db
1164 try' externals_ret $ \((db,exports),report_externals) -> do 1167 try' externals_ret $ \((db, exports), report_externals) -> do
1165 1168
1166 let decrypt = transcode (Unencrypted,S2K 100 "") 1169 let decrypt = transcode (Unencrypted,S2K 100 "")
1167 rt = KeyRingRuntime 1170 rt = KeyRingRuntime
@@ -1189,7 +1192,7 @@ runKeyRing operation = do
1189 1192
1190 r <- writePEMKeys decrypt (rtKeyDB rt) exports 1193 r <- writePEMKeys decrypt (rtKeyDB rt) exports
1191 try' r $ \report_pems -> do 1194 try' r $ \report_pems -> do
1192 1195
1193 import_hosts <- writeHostsFiles operation ctx hs 1196 import_hosts <- writeHostsFiles operation ctx hs
1194 1197
1195 return $ KikiResult (KikiSuccess rt) 1198 return $ KikiResult (KikiSuccess rt)
@@ -1200,9 +1203,6 @@ runKeyRing operation = do
1200 , report_rings 1203 , report_rings
1201 , report_pems ] 1204 , report_pems ]
1202 1205
1203 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
1204
1205 return ret
1206 1206
1207parseOptionFile :: FilePath -> IO [String] 1207parseOptionFile :: FilePath -> IO [String]
1208parseOptionFile fname = do 1208parseOptionFile fname = do