From 687c7db8bbdf42b57a252e5bc6dbd01d4dd5593e Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 21 Apr 2014 01:59:27 -0400
Subject: added error handling to performManipulations

---
 KeyRing.hs | 90 ++++++++++++++++++++++++++++++++++----------------------------
 1 file changed, 50 insertions(+), 40 deletions(-)

(limited to 'KeyRing.hs')

diff --git a/KeyRing.hs b/KeyRing.hs
index 653a76d..49a6069 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -19,7 +19,7 @@ import Data.Functor
 import Data.Monoid
 import Data.Tuple             ( swap )
 import Data.Bits              ( (.|.) )
-import Control.Applicative    ( liftA2, (<$>) )
+import Control.Applicative    ( Applicative, pure, liftA2, (<$>), (<*>) )
 import System.Directory       ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
 import Control.Arrow          ( first, second )
 import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
@@ -54,6 +54,7 @@ import Data.Binary ( encode )
 import Data.IORef
 import System.Posix.IO (fdToHandle,fdRead)
 import qualified Data.Traversable as Traversable (mapM,forM,sequence)
+import Data.Traversable ( sequenceA )
 #if ! MIN_VERSION_base(4,6,0)
 import GHC.Exts ( Down(..) )
 #endif
@@ -292,12 +293,22 @@ data KikiCondition a = KikiSuccess a
     | CantFindHome
     | AmbiguousKeySpec FilePath
     | CannotImportMasterKey
+    | NoWorkingKey
  deriving ( Functor, Show )
 
 instance FunctorToMaybe KikiCondition where
     functorToMaybe (KikiSuccess a) = Just a
     functorToMaybe _               = Nothing
 
+instance Applicative KikiCondition where
+    pure a  = KikiSuccess a
+    f <*> a =
+        case functorToEither f of
+            Right f  -> case functorToEither a of
+                            Right a  -> pure (f a)
+                            Left err -> err
+            Left err -> err
+
 data KikiReportAction =
         NewPacket String
         | MissingPacket String
@@ -1339,46 +1350,45 @@ performManipulations ::
                 -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
 performManipulations doDecrypt operation rt wk = do
     let db = rtKeyDB rt
-    db <- let perform kd (InducerSignature uid subpaks) = do
-                   case wk of
-                        Nothing  -> error "TODO no working key" -- todo
-                        Just wk' -> do
-                            wkun' <- doDecrypt wk'
-                            case functorToEither wkun' of
-                                Left  e    -> error "Bad passphrase, todo"
-                                Right wkun -> do
-                                    let sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) subpaks
-                                    sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
-                                    let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
-                                        f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
-                                              , om `Map.union` snd x )
-                                        om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
-                                        toMappedPacket om p = (mappedPacket "" p) {locations=om}
-                                        selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
-                                                               . (== keykey whosign)
-                                                               . keykey)) vs
-                                        keys = map keyPacket $ Map.elems (rtKeyDB rt)
-                                        overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
-                                        vs :: [ ( Packet -- signature
-                                               , Maybe SignatureOver -- Nothing means non-verified
-                                               , Packet ) -- key who signed
-                                             ]
-                                        vs = do
-                                               x <- maybeToList $ Map.lookup uid (rentryUids kd)
-                                               sig <- map (packet . fst) (fst x)
-                                               o <- overs sig
-                                               k <- keys
-                                               let ov = verify (Message [k]) $ o
-                                               signatures_over ov
-                                               return (sig,Just ov,k)
-                                        additional new_sig = do
-                                            new_sig <- maybeToList new_sig
-                                            guard (null $ selfsigs)
-                                            signatures_over new_sig
-                                    return kd { rentryUids = Map.adjust f uid (rentryUids kd) }
-            in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db
+        performAll kd = foldM perform (KikiSuccess kd) $ kManip operation rt kd
+    r <- Traversable.mapM performAll db
+    try (sequenceA r) $ \db -> do
     return $ KikiSuccess (rt { rtKeyDB = db },[])
-
+ where
+    perform kd (InducerSignature uid subpaks) = do
+        try kd $ \kd -> do
+        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
+        wkun' <- doDecrypt wk'
+        try wkun' $ \wkun -> do    
+        let sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) subpaks
+        sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
+        let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
+            f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
+                  , om `Map.union` snd x )
+            om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
+            toMappedPacket om p = (mappedPacket "" p) {locations=om}
+            selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
+                                   . (== keykey whosign)
+                                   . keykey)) vs
+            keys = map keyPacket $ Map.elems (rtKeyDB rt)
+            overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
+            vs :: [ ( Packet -- signature
+                   , Maybe SignatureOver -- Nothing means non-verified
+                   , Packet ) -- key who signed
+                 ]
+            vs = do
+                   x <- maybeToList $ Map.lookup uid (rentryUids kd)
+                   sig <- map (packet . fst) (fst x)
+                   o <- overs sig
+                   k <- keys
+                   let ov = verify (Message [k]) $ o
+                   signatures_over ov
+                   return (sig,Just ov,k)
+            additional new_sig = do
+                new_sig <- maybeToList new_sig
+                guard (null $ selfsigs)
+                signatures_over new_sig
+        return $ KikiSuccess $ kd { rentryUids = Map.adjust f uid (rentryUids kd) }
 
 initializeMissingPEMFiles ::
     KeyRingOperation
-- 
cgit v1.2.3