diff options
-rw-r--r-- | kiki.cabal | 2 | ||||
-rw-r--r-- | lib/KeyRing.hs | 60 |
2 files changed, 31 insertions, 31 deletions
@@ -27,7 +27,7 @@ Flag unixEnv | |||
27 | Default: False | 27 | Default: False |
28 | 28 | ||
29 | Executable kiki | 29 | Executable 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 #-} | ||
27 | module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where | 27 | module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where |
28 | 28 | ||
29 | import System.Environment | 29 | import 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. | ||
1122 | try' :: Monad m => KikiCondition t -> (t -> m (KikiResult a)) -> m (KikiResult a) | ||
1123 | try' 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'. |
1121 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) | 1129 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) |
1122 | runKeyRing operation = do | 1130 | runKeyRing 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 | 1156 | realRunKeyRing :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiResult KeyRingRuntime) |
1157 | realRunKeyRing 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 | ||
1207 | parseOptionFile :: FilePath -> IO [String] | 1207 | parseOptionFile :: FilePath -> IO [String] |
1208 | parseOptionFile fname = do | 1208 | parseOptionFile fname = do |