create nonexistent PEM files via external shell commands

3 files changed, 99 insertions, 54 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index d5eb9ea..798ad38 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -51,6 +51,7 @@ import qualified CryptoCoins as CryptoCoins
 import Base58
 import FunctorToMaybe
 import DotLock
+import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
 
 -- DER-encoded elliptic curve ids
 nistp256_id  = 0x2a8648ce3d030107
@@ -68,19 +69,27 @@ home = HomeDir
     , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
     }
 
-data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int
+data InputFile = HomeSec
+               | HomePub
+               | ArgFile FilePath
+               | FileDesc Int
 
 type UsageTag = String
 type Initializer = String
 type PassWordFile = InputFile
 
-data FileType = KeyRingFile PassWordFile | PEMFile UsageTag | WalletFile
+data FileType = KeyRingFile PassWordFile
+              | PEMFile UsageTag
+              | WalletFile -- (Maybe UsageTag)
 
 data RefType = ConstRef | MutableRef (Maybe Initializer)
 
 initializer (MutableRef x) = x
 initializer _              = Nothing
 
+getUsage (PEMFile usage) = return usage
+getUsage _               = mzero
+
 
 data KeyRingRuntime = KeyRingRuntime
                         { rtPubring :: FilePath
@@ -247,6 +256,8 @@ data KikiReportAction =
         | YieldSecretKeyPacket String
         | UnableToUpdateExpiredSignature
         | WarnFailedToMakeSignature
+        | FailedExternal Int
+        | ExternallyGeneratedFile
 
 data KikiResult a = KikiResult
     { kikiCondition :: KikiCondition a
@@ -480,6 +491,8 @@ data KeySpec =
     | KeyUidMatch String
  deriving Show
 
+-- | Parse a key specification.
+-- The first argument is a grip for the default working key.
 parseSpec :: String -> String -> (KeySpec,Maybe String)
 parseSpec grip spec = (topspec,subspec)
  where
@@ -525,11 +538,8 @@ buildKeyDB secring pubring grip0 keyring = do
     let isring (KeyRingFile {}) = True
         isring _                = False
 
-        getUsage (PEMFile usage) = return usage
-        getUsage _               = mzero
-
-        iswallet WalletFile = True
-        iswallet _          = False
+        iswallet (WalletFile {}) = True
+        iswallet _               = False
 
         files isring = do
             (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
@@ -812,7 +822,7 @@ writeWalletKeys :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(F
 writeWalletKeys krd db wk = do
     let cs = db `coinKeysOwnedBy` wk
     -- export wallet keys
-        isMutableWallet (MutableRef {}) WalletFile = True
+        isMutableWallet (MutableRef {}) (WalletFile {}) = True
         isMutableWallet _ _ = False
         files pred = do
             (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
@@ -853,11 +863,6 @@ writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet
                 -> 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
@@ -869,9 +874,6 @@ writeRingKeys krd db wk secring pubring = do
             return (n,isMutable rtyp)
         fromfile f kd@(KeyData p _ _ _) =
                    Map.member f $ locations p 
-         {- maybe (Map.member f $ locations p)
-                  (\pred -> pred kd)
-                  (Map.lookup f $ kImports krd) -}
     let s = do
         (f,mutable) <- fs
         let x = do
@@ -921,12 +923,31 @@ runKeyRing keyring op = do
                 if e==0 then return $ Just lk
                         else dotlock_destroy lk >> return Nothing
         return (v,f)
-    let (lked, map snd -> failed) = partition (isJust . fst) lks
-        ret = if null failed then KikiSuccess () else FailedToLock failed
-    ret <- case functorToEither ret of
-      Right {} -> do
-         bresult <- buildKeyDB secring pubring grip0 keyring -- build db
-         try' bresult $ \((db,grip,wk),report1) -> do
+    let (lked, map snd -> failed_locks) = partition (isJust . fst) lks
+    ret <-
+      if not $ null failed_locks
+        then return $ KikiResult (FailedToLock failed_locks) []
+        else do
+         -- create nonexistent files via external commands
+         report_externals <- do
+            let cmds = do
+                 (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
+                 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
+                e <- systemEnv [ ("file",fname)
+                               , ("usage",usage) ]
+                               cmd
+                case e of
+                    ExitFailure num -> return (fname,FailedExternal num)
+                    ExitSuccess     -> return (fname,ExternallyGeneratedFile)
+
+         -- merge all keyrings, PEM files, and wallets
+         bresult <- buildKeyDB secring pubring grip0 keyring
+
+         try' bresult $ \((db,grip,wk),report_imports) -> do
              a <- return $ op KeyRingRuntime
                             { rtPubring = pubring
                             , rtSecring = secring
@@ -935,12 +956,20 @@ runKeyRing keyring op = do
                             , rtGrip = grip
                             , rtKeyDB = db
                             }
+
              r <- writeWalletKeys keyring db wk
-             try' r $ \report2 -> do
+             try' r $ \report_wallets -> do
+
              r <- writeRingKeys keyring db wk secring pubring
-             try' r $ \report3 -> do
-             return $ KikiResult (KikiSuccess a) (report1 ++ report3)
-      Left err -> return $ KikiResult err []
+             try' r $ \report_rings -> do
+
+             -- writePEMKeys
+
+             return $ KikiResult (KikiSuccess a)
+                        $ concat [ report_externals
+                                 , report_imports
+                                 , report_wallets
+                                 , report_rings ]
 
     forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                          dotlock_destroy lk -- todo: verify we want this
diff --git a/ProcessUtils.hs b/ProcessUtils.hs
new file mode 100644
index 0000000..7f7928c
--- /dev/null
+++ b/ProcessUtils.hs
@@ -0,0 +1,44 @@
+module ProcessUtils
+    ( ExitCode(ExitFailure,ExitSuccess)
+    , systemEnv
+    ) where
+
+import GHC.IO.Exception ( ioException, IOErrorType(..) )
+import System.Process
+import System.Posix.Signals
+import System.Process.Internals (runGenProcess_,defaultSignal)
+import System.Environment
+import Data.Maybe ( isNothing )
+import System.IO.Error ( mkIOError, ioeSetErrorString ) 
+import System.Exit ( ExitCode(..) )
+
+
+-- | systemEnv
+-- This is like System.Process.system except that it lets you set
+-- some environment variables.
+systemEnv _    ""  = 
+    ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
+systemEnv vars cmd = do
+    env0 <- getEnvironment
+    let env1 = filter (isNothing . flip lookup vars . fst) env0
+        env = vars ++ env1
+    syncProcess "system" $ (shell cmd) {env=Just env}
+ where
+    -- This is a non-exported function from System.Process
+    syncProcess fun c = do
+      -- The POSIX version of system needs to do some manipulation of signal
+      -- handlers.  Since we're going to be synchronously waiting for the child,
+      -- we want to ignore ^C in the parent, but handle it the default way
+      -- in the child (using SIG_DFL isn't really correct, it should be the
+      -- original signal handler, but the GHC RTS will have already set up
+      -- its own handler and we don't want to use that).
+      old_int  <- installHandler sigINT  Ignore Nothing
+      old_quit <- installHandler sigQUIT Ignore Nothing
+      (_,_,_,p) <- runGenProcess_ fun c
+            (Just defaultSignal) (Just defaultSignal)
+      r <- waitForProcess p
+      _ <- installHandler sigINT  old_int Nothing
+      _ <- installHandler sigQUIT old_quit Nothing
+      return r
+
+
diff --git a/kiki.hs b/kiki.hs
index 6cbf74d..1c6fa37 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -853,34 +853,6 @@ show_wip keyspec wkgrip db = do
     let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s
     putStrLn $ walletImportFormat nwb k
 
--- | systemEnv
--- This is like System.Process.system except that it lets you set
--- some environment variables.
-systemEnv _    ""  = 
-    ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
-systemEnv vars cmd = do
-    env0 <- getEnvironment
-    let env1 = filter (isNothing . flip lookup vars . fst) env0
-        env = vars ++ env1
-    syncProcess "system" $ (shell cmd) {env=Just env}
- where
-    -- This is a non-exported function from System.Process
-    syncProcess fun c = do
-      -- The POSIX version of system needs to do some manipulation of signal
-      -- handlers.  Since we're going to be synchronously waiting for the child,
-      -- we want to ignore ^C in the parent, but handle it the default way
-      -- in the child (using SIG_DFL isn't really correct, it should be the
-      -- original signal handler, but the GHC RTS will have already set up
-      -- its own handler and we don't want to use that).
-      old_int  <- installHandler sigINT  Ignore Nothing
-      old_quit <- installHandler sigQUIT Ignore Nothing
-      (_,_,_,p) <- runGenProcess_ fun c
-            (Just defaultSignal) (Just defaultSignal)
-      r <- waitForProcess p
-      _ <- installHandler sigINT  old_int Nothing
-      _ <- installHandler sigQUIT old_quit Nothing
-      return r
-
 doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) =
         case ms of
             [_]   -> export