fixes related to creating key files via external commands

2 files changed, 130 insertions, 103 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 8cd4bcb..c595d77 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -529,6 +529,70 @@ parseSpec grip spec = (topspec,subspec)
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
 filterMatches spec ks = filter (matchSpec spec) ks
 
+selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
+
+selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
+
+selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectKey0 wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
+    let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys
+        zs = snd $ seek_key subspec ys1
+    listToMaybe zs
+
+seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
+seek_key (KeyGrip grip) sec = (pre, subs)
+  where
+    (pre,subs) = break pred sec
+    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
+    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
+    pred _                      = False
+
+seek_key (KeyTag key tag) ps = if null bs
+                                then (ps,[])
+                                else if null qs
+                                 then let (as',bs') = seek_key (KeyTag key tag) (tail bs)
+                                      in (as ++ (head bs:as'), bs')
+                                 else (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (\p -> isSignaturePacket p
+                        && has_tag tag p
+                        && isJust (signature_issuer p)
+                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
+                    ps
+    (rs,qs) = break isKey (reverse as)
+
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+seek_key (KeyUidMatch pat) ps = if null bs
+                                then (ps,[])
+                                else if null qs
+                                 then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs)
+                                      in (as ++ (head bs:as'), bs')
+                                 else (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (isInfixOf pat . uidStr)
+                    ps
+    (rs,qs) = break isKey (reverse as)
+
+    uidStr (UserIDPacket s) = s
+    uidStr _                = ""
+
+
+importPEMKey db' tup = do
+            try db' $ \(db',report0) -> do
+            r <- doImport doDecrypt 
+                      db'
+                      tup
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+ where doDecrypt = todo
+
 
 buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
               -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)]))
@@ -559,14 +623,6 @@ buildKeyDB secring pubring grip0 keyring = do
             try r $ \(db'',report) -> do
             return $ KikiSuccess (db'', report0 ++ report)
 
-        importPEMKey db' tup = do
-            try db' $ \(db',report0) -> do
-            r <- doImport doDecrypt 
-                      db'
-                      tup
-            try r $ \(db'',report) -> do
-            return $ KikiSuccess (db'', report0 ++ report)
-
         doDecrypt = todo
 
     -- KeyRings (todo: KikiCondition reporting?)
@@ -929,46 +985,71 @@ runKeyRing keyring = do
       if not $ null failed_locks
         then return $ KikiResult (FailedToLock failed_locks) []
         else do
+
+         let doDecrypt = todo
+
+         -- merge all keyrings, PEM files, and wallets
+         bresult <- buildKeyDB secring pubring grip0 keyring
+
+         try' bresult $ \((db,grip,wk),report_imports) -> do
+
+         nonexistents <- 
+            filterM (fmap not . doesFileExist . fst)
+                $ do (f,t) <- Map.toList (kFiles keyring)
+                     f <- resolveInputFile secring pubring f
+                     return (f,t)
+
+
          -- create nonexistent files via external commands
-         report_externals <- do
+         externals_ret <- do
             let cmds = do
-                 (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
+                 (fname,(rtyp,ftyp)) <- nonexistents
                  cmd <- maybeToList (initializer rtyp)
-                 (_,subspec) <- fmap (parseSpec "") $ getUsage ftyp
-                 fname <- resolveInputFile secring pubring f
-                 return (fname,maybe "" id subspec,cmd)
-            forM cmds $ \(fname,usage,cmd) -> do
+                 (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip)
+                                        $ getUsage ftyp
+                 let ms = map fst $ filterMatches topspec (Map.toList db)
+                 guard $ isNothing $ selectPublicKey (topspec,subspec) db
+                 return (fname,subspec,ms,cmd)
+            rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do
                 e <- systemEnv [ ("file",fname)
-                               , ("usage",usage) ]
+                               , ("usage",maybe "" id subspec) ]
                                cmd
                 case e of
-                    ExitFailure num -> return (fname,FailedExternal num)
-                    ExitSuccess     -> return (fname,ExternallyGeneratedFile)
+                  ExitFailure num -> return (tup,FailedExternal num)
+                  ExitSuccess     -> return (tup,ExternallyGeneratedFile)
 
-         -- merge all keyrings, PEM files, and wallets
-         bresult <- buildKeyDB secring pubring grip0 keyring
+            v <- foldM importPEMKey (KikiSuccess (db,[])) $ do
+                     (tup,r) <- rs
+                     guard $ case r of
+                        ExternallyGeneratedFile -> True
+                        _ -> False
+                     return tup
 
-         try' bresult $ \((db,grip,wk),report_imports) -> do
-             let a = KeyRingRuntime
-                            { rtPubring = pubring
-                            , rtSecring = secring
-                            , rtGrip = grip
-                            , rtKeyDB = db
-                            }
+            try v $ \(db,import_rs) -> do
+            return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs
+                                      ++ import_rs)
 
-             r <- writeWalletKeys keyring db wk
-             try' r $ \report_wallets -> do
+         try' externals_ret $ \(db,report_externals) -> do
 
-             r <- writeRingKeys keyring db wk secring pubring
-             try' r $ \report_rings -> do
+         r <- writeWalletKeys keyring db wk
+         try' r $ \report_wallets -> do
 
-             -- todo writePEMKeys
+         r <- writeRingKeys keyring db wk secring pubring
+         try' r $ \report_rings -> do
 
-             return $ KikiResult (KikiSuccess a)
-                        $ concat [ report_externals
-                                 , report_imports
-                                 , report_wallets
-                                 , report_rings ]
+         -- todo writePEMKeys
+
+         let rt = KeyRingRuntime
+                        { rtPubring = pubring
+                        , rtSecring = secring
+                        , rtGrip = grip
+                        , rtKeyDB = db
+                        }
+         return $ KikiResult (KikiSuccess rt)
+                    $ concat [ report_imports
+                             , report_externals
+                             , report_wallets
+                             , report_rings ]
 
     forM_ lked $ \(Just lk, fname) -> dotlock_release lk
 
@@ -1524,6 +1605,19 @@ sortByHint fname f = sortBy (comparing gethint)
     gethint = maybe defnum originalNum . Map.lookup fname . locations . f
     defnum = -1
 
+flattenKeys :: Bool -> KeyDB -> Message
+flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
+ where
+    prefilter = if isPublic then id else filter isSecret
+                 where
+                  isSecret (_,(KeyData
+                                  (MappedPacket { packet=(SecretKeyPacket {})})
+                                  _
+                                  _
+                                  _)) = True
+                  isSecret _          = False
+
+
 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
 flattenTop fname ispub (KeyData key sigs uids subkeys) =
     unk ispub key : 
diff --git a/kiki.hs b/kiki.hs
index 1c6fa37..43d170c 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -650,19 +650,6 @@ getPassphrase cmd =
 
 #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
 
-flattenKeys :: Bool -> KeyDB -> Message
-flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
- where
-    prefilter = if isPublic then id else filter isSecret
-                 where
-                  isSecret (_,(KeyData
-                                  (MappedPacket { packet=(SecretKeyPacket {})})
-                                  _
-                                  _
-                                  _)) = True
-                  isSecret _          = False
-
-
 writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
 writeOutKeyrings lkmap db = do
     let ks = Map.elems db
@@ -1704,60 +1691,6 @@ isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True
 isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True
 isTopKey _ = False
 
-selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
-selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
-
-selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
-selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
-
-selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
-selectKey0 wantPublic (spec,mtag) db = do
-    let Message ps = flattenKeys wantPublic db
-        ys = snd $ seek_key spec ps
-    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
-    let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys
-        zs = snd $ seek_key subspec ys1
-    listToMaybe zs
-
-seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
-seek_key (KeyGrip grip) sec = (pre, subs)
-  where
-    (pre,subs) = break pred sec
-    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
-    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
-    pred _                      = False
-
-seek_key (KeyTag key tag) ps = if null bs
-                                then (ps,[])
-                                else if null qs
-                                 then let (as',bs') = seek_key (KeyTag key tag) (tail bs)
-                                      in (as ++ (head bs:as'), bs')
-                                 else (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (\p -> isSignaturePacket p
-                        && has_tag tag p
-                        && isJust (signature_issuer p)
-                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
-                    ps
-    (rs,qs) = break isKey (reverse as)
-
-    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
-                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
-
-seek_key (KeyUidMatch pat) ps = if null bs
-                                then (ps,[])
-                                else if null qs
-                                 then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs)
-                                      in (as ++ (head bs:as'), bs')
-                                 else (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (isInfixOf pat . uidStr)
-                    ps
-    (rs,qs) = break isKey (reverse as)
-
-    uidStr (UserIDPacket s) = s
-    uidStr _                = ""
-
 groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps