Better error reporting

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
         putStrLn $ fname ++ ": " ++ reportString act
 
 
+doTransform :: [String] -> ([String]->[Transform]) -> IO ()
+doTransform args mktrans = do
+    let (sargs,margs) = processArgs sargspec polyVariadicArgs "---" args
+            where sargspec = []
+                  polyVariadicArgs = ["---"]
+        passfd = fmap (FileDesc . read) passphrase_fd
+            where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
+        targs = fromMaybe [] $ Map.lookup "---" margs
+        homespec = join . take 1 <$> Map.lookup "--homedir" margs
+        kikiOp = KeyRingOperation
+            { opFiles = Map.fromList $
+                [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
+                , ( HomePub, buildStreamInfo KF_All KeyRingFile )
+                ]
+            , opPassphrases = withAgent $ do pfile <- maybeToList passfd
+                                             return $ PassphraseSpec Nothing Nothing pfile
+            , opTransforms = mktrans targs
+            , opHome = homespec
+            }
+    KikiResult rt report <- runKeyRing kikiOp
+    forM_ report $ \(fname,act) -> do
+        putStrLn $ fname ++ ": " ++ reportString act
+    case rt of
+      KikiSuccess _ -> return ()
+      err -> putStrLn $ errorString err
+
 kiki :: String -> [String] -> IO ()
 kiki "sync-secret" args_raw =
     sync True True True "sync-secret" args_raw
@@ -1532,27 +1558,8 @@ kiki "delete" args | "--help" `elem` args = do
         , "  with all associated signatures and trust markers."
         ]
     return ()
-kiki "delete" args = do
-    let (sargs,margs) = processArgs sargspec polyVariadicArgs "--delete" args
-            where sargspec = []
-                  polyVariadicArgs = ["--delete"]
-        passfd = fmap (FileDesc . read) passphrase_fd
-            where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
-        fps = fromMaybe [] $ Map.lookup "--delete" margs
-        homespec = join . take 1 <$> Map.lookup "--homedir" margs
-        kikiOp = KeyRingOperation
-            { opFiles = Map.fromList $
-                [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
-                , ( HomePub, buildStreamInfo KF_All KeyRingFile )
-                ]
-            , opPassphrases = withAgent $ do pfile <- maybeToList passfd
-                                             return $ PassphraseSpec Nothing Nothing pfile
-            , opTransforms = map DeleteSubkeyByFingerprint fps
-            , opHome = homespec
-            }
-    KikiResult rt report <- runKeyRing kikiOp
-    forM_ report $ \(fname,act) -> do
-        putStrLn $ fname ++ ": " ++ reportString act
+kiki "delete" args = doTransform args delete
+ where delete fps = map DeleteSubkeyByFingerprint fps
 
 kiki "rename" args | "--help" `elem` args = do
     putStr . unlines $
@@ -1562,28 +1569,9 @@ kiki "rename" args | "--help" `elem` args = do
         , "  The old signature will be replaced and a new one formed."
         ]
     return ()
-kiki "rename" args = do
-    let (sargs,margs) = processArgs sargspec polyVariadicArgs "--rename" args
-            where sargspec = [("--homedir",1)]
-                  polyVariadicArgs = ["--rename"]
-        passfd = fmap (FileDesc . read) passphrase_fd
-            where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
-        (oldtag:newtag:_) = fromMaybe [] $ Map.lookup "--rename" margs
-        homespec = join . take 1 <$> Map.lookup "--homedir" margs
-        kikiOp = KeyRingOperation
-            { opFiles = Map.fromList $
-                [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
-                , ( HomePub, buildStreamInfo KF_All KeyRingFile )
-                ]
-            , opPassphrases = withAgent $ do pfile <- maybeToList passfd
-                                             return $ PassphraseSpec Nothing Nothing pfile
-            , opTransforms = [ RenameSubkeys oldtag newtag]
-            , opHome = homespec
-            }
-    KikiResult rt report <- runKeyRing kikiOp
-    forM_ report $ \(fname,act) -> do
-        putStrLn $ fname ++ ": " ++ reportString act
 
+kiki "rename" args = doTransform args rename
+ where rename (oldtag:newtag:_) = [ RenameSubkeys oldtag newtag ]
 
 kiki "tar" args | "--help" `elem` args = do
     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
 
 import Debug.Trace
 import Control.Monad
+import ControlMaybe
 import Data.Char
 import Data.OpenPGP
 import Data.OpenPGP.Util
@@ -39,9 +40,11 @@ import Data.Word
 
 data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
 
+session :: IO (Maybe GnuPGAgent)
 session = do
     envhomedir Nothing gpgHomeSpec >>= \case
         Just gpghome -> do
+            handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ do
             sock <- socket AF_UNIX Stream defaultProtocol
             connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
             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
                 --  allow you to run 'decryptIt' on an unencrypted public key
                 --  to obtain it's secret key.
                 handleIO_ (decryptIt []) $ do
-                (pw,wants_retry) <- getpw (count,qry)
-                let wkun = fromMaybe wk $ do
-                                guard $ symmetric_algorithm (packet mp) /= Unencrypted
-                                decryptSecretKey pw (packet mp)
-
-                    retryOrFail
-                        | Just clear <- wants_retry = if count < 4
-                                                        then tries (count+1) getpw recurse
-                                                        else clear >> recurse
-                        | otherwise                 = recurse
-
-                case symmetric_algorithm wkun of
-
-                    Unencrypted -> do
-                        writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys)
-                        ek <- case dest_alg of
-                                Unencrypted -> return $ Just wkun
-                                _           -> encryptSecretKey pw dest_s2k' dest_alg wkun
-
-                        case ek of
-                            Nothing   -> retryOrFail
-                            Just wken -> do
-                                modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken)
-                                return $ KikiSuccess wken
-
-                    _ -> retryOrFail
-
-            getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
+                (pw0,wants_retry) <- getpw (count,qry)
+                case pw0 of
+                  KikiSuccess pw -> do
+                    let wkun = fromMaybe wk $ do
+                                    guard $ symmetric_algorithm (packet mp) /= Unencrypted
+                                    decryptSecretKey pw (packet mp)
+
+                        retryOrFail
+                            | Just clear <- wants_retry = if count < 4
+                                                            then tries (count+1) getpw recurse
+                                                            else clear >> recurse
+                            | otherwise                 = recurse
+
+                    case symmetric_algorithm wkun of
+
+                        Unencrypted -> do
+                            writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys)
+                            ek <- case dest_alg of
+                                    Unencrypted -> return $ Just wkun
+                                    _           -> encryptSecretKey pw dest_s2k' dest_alg wkun
+
+                            case ek of
+                                Nothing   -> retryOrFail
+                                Just wken -> do
+                                    modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken)
+                                    return $ KikiSuccess wken
+
+                        _ -> retryOrFail
+                  err -> return $ fmap (error "pasphrase error") err
+
+            getpws = (map (const . fmap (\pw -> (KikiSuccess pw,Nothing)))
+                        $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
 
             agentpw (count,qry) = do
                     s <- session
-                    fromMaybe (return ("",Nothing)) $ do
+                    fromMaybe (return (AgentConnectionFailure,Nothing)) $ do
                     s <- s
                     Just $ do
                     let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k)
@@ -230,7 +234,12 @@ makeMemoizingDecrypter operation ctx (workingkey,keys) = do
                     -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry)
                     mbpw <- getPassphrase s ask actual_qry
                     quit s
-                    return ( maybe "" S8.pack mbpw, guard (ask /= AskNew) >> Just clear )
+                    -- putStrLn $ "mbpw = " ++show mbpw
+                    return ( maybe (if count >=firsttime then OperationCanceled
+                                                         else KikiSuccess "") -- No cached data.
+                                   (KikiSuccess . S8.pack)
+                                   mbpw
+                           , guard (ask /= AskNew) >> Just clear )
 
         calls <- currentCallStack
         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
     | AmbiguousKeySpec FilePath
     | CannotImportMasterKey
     | NoWorkingKey
+    | AgentConnectionFailure
+    | OperationCanceled
  deriving ( Functor, Show )
 
 instance FunctorToMaybe KikiCondition where