performManipulations returns KeyRingRuntime rather than just the KeyDB

1 files changed, 54 insertions, 58 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index b0e24de..5149da4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -99,7 +99,7 @@ data FileType = KeyRingFile (Maybe PassWordFile)
 -- | RefType is perhaps not a good name for this...
 --   It is sort of like a read/write flag, although
 --   semantically, it is indicating the intention of
---   an action and not just the access level of an 
+--   an action and not just the access level of an
 --   object.
 data RefType = ConstRef
              -- ^ merge into database but do not update
@@ -149,7 +149,7 @@ noManip _ _ = []
 data KeyRingOperation = KeyRingOperation
     { kFiles :: Map.Map InputFile (RefType,FileType)
     , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool)
-    -- ^ 
+    -- ^
     -- Indicates what pgp master keys get written to which keyring files.
     --   Just True  = import public key
     --   Just False = import secret key
@@ -488,7 +488,7 @@ keyFlags0 wkun uidsigs = concat
     isfeatures _ = False
 
 
-matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 
+matchSpec (KeyGrip grip) (_,KeyData p _ _ _)
     | matchpr grip (packet p)==grip = True
     | otherwise                     = False
 
@@ -608,7 +608,7 @@ selectAll wantPublic (spec,mtag) db = do
     y <- take 1 ys
     case mtag of
         Nothing -> return (y,Nothing)
-        Just tag -> 
+        Just tag ->
             let search ys1 = do
                     let zs = snd $ seek_key (KeyTag y tag) ys1
                     z <- take 1 zs
@@ -664,12 +664,12 @@ cachedContents secring pubring fd = do
     trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
 
     get ref fd = do
-        pw <- readIORef ref 
+        pw <- readIORef ref
         flip (flip maybe return) pw $ do
             pw <- fmap trimCR $ getContents fd
             writeIORef ref (Just pw)
             return pw
-        
+
     getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents
     getContents inp = do
         let fname = resolveInputFile secring pubring inp
@@ -677,7 +677,7 @@ cachedContents secring pubring fd = do
 
 importPEMKey doDecrypt db' tup = do
             try db' $ \(db',report0) -> do
-            r <- doImport doDecrypt 
+            r <- doImport doDecrypt
                       db'
                       tup
             try r $ \(db'',report) -> do
@@ -688,7 +688,7 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
               -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket)
                                    ,[(FilePath,KikiReportAction)]))
 buildKeyDB doDecrypt secring pubring grip0 keyring = do
-    let 
+    let
 
         files isring = do
             (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
@@ -701,7 +701,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
 
         importWalletKey wk db' (top,fname,sub,tag) = do
             try db' $ \(db',report0) -> do
-            r <- doImportG doDecrypt 
+            r <- doImportG doDecrypt
                       db'
                       (fmap keykey $ maybeToList wk)
                       tag
@@ -715,7 +715,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
         ms <- mapM readp (files isring)
         let grip = grip0 `mplus` (fingerprint <$> fstkey)
               where
-                fstkey = listToMaybe $ mapMaybe isSecringKey ms 
+                fstkey = listToMaybe $ mapMaybe isSecringKey ms
                           where isSecringKey (fn,Message ps)
                                     | fn==secring = listToMaybe ps
                                 isSecringKey _  = Nothing
@@ -774,7 +774,7 @@ readKeyFromFile False "PEM" fname = do
     -- warn $ fname ++ ": reading ..."
     -- Note: The key's timestamp is included in it's fingerprint.
     --       Therefore, we should attempt to preserve it.
-    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
+    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
                     modificationTime <$> getFileStatus fname
     input <- L.readFile fname
     let dta = extractPEM "RSA PRIVATE KEY" input
@@ -855,7 +855,7 @@ doImportG doDecrypt db m0 tag fname key = do
                                  ( (False,) . addOrigin )
                                  (Map.lookup subkk subs)
                              where
-                                addOrigin (SubKey mp sigs) = 
+                                addOrigin (SubKey mp sigs) =
                                     let mp' = mp
                                           { locations = Map.insert fname
                                                              (origin (packet mp) (-1))
@@ -892,7 +892,7 @@ doImportG doDecrypt db m0 tag fname key = do
                      $ \sig -> do
                 let om = Map.singleton fname (origin sig (-1))
                     trust = Map.empty
-                return $ KikiSuccess 
+                return $ KikiSuccess
                     ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
                                          , trust)],om) uids
                     , [] )
@@ -990,7 +990,7 @@ ifSecret (SecretKeyPacket {}) t f = t
 ifSecret _                    t f = f
 
 showPacket :: Packet -> String
-showPacket p | isKey p   = (if is_subkey p 
+showPacket p | isKey p   = (if is_subkey p
                               then showPacket0 p
                               else ifSecret p "----Secret-----" "----Public-----")
                            ++ " "++show (key_algorithm p)++" "++fingerprint p
@@ -1059,7 +1059,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
     let (towrites,report) = (\f -> foldl f ([],[]) s) $
          \(ws,report) ((f,mutable),(new_packets,x)) ->
             if mutable
-                then 
+                then
                      let rs = flip map new_packets
                                 $ \c -> (f, NewPacket $ showPacket (packet c))
                      in (ws++[(f,x)],report++rs)
@@ -1090,7 +1090,7 @@ subkeysForExport subspec (KeyData key _ _ subkeys) = do
     doSearch key tag (SubKey sub_mp sigtrusts) =
         let (_,v,_) = findTag tag
                           (packet key)
-                          (packet sub_mp) 
+                          (packet sub_mp)
                           sigtrusts
         in fmap fst v==Just True
 
@@ -1119,11 +1119,11 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
     -- Ideally, it would be better to compute (inverse q) mod p
     -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
     --     (package constructive-algebra)
-    coefficient <- lookup 'u' $ key pkt 
+    coefficient <- lookup 'u' $ key pkt
 
     let dmodp1 = MPI $ d `mod` (p - 1)
         dmodqminus1 = MPI $ d `mod` (q - 1)
-    return $ RSAPrivateKey 
+    return $ RSAPrivateKey
         { rsaN = n
         , rsaE = e
         , rsaD = MPI d
@@ -1222,8 +1222,8 @@ performManipulations ::
                 (MappedPacket -> IO (KikiCondition Packet))
                 -> KeyRingOperation
                 -> KeyRingRuntime
-                -> Maybe MappedPacket 
-                -> IO (KikiCondition (KeyDB,[(FilePath,KikiReportAction)]))
+                -> Maybe MappedPacket
+                -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
 performManipulations doDecrypt operation rt wk = do
     let db = rtKeyDB rt
     db <- let perform kd (InducerSignature uid subpaks) = do
@@ -1241,8 +1241,8 @@ performManipulations doDecrypt operation rt wk = do
                                               , 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) 
+                                        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])
@@ -1250,21 +1250,21 @@ performManipulations doDecrypt operation rt wk = do
                                                , Maybe SignatureOver -- Nothing means non-verified
                                                , Packet ) -- key who signed
                                              ]
-                                        vs = do 
+                                        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)                         
+                                               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,[])
+    return $ KikiSuccess (rt { rtKeyDB = db },[])
 
 
 initializeMissingPEMFiles ::
@@ -1278,7 +1278,7 @@ initializeMissingPEMFiles ::
                                      , Maybe Initializer)])
                            , [(FilePath,KikiReportAction)]))
 initializeMissingPEMFiles operation secring pubring grip decrypt db = do
-        nonexistents <- 
+        nonexistents <-
            filterM (fmap not . doesFileExist . fst)
                $ do (f,t) <- Map.toList (kFiles operation)
                     f <- resolveInputFile secring pubring f
@@ -1306,7 +1306,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do
 
             ifnotnull (x:xs) f g = f x
             ifnotnull _      f g = g
-       
+
         ifnotnull ambiguous ambiguity $ do
 
         -- create nonexistent files via external commands
@@ -1378,6 +1378,7 @@ runKeyRing operation = do
                                                    secring pubring grip
                                                    decrypt
                                                    db
+        try' externals_ret $ \((db,exports),report_externals) -> do
 
         let rt = KeyRingRuntime
                        { rtPubring = pubring
@@ -1387,24 +1388,19 @@ runKeyRing operation = do
                        , rtKeyDB = db
                        }
 
-        try' externals_ret $ \((db,exports),report_externals) -> do
-
-
-
-        r <- performManipulations decrypt 
+        r <- performManipulations decrypt
                                   operation
                                   rt
                                   wk
-        try' r $ \(db,report_manips) -> do
-        rt <- return $ rt { rtKeyDB = db }
+        try' r $ \(rt,report_manips) -> do
 
-        r <- writeWalletKeys operation db (fmap packet wk)
+        r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
         try' r $ \report_wallets -> do
 
         r <- writeRingKeys operation rt -- db wk secring pubring
         try' r $ \report_rings -> do
 
-        r <- writePEMKeys decrypt db exports
+        r <- writePEMKeys decrypt (rtKeyDB rt) exports
         try' r $ \report_pems -> do
 
         return $ KikiResult (KikiSuccess rt)
@@ -1452,7 +1448,7 @@ getHomeDir protohome = do
         let homegnupg = (++('/':(appdir home))) <$> homed
         let val = (opt `mplus` gnupghome `mplus` homegnupg)
         return $ val
-    
+
     -- TODO: rename this to getGrip
     getWorkingKey homedir = do
         let o = Nothing
@@ -1516,10 +1512,10 @@ slurpWIPKeys stamp "" = ([],[])
 slurpWIPKeys stamp cs =
     let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
         mb        = decode_btc_key stamp (Char8.unpack b58)
-    in if L.null b58 
+    in if L.null b58
         then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs
                  (ks,js)  = slurpWIPKeys stamp xs'
-             in (ks,ys:js) 
+             in (ks,ys:js)
         else let (ks,js) = slurpWIPKeys stamp xs
              in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
 
@@ -1548,7 +1544,7 @@ decode_btc_key timestamp str = do
                                 ,"y  ="++show y
                                 ,"y' ="++show y'
                                 ,"y''="++show y'']) -}
-            SecretKeyPacket 
+            SecretKeyPacket
             { version = 4
             , timestamp = toEnum (fromEnum timestamp)
             , key_algorithm = ECDSA
@@ -1579,12 +1575,12 @@ rsaKeyFromPacket p@(SecretKeyPacket {}) = do
 rsaKeyFromPacket _ = Nothing
 
 
-readPacketsFromWallet :: 
+readPacketsFromWallet ::
     Maybe Packet
-    -> FilePath 
+    -> FilePath
     -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
 readPacketsFromWallet wk fname = do
-    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
+    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
                     modificationTime <$> getFileStatus fname
     input <- L.readFile fname
     let (ks,_) = slurpWIPKeys timestamp input
@@ -1673,7 +1669,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
     let grip = fingerprint wk
         addOrigin new_sig = do
             flip (maybe $ return FailedToMakeSignature)
-                 (new_sig >>= listToMaybe . signatures_over) 
+                 (new_sig >>= listToMaybe . signatures_over)
                  $ \new_sig -> do
             let mp' = mappedPacket fname new_sig
             return $ KikiSuccess (mp', Map.empty)
@@ -1797,7 +1793,7 @@ origin p n = OriginFlags ispub n
                     SecretKeyPacket {} -> False
                     _                  -> True
 
-mappedPacket filename p = MappedPacket 
+mappedPacket filename p = MappedPacket
     { packet = p
     , usage_tag = Nothing
     , locations = Map.singleton filename (origin p (-1))
@@ -1860,10 +1856,10 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
      where
         -- NOTE:
         --  if a keyring file has both a public key packet and a secret key packet
-        --  for the same key, then only one of them will survive, which ever is 
+        --  for the same key, then only one of them will survive, which ever is
         --  later in the file.
-        -- 
-        --  This is due to the use of statements like 
+        --
+        --  This is due to the use of statements like
         --      (Map.insert filename (origin p n) (locations key))
         --
         update v | isKey p && not (is_subkey p)
@@ -1961,7 +1957,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
         "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
 
 unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
-unsig fname isPublic (sig,trustmap) = 
+unsig fname isPublic (sig,trustmap) =
     [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
   where
     f n _ = n==fname -- && trace ("fname=n="++show n) True
@@ -1990,7 +1986,7 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
 
 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
 flattenTop fname ispub (KeyData key sigs uids subkeys) =
-    unk ispub key : 
+    unk ispub key :
             ( flattenAllUids fname ispub uids
              ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
 
@@ -2006,11 +2002,11 @@ flattenAllUids fname ispub uids =
     concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
 
 flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
-flattenUid fname ispub (str,(sigs,om)) = 
+flattenUid fname ispub (str,(sigs,om)) =
     (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
 
 
- 
+
 {-
 data Kiki a =
     SinglePass (KeyRingOperation -> KeyRingAction a)
@@ -2031,14 +2027,14 @@ instance Functor Kiki where fmap f k = fmapWithRT (const f) k
 
 instance Monad Kiki where
     return x = SinglePass (const $ KeyRingAction x)
-    
+
     k >>= f  = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
                 where (.:) = (.) . (.)
 
 eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a
 eval rt (SinglePass f) kd =
     case f kd of KeyRingAction v -> v
-                 RunTimeAction g -> g rt                       
+                 RunTimeAction g -> g rt
 eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd
 
 eval' :: Kiki (KeyRingOperation -> a) -> Kiki a