summaryrefslogtreecommitdiff
path: root/Utility/CoProcess.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Utility/CoProcess.hs')
-rw-r--r--Utility/CoProcess.hs93
1 files changed, 93 insertions, 0 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
new file mode 100644
index 0000000..710d2af
--- /dev/null
+++ b/Utility/CoProcess.hs
@@ -0,0 +1,93 @@
+{- Interface for running a shell command as a coprocess,
+ - sending it queries and getting back results.
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.CoProcess (
+ CoProcessHandle,
+ start,
+ stop,
+ query,
+ rawMode
+) where
+
+import Common
+
+import Control.Concurrent.MVar
+
+type CoProcessHandle = MVar CoProcessState
+
+data CoProcessState = CoProcessState
+ { coProcessPid :: ProcessHandle
+ , coProcessTo :: Handle
+ , coProcessFrom :: Handle
+ , coProcessSpec :: CoProcessSpec
+ }
+
+data CoProcessSpec = CoProcessSpec
+ { coProcessRestartable :: Bool
+ , coProcessCmd :: FilePath
+ , coProcessParams :: [String]
+ , coProcessEnv :: Maybe [(String, String)]
+ }
+
+start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
+start restartable cmd params env = do
+ s <- start' $ CoProcessSpec restartable cmd params env
+ newMVar s
+
+start' :: CoProcessSpec -> IO CoProcessState
+start' s = do
+ (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
+ return $ CoProcessState pid to from s
+
+stop :: CoProcessHandle -> IO ()
+stop ch = do
+ s <- readMVar ch
+ hClose $ coProcessTo s
+ hClose $ coProcessFrom s
+ let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
+ forceSuccessProcess p (coProcessPid s)
+
+{- To handle a restartable process, any IO exception thrown by the send and
+ - receive actions are assumed to mean communication with the process
+ - failed, and the failed action is re-run with a new process. -}
+query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
+query ch send receive = do
+ s <- readMVar ch
+ restartable s (send $ coProcessTo s) $ const $
+ restartable s (hFlush $ coProcessTo s) $ const $
+ restartable s (receive $ coProcessFrom s) $
+ return
+ where
+ restartable s a cont
+ | coProcessRestartable (coProcessSpec s) =
+ maybe restart cont =<< catchMaybeIO a
+ | otherwise = cont =<< a
+ restart = do
+ s <- takeMVar ch
+ void $ catchMaybeIO $ do
+ hClose $ coProcessTo s
+ hClose $ coProcessFrom s
+ void $ waitForProcess $ coProcessPid s
+ s' <- start' (coProcessSpec s)
+ putMVar ch s'
+ query ch send receive
+
+rawMode :: CoProcessHandle -> IO CoProcessHandle
+rawMode ch = do
+ s <- readMVar ch
+ raw $ coProcessFrom s
+ raw $ coProcessTo s
+ return ch
+ where
+ raw h = do
+ fileEncoding h
+#ifdef mingw32_HOST_OS
+ hSetNewlineMode h noNewlineTranslation
+#endif