Invoke shell commands to generate absent keypairs.

1 files changed, 69 insertions, 54 deletions

diff --git a/kiki.hs b/kiki.hs
index a87a1b7..fef214c 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -10,6 +10,7 @@ module Main where
 
 import Debug.Trace
 import GHC.Exts (Down(..))
+import GHC.IO.Exception ( ioException, IOErrorType(..) )
 import Data.Tuple
 import Data.Binary
 import Data.OpenPGP
@@ -41,6 +42,13 @@ import Control.Applicative
 import System.Environment
 import System.Directory
 import System.Exit
+import System.Process
+import System.Posix.IO (fdToHandle,fdRead)
+import System.Posix.Files
+import System.Posix.Signals
+import System.Process.Internals (runGenProcess_,defaultSignal)
+import System.IO (hPutStrLn,stderr)
+import System.IO.Error
 import ControlMaybe
 import Data.Char
 import Control.Arrow (first,second)
@@ -48,13 +56,10 @@ import Data.Traversable hiding (mapM,forM)
 import System.Console.CmdArgs
 -- import System.Posix.Time
 import Data.Time.Clock.POSIX
-import System.Posix.IO (fdToHandle,fdRead)
-import System.Posix.Files
 import Data.Monoid ((<>))
 -- import Data.X509
 import qualified Data.Map as Map
 import DotLock
-import System.IO (hPutStrLn,stderr)
 
 
 warn str = hPutStrLn stderr str
@@ -200,7 +205,13 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
     MPI d <- lookup 'd' $ key pkt
     MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
     MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
-    coefficient <- lookup 'u' $ key pkt -- TODO: compute (inverse q) mod p
+
+    -- Note: Here we fail if 'u' key is missing.
+    -- Ideally, it would be better to compute (inverse q) mod p
+    -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
+    --     (package constructive-algebra)
+    coefficient <- lookup 'u' $ key pkt 
+
     let dmodp1 = MPI $ d `mod` (p - 1)
         dmodqminus1 = MPI $ d `mod` (q - 1)
     return $ RSAPrivateKey 
@@ -1155,9 +1166,12 @@ 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
+                -- unlockFiles fsns -----------
+                -------------------------------
+                db' <- f (sec_n,fstkey) db 
+                -- lk <- relock ---------------
+                let lk = (fsns,failed_locks) --
+                -------------------------------
                 maybe (if n==0 then pass 1 lk else return (lk,db))
                       (return . (lk,))
                       db'
@@ -1219,11 +1233,6 @@ parseSpec grip spec = (topspec,subspec)
                 "" | top=="" && is40digitHex sub -> Nothing
                 "" -> Just sub
 
-insertSubKey tag key (Just (KeyData p sigs uids subs)) =
-    Just $ KeyData p sigs uids subs'
- where
-    subs' = todo
-
 splitAtMinBy comp xs = minimumBy comp' xxs
  where
     xxs = zip (inits xs) (tails xs)
@@ -1232,6 +1241,35 @@ splitAtMinBy comp xs = minimumBy comp' xxs
     compM Nothing  mb       = GT
     compM _        _        = LT
 
+
+-- | 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 (fname,subspec,ms,cmd) =
         case ms of
             [_]   -> export
@@ -1240,16 +1278,16 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
  where
     ambiguous = error "Key specification is ambiguous."
     shcmd = do
-                --
-                --   does ms contain exactly one key?
-                --      yes -> export key
-                --      no  -> no keys?
-                --              no -> ambiguous error
-                --              yes -> cmd
-                --                     if error warn
-                --                     else need another pass
-        todo
-        return Nothing
+        let noop warning = do
+            warn warning
+            return 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
     export = do
         let [(kk,KeyData key sigs uids subkeys)] = ms
             p = flip (maybe (Just $ packet key)) subspec $ \tag -> do
@@ -1266,7 +1304,7 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
                     _  -> ambiguous
         flip (maybe shcmd) p $ \p -> do
         pun <- doDecrypt p
-        flip (maybe shcmd) pun $ \pun -> do
+        flip (maybe $ error "Bad passphrase?") pun $ \pun -> do
         warn $ "writing "++fname
         writeKeyToFile False "PEM" fname pun
         return db
@@ -1322,12 +1360,12 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
         (xs',minsig,ys') = searchSubkeys tag wk key subsigs
         doInsert mbsig db = do
             sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
-            warn $ fname ++ ": new SignaturePacket"
+            warn $ fname ++ ": yield SignaturePacket"
             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 ++ ": new SecretKeyPacket")
+    when is_new (warn $ fname ++ ": yield SecretKeyPacket "++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
@@ -1564,37 +1602,14 @@ main = do
         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)
-        {-
-        forM_ pkeypairs $ \(spec,f,cmd) -> do
-            let ms = filterMatches spec (Map.toList db)
-                import_if_neccessary = todo
-                --   read file
-                --   is the key in ms?
-                --      yes -> continue
-                --      no  -> import key
-                --             need to write keyring files or remember imports
-                export_or_create = todo
-                --   does ms contain exactly one key?
-                --      yes -> export key
-                --      no  -> no keys?
-                --              no -> ambiguous error
-                --              yes -> cmd
-                --                     if error warn
-                --                     else need another pass
-            f_found <- doesFileExist f
-            if f_found
-                then import_if_neccessary
-                else export_or_create
-            return ()
-            -}
-
-        let ret_db = Just use_db
 
-        let shspec = Map.fromList [("--show-wk", show_wk secfile grip)
-                                  ,("--show-all",show_all    )]
-            shargs = mapMaybe (\x -> listToMaybe x >>= \x ->Map.lookup x shspec) sargs
+        flip (maybe $ return ()) ret_db . const $ do
+            -- On last pass, interpret --show-* commands.
+            let shspec = Map.fromList [("--show-wk", show_wk secfile grip)
+                                      ,("--show-all",show_all    )]
+                shargs = mapMaybe (\x -> listToMaybe x >>= \x ->Map.lookup x shspec) sargs
 
-        forM_ shargs $ \cmd -> cmd use_db
+            forM_ shargs $ \cmd -> cmd use_db
         return $ ret_db
 
     return()