bug fixes.

2 files changed, 74 insertions, 44 deletions

diff --git a/kiki.cabal b/kiki.cabal
index fbf9470..0a517f0 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -20,6 +20,6 @@ Executable kiki
                      dataenc -any, text -any, pretty -any, pretty-show -any,
                      bytestring -any, openpgp (==0.6.1), binary -any,
                      unix, time, crypto-api, cryptocipher (>=0.3.7),
-                     containers -any
+                     containers -any, process -any, filepath -any
     ghc-options:     -O2
     c-sources: dotlock.c
diff --git a/kiki.hs b/kiki.hs
index e6e0630..54cacc3 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -11,6 +11,7 @@ module Main where
 import Debug.Trace
 import GHC.Exts (Down(..))
 import GHC.IO.Exception ( ioException, IOErrorType(..) )
+import Data.IORef
 import Data.Tuple
 import Data.Binary
 import Data.OpenPGP
@@ -41,6 +42,7 @@ import Data.ASN1.BitArray
 import Control.Applicative
 import System.Environment
 import System.Directory
+import System.FilePath
 import System.Exit
 import System.Process
 import System.Posix.IO (fdToHandle,fdRead)
@@ -602,6 +604,7 @@ expandPath path []                 = []
 
 readPacketsFromFile :: FilePath -> IO Message
 readPacketsFromFile fname = do
+    -- warn $ fname ++ ": reading..."
     input <- L.readFile fname
     return $
       case decodeOrFail input of
@@ -807,15 +810,24 @@ writeKeyToFile False "PEM" fname packet = do
         dta = Base64.encode (L.unpack bs)
         output = writePEM "RSA PRIVATE KEY" dta
         stamp = toEnum . fromEnum $ timestamp packet
-    writeFile fname output
-    -- Note: The key's timestamp is included in it's fingerprint.
-    --       Therefore, we should attempt to preserve it.
-    setFileTimes fname stamp stamp
+    createDirectoryIfMissing True (takeDirectory fname)
+    handleIO_ (warn $ fname ++ ": write failure") $ do
+        saved_mask <- setFileCreationMask 0o077
+        writeFile fname output
+        -- Note: The key's timestamp is included in it's fingerprint.
+        --       Therefore, we should attempt to preserve it.
+        setFileTimes fname stamp stamp
+        setFileCreationMask saved_mask
+        return ()
+    -- warn $ fname++ ": wrote"
+    return ()
 
 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 <- modificationTime <$> getFileStatus fname
+    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
+                    modificationTime <$> getFileStatus fname
     input <- L.readFile fname
     let dta = extractPEM "RSA PRIVATE KEY" input
     -- Char8.putStrLn $ "dta = " <> dta
@@ -1125,8 +1137,8 @@ writeOutKeyrings lkmap db = do
                 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyPacket ks)
                 n <- maybeToList $ Map.lookup f (locations p)
                 flattenTop f (originallyPublic n) d
-            changes = filter notnew x
-                where notnew p = isNothing (Map.lookup f $ locations p)
+            changes = filter isnew x
+                where isnew p = isNothing (Map.lookup f $ locations p)
         {-
         trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
                   ( "CHANGES: " : map (("  "++) . showPacket . packet) changes)) $ do
@@ -1166,17 +1178,17 @@ cross_merge keyrings f = do
                               where isSecringKey (fn,Message ps)
                                         | fn==sec_n = listToMaybe ps
                                     isSecringKey _  = Nothing
-                -- unlockFiles fsns -----------
-                -------------------------------
-                db' <- f (sec_n,fstkey) db 
-                -- lk <- relock ---------------
-                let lk = (fsns,failed_locks) --
+                -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
+                ------------------------------- from external tools. 
+                (db',_) <- f (sec_n,fstkey) db
+                -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
+                let lk = (fsns,failed_locks) -- 
                 -------------------------------
                 maybe (if n==0 then pass 1 lk else return (lk,db))
                       (return . (lk,))
                       db'
         ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks)
-        let lkmap = Map.fromList (map swap fsns)
+        let lkmap = Map.fromList $ map swap fsns
         writeOutKeyrings lkmap db
         unlockFiles fsns
         return ()
@@ -1281,7 +1293,7 @@ systemEnv vars cmd = do
       _ <- installHandler sigQUIT old_quit Nothing
       return r
 
-doExport doDecrypt db (fname,subspec,ms,cmd) =
+doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) =
         case ms of
             [_]   -> export
             (_:_) -> ambiguous
@@ -1291,20 +1303,23 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
     shcmd = do
         let noop warning = do
             warn warning
-            return db
+            return (db,use_db)
         if null cmd then noop (fname ++ ": missing.") else do
         let vars = [ ("file",fname)
                    , ("usage",maybe "" id subspec) ]
         e <- systemEnv vars cmd
         case e of
             ExitFailure num -> noop $ fname ++ ": failed external (code="++show num++")"
-            ExitSuccess     -> return Nothing -- need another pass
+            ExitSuccess     -> do
+                warn $ fname ++ ": generated"
+                return (Nothing,use_db) -- need another pass
     export = do
-        let [(kk,KeyData key sigs uids subkeys)] = ms
+        let [kk] = ms
+            Just (KeyData key sigs uids subkeys) = Map.lookup kk use_db
             p = flip (maybe (Just $ packet key)) subspec $ \tag -> do
                   let subs = Map.elems subkeys
                       doSearch (SubKey sub_mp sigtrusts) =
-                        let (_,v,_) = searchSubkeys tag
+                        let (_,v,_) = findTag tag
                                           (packet key)
                                           (packet sub_mp) 
                                           sigtrusts
@@ -1316,11 +1331,11 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
         flip (maybe shcmd) p $ \p -> do
         pun <- doDecrypt p
         flip (maybe $ error "Bad passphrase?") pun $ \pun -> do
-        warn $ "writing "++fname
         writeKeyToFile False "PEM" fname pun
-        return db
+        warn $ fname ++ ": exported"
+        return (db,use_db)
 
-searchSubkeys tag wk subkey subsigs = (xs',minsig,ys')
+findTag tag wk subkey subsigs = (xs',minsig,ys')
          where
             vs = map (\sig ->
                           (sig, do
@@ -1337,7 +1352,7 @@ searchSubkeys tag wk subkey subsigs = (xs',minsig,ys')
                      subsigs
             (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
             xs' = map fst xs
-            ys' = map fst (drop 1 ys)
+            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
             minsig = do
                 (sig,ov) <- listToMaybe ys
                 ov
@@ -1360,7 +1375,8 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
     let (m0,tailms) = splitAt 1 ms
     when (not (null tailms) || null m0)
         $ error "Key specification is ambiguous."
-    let (kk,KeyData top topsigs uids subs) = head m0
+    let kk = head m0
+        Just (KeyData top topsigs uids subs) = Map.lookup kk db
     let subkk = keykey key
         (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
                                                [])
@@ -1368,15 +1384,15 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
                                  (Map.lookup subkk subs)
     let SubKey subkey_p subsigs = subkey
         wk = packet top
-        (xs',minsig,ys') = searchSubkeys tag wk key subsigs
+        (xs',minsig,ys') = findTag tag wk key subsigs
         doInsert mbsig db = do
             sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
             warn $ fname ++ ": yield SignaturePacket"
-            let subs' = Map.insert subkk 
+            let subs' = Map.insert subkk
                                    (SubKey subkey_p $ xs'++[sig']++ys')
                                    subs
             return $ Map.insert kk (KeyData top topsigs uids subs') db
-    when is_new (warn $ fname ++ ": yield SecretKeyPacket "++fingerprint key)
+    when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key))
     case minsig of
         Nothing          -> doInsert Nothing db    -- we need to create a new sig
         Just (True,sig)  -> return db              -- we can deduce is_new == False
@@ -1529,6 +1545,8 @@ main = do
                                   $ args'
                           appendArgs xs = Just . maybe xs (++xs)
     -- putStrLn $ "margs = " ++ show (Map.assocs margs)
+    unkeysRef <- newIORef Map.empty
+    pwRef <- newIORef Nothing
     let keypairs0 =
             flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do
                 let (spec,efilecmd) = break (=='=') specfile
@@ -1550,19 +1568,27 @@ main = do
         keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
         decrypt wk = do
-            -- TODO: memoize?
-            pw <- case passphrase_fd of
+            -- warn $ "decryptKey "++fingerprint wk
+            unkeys <- readIORef unkeysRef
+            let kk = keykey wk
+            flip (flip maybe $ return . Just) (Map.lookup kk unkeys) $ do
+            let ret wkun = do writeIORef unkeysRef (Map.insert kk wkun unkeys)
+                              return (Just wkun)
+            if symmetric_algorithm wk == Unencrypted then ret wk else do
+            pw <- do
+                pw <- readIORef pwRef
+                flip (flip maybe return) pw $ do
+                case passphrase_fd of
                     Just fd -> do pwh <- fdToHandle (read fd)
-                                  fmap trimCR $ S.hGetContents pwh
+                                  pw <- fmap trimCR $ S.hGetContents pwh
+                                  writeIORef pwRef (Just pw)
+                                  return pw
                     Nothing -> return ""
-            let wkun = 
-                 if symmetric_algorithm wk == Unencrypted
-                    then Just wk
-                    else do
-                        k <- decryptSecretKey pw wk
-                        guard (symmetric_algorithm k == Unencrypted)
-                        return k
-            return wkun
+            let wkun = do
+                k <- decryptSecretKey pw wk
+                guard (symmetric_algorithm k == Unencrypted)
+                return k
+            maybe (return Nothing) ret wkun
 
     when (not . null $ filter isNothing keypairs0) $ do
         warn "syntax error"
@@ -1601,19 +1627,23 @@ main = do
                               }
                 dont_have (KeyData p _ _ _) = not . Map.member pubring
                                                    $ locations p
-        use_db <- get_use_db
+        use_db0 <- get_use_db
 
         let pkeypairs = maybe [] id $ do
                             g <- grip
                             return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs
         fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do
-            let ms = filterMatches topspec (Map.toList db)
+            -- Note that it's important to discard the KeyData objects
+            -- returned by filterMatches and retain only the keys.
+            -- Otherwise, the iterations within the foldM would not be
+            -- able to alter them by returning a modified KeyDB.
+            let ms = map fst $ filterMatches topspec (Map.toList db)
             f_found <- doesFileExist f
             return (f_found,(f,subspec,ms,cmd))
 
         let (imports,exports) = partition fst fs
-        use_db <- foldM (doImport decrypt) use_db (map snd imports)
-        ret_db <- foldM (doExport decrypt) (Just use_db) (map snd exports)
+        use_db <- foldM (doImport decrypt) use_db0 (map snd imports)
+        (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports)
 
         flip (maybe $ return ()) ret_db . const $ do
             -- On last pass, interpret --show-* commands.
@@ -1623,7 +1653,7 @@ main = do
                 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
 
             forM_ shargs $ \(cmd,args) -> cmd args use_db
-        return $ ret_db
+        return $ (ret_db,use_db)
 
     return()
  where
@@ -1863,7 +1893,7 @@ main = do
     doCmd cmd@(Cross_Merge {}) = do
         (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd)
         -- grip0 may be empty, in which case we should use the first key
-        cross_merge (secring:pubring:files cmd) $ \_ db -> return $ Just db
+        cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db)
 
     {-
     doCmd cmd@(CatPub {}) = do