diff options
author | joe <joe@jerkface.net> | 2016-08-31 23:33:04 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2016-08-31 23:33:04 -0400 |
commit | 6734397a53e2160257a89f8c391d89ea4aa02ad4 (patch) | |
tree | 57da0c2ff30e97abb9e821e587172ecb6d5e15b5 | |
parent | d8950d3ccdf51f308aa93f06c16f26b15a6c55c4 (diff) |
Better error reporting
-rw-r--r-- | kiki.hs | 72 | ||||
-rw-r--r-- | lib/GnuPGAgent.hs | 3 | ||||
-rw-r--r-- | lib/PacketTranscoder.hs | 69 | ||||
-rw-r--r-- | lib/Types.hs | 2 |
4 files changed, 74 insertions, 72 deletions
@@ -1179,6 +1179,32 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
1179 | putStrLn $ fname ++ ": " ++ reportString act | 1179 | putStrLn $ fname ++ ": " ++ reportString act |
1180 | 1180 | ||
1181 | 1181 | ||
1182 | doTransform :: [String] -> ([String]->[Transform]) -> IO () | ||
1183 | doTransform args mktrans = do | ||
1184 | let (sargs,margs) = processArgs sargspec polyVariadicArgs "---" args | ||
1185 | where sargspec = [] | ||
1186 | polyVariadicArgs = ["---"] | ||
1187 | passfd = fmap (FileDesc . read) passphrase_fd | ||
1188 | where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | ||
1189 | targs = fromMaybe [] $ Map.lookup "---" margs | ||
1190 | homespec = join . take 1 <$> Map.lookup "--homedir" margs | ||
1191 | kikiOp = KeyRingOperation | ||
1192 | { opFiles = Map.fromList $ | ||
1193 | [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) | ||
1194 | , ( HomePub, buildStreamInfo KF_All KeyRingFile ) | ||
1195 | ] | ||
1196 | , opPassphrases = withAgent $ do pfile <- maybeToList passfd | ||
1197 | return $ PassphraseSpec Nothing Nothing pfile | ||
1198 | , opTransforms = mktrans targs | ||
1199 | , opHome = homespec | ||
1200 | } | ||
1201 | KikiResult rt report <- runKeyRing kikiOp | ||
1202 | forM_ report $ \(fname,act) -> do | ||
1203 | putStrLn $ fname ++ ": " ++ reportString act | ||
1204 | case rt of | ||
1205 | KikiSuccess _ -> return () | ||
1206 | err -> putStrLn $ errorString err | ||
1207 | |||
1182 | kiki :: String -> [String] -> IO () | 1208 | kiki :: String -> [String] -> IO () |
1183 | kiki "sync-secret" args_raw = | 1209 | kiki "sync-secret" args_raw = |
1184 | sync True True True "sync-secret" args_raw | 1210 | sync True True True "sync-secret" args_raw |
@@ -1532,27 +1558,8 @@ kiki "delete" args | "--help" `elem` args = do | |||
1532 | , " with all associated signatures and trust markers." | 1558 | , " with all associated signatures and trust markers." |
1533 | ] | 1559 | ] |
1534 | return () | 1560 | return () |
1535 | kiki "delete" args = do | 1561 | kiki "delete" args = doTransform args delete |
1536 | let (sargs,margs) = processArgs sargspec polyVariadicArgs "--delete" args | 1562 | where delete fps = map DeleteSubkeyByFingerprint fps |
1537 | where sargspec = [] | ||
1538 | polyVariadicArgs = ["--delete"] | ||
1539 | passfd = fmap (FileDesc . read) passphrase_fd | ||
1540 | where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | ||
1541 | fps = fromMaybe [] $ Map.lookup "--delete" margs | ||
1542 | homespec = join . take 1 <$> Map.lookup "--homedir" margs | ||
1543 | kikiOp = KeyRingOperation | ||
1544 | { opFiles = Map.fromList $ | ||
1545 | [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) | ||
1546 | , ( HomePub, buildStreamInfo KF_All KeyRingFile ) | ||
1547 | ] | ||
1548 | , opPassphrases = withAgent $ do pfile <- maybeToList passfd | ||
1549 | return $ PassphraseSpec Nothing Nothing pfile | ||
1550 | , opTransforms = map DeleteSubkeyByFingerprint fps | ||
1551 | , opHome = homespec | ||
1552 | } | ||
1553 | KikiResult rt report <- runKeyRing kikiOp | ||
1554 | forM_ report $ \(fname,act) -> do | ||
1555 | putStrLn $ fname ++ ": " ++ reportString act | ||
1556 | 1563 | ||
1557 | kiki "rename" args | "--help" `elem` args = do | 1564 | kiki "rename" args | "--help" `elem` args = do |
1558 | putStr . unlines $ | 1565 | putStr . unlines $ |
@@ -1562,28 +1569,9 @@ kiki "rename" args | "--help" `elem` args = do | |||
1562 | , " The old signature will be replaced and a new one formed." | 1569 | , " The old signature will be replaced and a new one formed." |
1563 | ] | 1570 | ] |
1564 | return () | 1571 | return () |
1565 | kiki "rename" args = do | ||
1566 | let (sargs,margs) = processArgs sargspec polyVariadicArgs "--rename" args | ||
1567 | where sargspec = [("--homedir",1)] | ||
1568 | polyVariadicArgs = ["--rename"] | ||
1569 | passfd = fmap (FileDesc . read) passphrase_fd | ||
1570 | where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | ||
1571 | (oldtag:newtag:_) = fromMaybe [] $ Map.lookup "--rename" margs | ||
1572 | homespec = join . take 1 <$> Map.lookup "--homedir" margs | ||
1573 | kikiOp = KeyRingOperation | ||
1574 | { opFiles = Map.fromList $ | ||
1575 | [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) | ||
1576 | , ( HomePub, buildStreamInfo KF_All KeyRingFile ) | ||
1577 | ] | ||
1578 | , opPassphrases = withAgent $ do pfile <- maybeToList passfd | ||
1579 | return $ PassphraseSpec Nothing Nothing pfile | ||
1580 | , opTransforms = [ RenameSubkeys oldtag newtag] | ||
1581 | , opHome = homespec | ||
1582 | } | ||
1583 | KikiResult rt report <- runKeyRing kikiOp | ||
1584 | forM_ report $ \(fname,act) -> do | ||
1585 | putStrLn $ fname ++ ": " ++ reportString act | ||
1586 | 1572 | ||
1573 | kiki "rename" args = doTransform args rename | ||
1574 | where rename (oldtag:newtag:_) = [ RenameSubkeys oldtag newtag ] | ||
1587 | 1575 | ||
1588 | kiki "tar" args | "--help" `elem` args = do | 1576 | kiki "tar" args | "--help" `elem` args = do |
1589 | putStr . unlines $ | 1577 | putStr . unlines $ |
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index 7161b92..067e3bc 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs | |||
@@ -12,6 +12,7 @@ module GnuPGAgent | |||
12 | 12 | ||
13 | import Debug.Trace | 13 | import Debug.Trace |
14 | import Control.Monad | 14 | import Control.Monad |
15 | import ControlMaybe | ||
15 | import Data.Char | 16 | import Data.Char |
16 | import Data.OpenPGP | 17 | import Data.OpenPGP |
17 | import Data.OpenPGP.Util | 18 | import Data.OpenPGP.Util |
@@ -39,9 +40,11 @@ import Data.Word | |||
39 | 40 | ||
40 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } | 41 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } |
41 | 42 | ||
43 | session :: IO (Maybe GnuPGAgent) | ||
42 | session = do | 44 | session = do |
43 | envhomedir Nothing gpgHomeSpec >>= \case | 45 | envhomedir Nothing gpgHomeSpec >>= \case |
44 | Just gpghome -> do | 46 | Just gpghome -> do |
47 | handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ do | ||
45 | sock <- socket AF_UNIX Stream defaultProtocol | 48 | sock <- socket AF_UNIX Stream defaultProtocol |
46 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) | 49 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) |
47 | agent <- socketToHandle sock ReadWriteMode | 50 | agent <- socketToHandle sock ReadWriteMode |
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index f4b4cce..afbf55b 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs | |||
@@ -174,38 +174,42 @@ makeMemoizingDecrypter operation ctx (workingkey,keys) = do | |||
174 | -- allow you to run 'decryptIt' on an unencrypted public key | 174 | -- allow you to run 'decryptIt' on an unencrypted public key |
175 | -- to obtain it's secret key. | 175 | -- to obtain it's secret key. |
176 | handleIO_ (decryptIt []) $ do | 176 | handleIO_ (decryptIt []) $ do |
177 | (pw,wants_retry) <- getpw (count,qry) | 177 | (pw0,wants_retry) <- getpw (count,qry) |
178 | let wkun = fromMaybe wk $ do | 178 | case pw0 of |
179 | guard $ symmetric_algorithm (packet mp) /= Unencrypted | 179 | KikiSuccess pw -> do |
180 | decryptSecretKey pw (packet mp) | 180 | let wkun = fromMaybe wk $ do |
181 | 181 | guard $ symmetric_algorithm (packet mp) /= Unencrypted | |
182 | retryOrFail | 182 | decryptSecretKey pw (packet mp) |
183 | | Just clear <- wants_retry = if count < 4 | 183 | |
184 | then tries (count+1) getpw recurse | 184 | retryOrFail |
185 | else clear >> recurse | 185 | | Just clear <- wants_retry = if count < 4 |
186 | | otherwise = recurse | 186 | then tries (count+1) getpw recurse |
187 | 187 | else clear >> recurse | |
188 | case symmetric_algorithm wkun of | 188 | | otherwise = recurse |
189 | 189 | ||
190 | Unencrypted -> do | 190 | case symmetric_algorithm wkun of |
191 | writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys) | 191 | |
192 | ek <- case dest_alg of | 192 | Unencrypted -> do |
193 | Unencrypted -> return $ Just wkun | 193 | writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys) |
194 | _ -> encryptSecretKey pw dest_s2k' dest_alg wkun | 194 | ek <- case dest_alg of |
195 | 195 | Unencrypted -> return $ Just wkun | |
196 | case ek of | 196 | _ -> encryptSecretKey pw dest_s2k' dest_alg wkun |
197 | Nothing -> retryOrFail | 197 | |
198 | Just wken -> do | 198 | case ek of |
199 | modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken) | 199 | Nothing -> retryOrFail |
200 | return $ KikiSuccess wken | 200 | Just wken -> do |
201 | 201 | modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken) | |
202 | _ -> retryOrFail | 202 | return $ KikiSuccess wken |
203 | 203 | ||
204 | getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] | 204 | _ -> retryOrFail |
205 | err -> return $ fmap (error "pasphrase error") err | ||
206 | |||
207 | getpws = (map (const . fmap (\pw -> (KikiSuccess pw,Nothing))) | ||
208 | $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] | ||
205 | 209 | ||
206 | agentpw (count,qry) = do | 210 | agentpw (count,qry) = do |
207 | s <- session | 211 | s <- session |
208 | fromMaybe (return ("",Nothing)) $ do | 212 | fromMaybe (return (AgentConnectionFailure,Nothing)) $ do |
209 | s <- s | 213 | s <- s |
210 | Just $ do | 214 | Just $ do |
211 | let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k) | 215 | let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k) |
@@ -230,7 +234,12 @@ makeMemoizingDecrypter operation ctx (workingkey,keys) = do | |||
230 | -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry) | 234 | -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry) |
231 | mbpw <- getPassphrase s ask actual_qry | 235 | mbpw <- getPassphrase s ask actual_qry |
232 | quit s | 236 | quit s |
233 | return ( maybe "" S8.pack mbpw, guard (ask /= AskNew) >> Just clear ) | 237 | -- putStrLn $ "mbpw = " ++show mbpw |
238 | return ( maybe (if count >=firsttime then OperationCanceled | ||
239 | else KikiSuccess "") -- No cached data. | ||
240 | (KikiSuccess . S8.pack) | ||
241 | mbpw | ||
242 | , guard (ask /= AskNew) >> Just clear ) | ||
234 | 243 | ||
235 | calls <- currentCallStack | 244 | calls <- currentCallStack |
236 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)] | 245 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)] |
diff --git a/lib/Types.hs b/lib/Types.hs index df2dfbe..686614e 100644 --- a/lib/Types.hs +++ b/lib/Types.hs | |||
@@ -236,6 +236,8 @@ data KikiCondition a = KikiSuccess a | |||
236 | | AmbiguousKeySpec FilePath | 236 | | AmbiguousKeySpec FilePath |
237 | | CannotImportMasterKey | 237 | | CannotImportMasterKey |
238 | | NoWorkingKey | 238 | | NoWorkingKey |
239 | | AgentConnectionFailure | ||
240 | | OperationCanceled | ||
239 | deriving ( Functor, Show ) | 241 | deriving ( Functor, Show ) |
240 | 242 | ||
241 | instance FunctorToMaybe KikiCondition where | 243 | instance FunctorToMaybe KikiCondition where |