diff options
-rw-r--r-- | lib/GnuPGAgent.hs | 66 | ||||
-rw-r--r-- | lib/ProcessUtils.hs | 41 | ||||
-rw-r--r-- | lib/dotlock.c | 2 |
3 files changed, 97 insertions, 12 deletions
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index 06784dd..18f1c25 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs | |||
@@ -1,6 +1,6 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | 1 | {-# LANGUAGE LambdaCase #-} |
2 | {-# LANGUAGE CPP #-} | 2 | {-# LANGUAGE CPP #-} |
3 | {-# LANGUAGE PatternGuards #-} | 3 | {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} |
4 | module GnuPGAgent | 4 | module GnuPGAgent |
5 | ( session | 5 | ( session |
6 | , GnuPGAgent | 6 | , GnuPGAgent |
@@ -15,8 +15,10 @@ import Debug.Trace | |||
15 | import Control.Monad | 15 | import Control.Monad |
16 | import ControlMaybe | 16 | import ControlMaybe |
17 | import Data.Char | 17 | import Data.Char |
18 | import Data.Maybe | ||
18 | import Data.OpenPGP | 19 | import Data.OpenPGP |
19 | import Data.OpenPGP.Util | 20 | import Data.OpenPGP.Util |
21 | import Data.Word | ||
20 | import Network.Socket | 22 | import Network.Socket |
21 | import System.Directory | 23 | import System.Directory |
22 | import System.Environment | 24 | import System.Environment |
@@ -37,26 +39,70 @@ import Data.Time.Calendar | |||
37 | import Data.Time.Clock | 39 | import Data.Time.Clock |
38 | import Data.Time.Clock.POSIX | 40 | import Data.Time.Clock.POSIX |
39 | #endif | 41 | #endif |
40 | import Data.Word | 42 | import ProcessUtils |
43 | import Control.Monad.Fix | ||
44 | import Control.Concurrent (threadDelay) | ||
41 | 45 | ||
42 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } | 46 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } |
43 | 47 | ||
48 | launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent) | ||
49 | launchAgent gpghome env = do | ||
50 | e <- spawnDetached "/usr/bin/gpg-agent" -- TODO: make this configurable | ||
51 | ["--homedir",gpghome,"--use-standard-socket","--daemon"] | ||
52 | env -- HERE redundant (see HERE below) | ||
53 | case e of | ||
54 | SpawnOK -> do | ||
55 | let secs_to_wait_for_agent = 5 | ||
56 | flip fix secs_to_wait_for_agent $ \loop count -> do | ||
57 | case count of | ||
58 | 0 -> do hPutStrLn stderr "Agent timed out." | ||
59 | return Nothing | ||
60 | _ -> do | ||
61 | handleIO_ (threadDelay 1000000 >> loop (count - 1)) $ do | ||
62 | sock <- socket AF_UNIX Stream defaultProtocol | ||
63 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) | ||
64 | agent <- socketToHandle sock ReadWriteMode | ||
65 | hSetBuffering agent LineBuffering | ||
66 | maybe (return ()) (putenv $ GnuPGAgent agent) env -- HERE redundant (see HERE above) | ||
67 | return $ Just $ GnuPGAgent agent | ||
68 | _ -> do | ||
69 | hPutStrLn stderr "Failed to connect to gpg-agent." | ||
70 | return Nothing | ||
71 | |||
72 | getDisplay :: IO [(String,String)] | ||
73 | getDisplay = catMaybes <$> mapM getvar vars | ||
74 | where | ||
75 | vars = [ "GPG_TTY" | ||
76 | , "TERM" | ||
77 | , "DISPLAY" | ||
78 | , "XAUTHORITY" | ||
79 | , "XMODIFIERS" | ||
80 | , "GTK_IM_MODULE" | ||
81 | , "DBUS_SESSION_BUS_ADDRESS" | ||
82 | , "QT_IM_MODULE" | ||
83 | , "INSIDE_EMACS" | ||
84 | , "PINENTRY_USER_DATA" | ||
85 | ] | ||
86 | getvar var = fmap (var,) <$> lookupEnv var | ||
87 | |||
88 | putenv :: GnuPGAgent -> [(String,String)] -> IO () | ||
89 | putenv (GnuPGAgent agent) env = do | ||
90 | forM_ env $ \(var,val) -> do | ||
91 | hPutStrLn agent ("option putenv "++var++"="++val) | ||
92 | _ <- hGetLine agent | ||
93 | return () | ||
94 | |||
44 | session :: IO (Maybe GnuPGAgent) | 95 | session :: IO (Maybe GnuPGAgent) |
45 | session = do | 96 | session = do |
46 | envhomedir Nothing gpgHomeSpec >>= \case | 97 | envhomedir Nothing gpgHomeSpec >>= \case |
47 | Just gpghome -> do | 98 | Just gpghome -> do |
48 | -- TODO: Launch gpg-agent if neccessary. | 99 | env <- getDisplay |
49 | handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ do | 100 | handleIO_ (launchAgent gpghome $ Just env) $ do |
50 | sock <- socket AF_UNIX Stream defaultProtocol | 101 | sock <- socket AF_UNIX Stream defaultProtocol |
51 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) | 102 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) |
52 | agent <- socketToHandle sock ReadWriteMode | 103 | agent <- socketToHandle sock ReadWriteMode |
53 | hSetBuffering agent LineBuffering | 104 | hSetBuffering agent LineBuffering |
54 | lookupEnv "DISPLAY" >>= \case | 105 | putenv (GnuPGAgent agent) env |
55 | Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display) | ||
56 | _ <- hGetLine agent | ||
57 | return () | ||
58 | Nothing -> return () | ||
59 | -- TODO: GPG_TTY | ||
60 | return $ Just $ GnuPGAgent agent | 106 | return $ Just $ GnuPGAgent agent |
61 | Nothing -> do | 107 | Nothing -> do |
62 | hPutStrLn stderr "Unable to find home directory." | 108 | hPutStrLn stderr "Unable to find home directory." |
diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs index 1a9cc04..31f5cc9 100644 --- a/lib/ProcessUtils.hs +++ b/lib/ProcessUtils.hs | |||
@@ -6,6 +6,8 @@ module ProcessUtils | |||
6 | , readPipe | 6 | , readPipe |
7 | , readProcessWithErrorH | 7 | , readProcessWithErrorH |
8 | , runExternal | 8 | , runExternal |
9 | , SpawnError(..) | ||
10 | , spawnDetached | ||
9 | ) where | 11 | ) where |
10 | 12 | ||
11 | import GHC.IO.Exception ( ioException, IOErrorType(..) ) | 13 | import GHC.IO.Exception ( ioException, IOErrorType(..) ) |
@@ -13,16 +15,20 @@ import System.FilePath | |||
13 | import System.Directory | 15 | import System.Directory |
14 | import System.Process | 16 | import System.Process |
15 | import System.Posix.Signals | 17 | import System.Posix.Signals |
18 | import System.Posix.Process | ||
16 | import System.Process.Internals (runGenProcess_,defaultSignal) | 19 | import System.Process.Internals (runGenProcess_,defaultSignal) |
17 | import System.Environment | 20 | import System.Environment |
18 | import Data.Maybe ( isNothing, fromMaybe ) | 21 | import Data.Maybe ( isNothing, fromMaybe, isJust, fromJust ) |
19 | import System.IO.Error ( mkIOError, ioeSetErrorString ) | 22 | import System.IO.Error ( mkIOError, ioeSetErrorString ) |
20 | import System.Exit ( ExitCode(..) ) | 23 | import System.Exit ( ExitCode(..) ) |
21 | import System.IO | 24 | import System.IO |
22 | import Control.Applicative | 25 | import Control.Applicative |
23 | import Control.Exception (bracket) | 26 | import Control.Exception (bracket) |
24 | import qualified Data.ByteString as S | 27 | import qualified Data.ByteString as S |
25 | 28 | import ControlMaybe (handleIO,handleIO_) | |
29 | import System.Posix.Files (fileAccess) | ||
30 | import System.Posix.User (getRealUserID,getEffectiveUserID) | ||
31 | import DotLock (dotlock_disable) | ||
26 | 32 | ||
27 | -- | systemEnv | 33 | -- | systemEnv |
28 | -- This is like System.Process.system except that it lets you set | 34 | -- This is like System.Process.system except that it lets you set |
@@ -152,3 +158,34 @@ runExternal cmd input = do | |||
152 | ExitFailure x -> x | 158 | ExitFailure x -> x |
153 | return (code,(out,err)) | 159 | return (code,(out,err)) |
154 | 160 | ||
161 | |||
162 | data SpawnError = SpawnOK | SpawnUIDCheck | SpawnBadAccess IOError | SpawnWaitPID | SpawnFork | ||
163 | deriving (Eq,Show) | ||
164 | |||
165 | spawnDetached :: FilePath -> [String] -> Maybe [(String,String)] -> IO SpawnError | ||
166 | spawnDetached filepath args env = do | ||
167 | uidcheck <- (==) <$> getRealUserID <*> getEffectiveUserID | ||
168 | if not uidcheck then return SpawnUIDCheck else do | ||
169 | accesscheck <- do | ||
170 | handleIO (return . Just . SpawnBadAccess) $ do | ||
171 | b <- fileAccess filepath False False True | ||
172 | if not b then return $ Just $ SpawnBadAccess (userError $ "No execute permission on "++filepath) | ||
173 | else return Nothing | ||
174 | if isJust accesscheck then return (fromJust accesscheck) else do | ||
175 | handleIO_ (return SpawnFork) $ do | ||
176 | pid <- forkProcess $ do | ||
177 | dotlock_disable -- Disable dotlock atexit handler. | ||
178 | -- This wouldn't be neccessary if we used exec* | ||
179 | -- instead of fork. | ||
180 | -- clean up secure memory: | ||
181 | -- gcry_control (GCRYCTL_TERM_SECMEM); | ||
182 | -- if (setsid() == -1 || chdir ("/")) _exit (1); | ||
183 | |||
184 | -- Double fork to let init take over the new child. | ||
185 | handleIO_ (exitImmediately $ ExitFailure 1) $ do | ||
186 | pid2 <- forkProcess $ executeFile filepath False args env | ||
187 | exitImmediately ExitSuccess | ||
188 | exitImmediately ExitSuccess | ||
189 | handleIO_ (return SpawnWaitPID) $ do | ||
190 | _ <- getProcessStatus True False pid | ||
191 | return SpawnOK | ||
diff --git a/lib/dotlock.c b/lib/dotlock.c index c111159..e091686 100644 --- a/lib/dotlock.c +++ b/lib/dotlock.c | |||
@@ -1286,6 +1286,8 @@ dotlock_remove_lockfiles (void) | |||
1286 | { | 1286 | { |
1287 | dotlock_t h, h2; | 1287 | dotlock_t h, h2; |
1288 | 1288 | ||
1289 | if( never_lock ) return; | ||
1290 | |||
1289 | /* First set the lockfiles list to NULL so that for example | 1291 | /* First set the lockfiles list to NULL so that for example |
1290 | dotlock_release is ware that this fucntion is currently | 1292 | dotlock_release is ware that this fucntion is currently |
1291 | running. */ | 1293 | running. */ |