From efcc25a7558ac6e41d5ad44cb02e58cb4985d3d5 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 5 Dec 2013 15:41:21 -0500 Subject: Invoke shell commands to generate absent keypairs. --- kiki.hs | 123 ++++++++++++++++++++++++++++++++++++---------------------------- 1 file 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() -- cgit v1.2.3