more progress on writeRingKeys

2 files changed, 47 insertions, 27 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index d3c4c24..eda19d1 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFunctor #-}
 module KeyRing where
 
 import System.Environment
@@ -173,13 +174,8 @@ data KikiCondition a = KikiSuccess a
     | BadPassphrase
     | FailedToMakeSignature
     | CantFindHome
+ deriving ( Functor, Show )
 
-#define TRIVIAL(OP) fmap _ (OP) = OP
-instance Functor KikiCondition where
-    fmap f (KikiSuccess a) = KikiSuccess (f a)
-    TRIVIAL( FailedToLock x )
-    TRIVIAL( BadPassphrase )
-    TRIVIAL( FailedToMakeSignature )
 instance FunctorToMaybe KikiCondition where
     functorToMaybe (KikiSuccess a) = Just a
     functorToMaybe _               = Nothing
@@ -493,11 +489,11 @@ derRSA rsa = do
     k <- rsaKeyFromPacket rsa
     return $ encodeASN1 DER (toASN1 k [])
 
-try :: KikiCondition a -> (a -> IO (KikiCondition b)) -> IO (KikiCondition b)
-try wkun body =
-    case functorToEither wkun of
+try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
+try x body =
+    case functorToEither x of
            Left e -> return e
-           Right wkun -> body wkun
+           Right x -> body x
 
 doImportG
   :: Ord k =>
@@ -648,15 +644,41 @@ writeWalletKeys krd db wk = do
     report <- foldM writeWallet [] (files isMutableWallet)
     return $ KikiSuccess report
 
-writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
-writeRingKeys krd db wk = do
+ifSecret (SecretKeyPacket {}) t f = t
+ifSecret _                    t f = f
+
+showPacket :: Packet -> String
+showPacket p | isKey p   = (if is_subkey p 
+                              then showPacket0 p
+                              else ifSecret p "----Secret-----" "----Public-----")
+                           ++ " "++show (key_algorithm p)++" "++fingerprint p
+             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
+             | otherwise = showPacket0 p
+showPacket0 p = concat . take 1 $ words (show p)
+
+
+writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet
+                -> FilePath -> FilePath
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writeRingKeys krd db wk secring pubring = do
     let ks = Map.elems db
+        {-
         fs = Map.keys (foldr unionfiles Map.empty ks)
                 where unionfiles (KeyData p _ _ _) m =
                         Map.union m (locations p)
+        -}
+        isring (KeyRingFile {}) = True
+        isring _                = False
+        isMutable (MutableRef {}) = True
+        isMutable _               = False
+        fs = do
+            (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
+            guard (isring ftyp)
+            n <- resolveInputFile secring pubring f
+            return (n,isMutable rtyp)
         fromfile f (KeyData p _ _ _) = Map.member f $ locations p
     let s = do
-        f <- fs
+        (f,mutable) <- fs
         let x = do
                 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyMappedPacket ks)
                 n <- maybeToList $ Map.lookup f (locations p)
@@ -667,7 +689,17 @@ writeRingKeys krd db wk = do
         trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
                   ( "CHANGES: " : map (("  "++) . showPacket . packet) changes)) $ do
         -}
-        return (f,(changes,x))
+        guard (not $ null changes)
+        return ((f,mutable),(changes,x))
+    let (towrites,report) = (\f -> foldl f ([],[]) s) $
+         \(ws,report) ((f,mutable),(changes,x)) ->
+            if mutable
+                then 
+                     let rs = flip map changes $ \c -> (f, NewPacket $ showPacket (packet c))
+                     in (ws++[(f,x)],report++rs)
+                else
+                     let rs = flip map changes $ \c -> (f,MissingPacket (showPacket (packet c)))
+                     in (ws,report++rs)
     todo -- porting from kiki.hs writeOutKeyrings
     return $ KikiSuccess []
 
@@ -705,7 +737,7 @@ runKeyRing keyring op = do
                             }
              r <- writeWalletKeys keyring db wk
              try' r $ \report2 -> do
-             r <- writeRingKeys keyring db wk
+             r <- writeRingKeys keyring db wk secring pubring
              try' r $ \report3 -> do
              return $ KikiResult (KikiSuccess a) (report1 ++ report3)
       Left err -> return $ KikiResult err []
diff --git a/kiki.hs b/kiki.hs
index 41e6e6b..66e3e4f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -766,18 +766,6 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
                   isSecret _          = False
 
 
-ifSecret (SecretKeyPacket {}) t f = t
-ifSecret _                    t f = f
-
-showPacket :: Packet -> String
-showPacket p | isKey p   = (if is_subkey p 
-                              then showPacket0 p
-                              else ifSecret p "----Secret-----" "----Public-----")
-                           ++ " "++show (key_algorithm p)++" "++fingerprint p
-             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
-             | otherwise = showPacket0 p
-showPacket0 p = concat . take 1 $ words (show p)
-
 writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
 writeOutKeyrings lkmap db = do
     let ks = Map.elems db