summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-08-31 23:33:04 -0400
committerjoe <joe@jerkface.net>2016-08-31 23:33:04 -0400
commit6734397a53e2160257a89f8c391d89ea4aa02ad4 (patch)
tree57da0c2ff30e97abb9e821e587172ecb6d5e15b5
parentd8950d3ccdf51f308aa93f06c16f26b15a6c55c4 (diff)
Better error reporting
-rw-r--r--kiki.hs72
-rw-r--r--lib/GnuPGAgent.hs3
-rw-r--r--lib/PacketTranscoder.hs69
-rw-r--r--lib/Types.hs2
4 files changed, 74 insertions, 72 deletions
diff --git a/kiki.hs b/kiki.hs
index 9796c3d..adb7973 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -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
1182doTransform :: [String] -> ([String]->[Transform]) -> IO ()
1183doTransform 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
1182kiki :: String -> [String] -> IO () 1208kiki :: String -> [String] -> IO ()
1183kiki "sync-secret" args_raw = 1209kiki "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 ()
1535kiki "delete" args = do 1561kiki "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
1557kiki "rename" args | "--help" `elem` args = do 1564kiki "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 ()
1565kiki "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
1573kiki "rename" args = doTransform args rename
1574 where rename (oldtag:newtag:_) = [ RenameSubkeys oldtag newtag ]
1587 1575
1588kiki "tar" args | "--help" `elem` args = do 1576kiki "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
13import Debug.Trace 13import Debug.Trace
14import Control.Monad 14import Control.Monad
15import ControlMaybe
15import Data.Char 16import Data.Char
16import Data.OpenPGP 17import Data.OpenPGP
17import Data.OpenPGP.Util 18import Data.OpenPGP.Util
@@ -39,9 +40,11 @@ import Data.Word
39 40
40data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } 41data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
41 42
43session :: IO (Maybe GnuPGAgent)
42session = do 44session = 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
241instance FunctorToMaybe KikiCondition where 243instance FunctorToMaybe KikiCondition where