abstract the performManipulations step

1 files changed, 56 insertions, 55 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 4973aa4..36477c0 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1205,6 +1205,55 @@ doDecrypt unkeysRef pws mp = do
                    (return . KikiSuccess)
                 $ Map.lookup kk unkeys
 
+performManipulations ::
+                (MappedPacket -> IO (KikiCondition Packet))
+                -> KeyRingOperation
+                -> KeyRingRuntime
+                -> Maybe MappedPacket 
+                -> IO (KikiCondition (KeyDB,[(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
+    return $ KikiSuccess (db,[])
+
+
 {-
 interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
 interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
@@ -1321,62 +1370,13 @@ runKeyRing operation = do
 
         try' externals_ret $ \(db,report_externals) -> do
 
-        db <- let perform kd (InducerSignature uid subpaks) = do
-                       case wk of
-                            Nothing  -> error "TODO no working key" -- todo
-                            Just wk' -> do
-                                wkun' <- doDecrypt unkeysRef pws 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
 
-{-
-        let manips0 = kManip operation rt
-            manips :: Map.Map KeyKey [KeyRingAddress PacketUpdate]
-            manips = Map.fromList $ do
-                ms <- groupBy ((==EQ) .: comparing topkeyAddress)
-                        $ sortBy (comparing topkeyAddress)
-                                 manips0
-                k <- fmap topkeyAddress $ take 1 ms
-                return (k,ms)
-              where (.:) = (.).(.)
-            doManips kd = do
-                let kk = keykey $ keyPacket kd
-                    ms = maybe [] id $ Map.lookup kk manips
-                foldM interpretManip kd ms
-
-        db' <- Traversable.mapM doManips db
--}
+        r <- performManipulations (doDecrypt unkeysRef pws)
+                                  operation
+                                  rt
+                                  wk
+        try' r $ \(db,report_manips) -> do
+        rt <- return $ rt { rtKeyDB = db }
 
         r <- writeWalletKeys operation db (fmap packet wk)
         try' r $ \report_wallets -> do
@@ -1390,6 +1390,7 @@ runKeyRing operation = do
         return $ KikiResult (KikiSuccess rt)
                    $ concat [ report_imports
                             , report_externals
+                            , report_manips
                             , report_wallets
                             , report_rings
                             , report_pems ]