{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} module Development.Iridium.ExternalProgWrappers ( runCommandSuccess , runCommandStdOut , observeCreateProcessWithExitCode , getExternalProgramVersion , readShellProcessWithExitCode , runCommandSuccessCabal , runCommandSuccessHLint ) where import Prelude hiding ( FilePath ) import qualified Data.Text as Text import qualified Turtle as Turtle import qualified Control.Foldl as Foldl import qualified Control.Exception as C import qualified Data.Yaml as Yaml import Control.Monad.Trans.MultiRWS import Control.Monad.Trans.MultiState as MultiState import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class import Control.Monad.IO.Class import Distribution.PackageDescription import Distribution.Package import Filesystem.Path.CurrentOS hiding ( null ) import Data.Version ( Version(..) ) import Data.Proxy import Data.Tagged import Control.Applicative import Control.Monad import Data.Functor import Data.List import System.Exit import System.IO import Control.Concurrent.MVar import Control.Concurrent import System.IO.Error import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) import Foreign.C import System.Process.Internals import Data.IORef import qualified Data.List.Split as Split import qualified System.Process as Process import qualified Data.Char as Char import Text.Read ( readMaybe ) -- well, no Turtle, apparently. -- no way to retrieve stdout, stderr and exitcode. -- the most generic case, not supported? psshhh. import System.Process hiding ( cwd ) import Data.Maybe ( maybeToList ) import qualified Filesystem.Path.CurrentOS as Path import Development.Iridium.Types import Development.Iridium.Utils import Development.Iridium.UI.Console import Development.Iridium.UI.Prompt import Development.Iridium.CheckState import Development.Iridium.Config readShellProcessWithExitCode :: String -> [String] -> IO (ExitCode, String, String) readShellProcessWithExitCode c ps = readCreateProcessWithExitCode (shell $ c ++ " " ++ intercalate " " (fmap show ps)) "" runCommandSuccess :: ( MonadIO m , MonadPlus m , MonadMultiState CheckState m , MonadMultiState LogState m ) => String -> [String] -> m () runCommandSuccess c ps = falseToMZero $ do let infoStr = c ++ " " ++ intercalate " " ps withStack infoStr $ do outListRef <- liftIO $ newIORef [] exitCode <- withStack "" $ do -- the additional stack elem is for -- output display stuff. -- this is evil, because we discard states down there. -- but .. the alternative is somewhat complex ( to do right ). s1 :: LogState <- mGet s2 :: CheckState <- mGet let handleLine l = runMultiStateTNil $ MultiState.withMultiStateA s1 $ MultiState.withMultiStateA s2 $ do liftIO $ atomicModifyIORef outListRef (\x -> (l:x, ())) replaceStackTop l liftIO $ observeCreateProcessWithExitCode (shell $ c ++ " " ++ intercalate " " (fmap show ps)) "" handleLine handleLine case exitCode of ExitSuccess -> do pushLog LogLevelInfo $ infoStr return True ExitFailure _ -> do pushLog LogLevelPrint infoStr outLines <- liftIO $ readIORef outListRef reverse outLines `forM_` pushLog LogLevelPrint logStack return False runCommandSuccessCabal :: ( MonadIO m , MonadPlus m , MonadMultiState CheckState m , MonadMultiState LogState m , MonadMultiReader Config m ) => [String] -> m () runCommandSuccessCabal ps = do cabalInvoc <- configReadStringWithDefaultM "cabal" ["setup", "cabal-command"] runCommandSuccess cabalInvoc ps runCommandSuccessHLint :: ( MonadIO m , MonadPlus m , MonadMultiState CheckState m , MonadMultiState LogState m , MonadMultiReader Config m ) => [String] -> m () runCommandSuccessHLint ps = do hlintInvoc <- configReadStringWithDefaultM "hlint" ["setup", "hlint-command"] runCommandSuccess hlintInvoc ps runCommandStdOut :: ( MonadIO m , MonadPlus m , MonadMultiState LogState m ) => String -> [String] -> m String runCommandStdOut c ps = do let infoStr = c ++ " " ++ intercalate " " ps (exitCode, stdOut, _stdErr) <- liftIO $ readShellProcessWithExitCode c ps case exitCode of ExitFailure _ -> do pushLog LogLevelError $ "Error running command `" ++ infoStr ++ "`." mzero ExitSuccess -> do return stdOut getExternalProgramVersion :: ( MonadIO m , MonadPlus m , MonadMultiState LogState m ) => String -> m [Int] getExternalProgramVersion prog = do let err = do pushLog LogLevelError $ "Could not determine version of external program " ++ prog mzero (exitCode, stdOut, _stdErr) <- liftIO $ readShellProcessWithExitCode prog ["--version"] case exitCode of ExitSuccess -> do case lines stdOut of (line:_) -> case takeWhile (`elem` ".0123456789") $ dropWhile (not . Char.isNumber) line of "" -> err s -> do pushLog LogLevelInfoVerbose $ "detected " ++ prog ++ " version " ++ s case mapM readMaybe $ Split.splitOn "." s of Just vs -> return vs Nothing -> err _ -> err ExitFailure _ -> err observeCreateProcessWithExitCode :: CreateProcess -> String -- ^ standard input -> (String -> IO ()) -- ^ stdout line handler -> (String -> IO ()) -- ^ stderr line handler -> IO (ExitCode) -- ^ exitcode observeCreateProcessWithExitCode cp input stdoutHandler stderrHandler = do let cp_opts = cp { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } withCreateProcess_ "observeCreateProcessWithExitCode" cp_opts $ \(Just inh) (Just outh) (Just errh) ph -> do let processStream :: Handle -> (String -> IO ()) -> IO () processStream h f = do catchIOError (forever $ hGetLine h >>= f) (\e -> unless (isEOFError e) (ioError e)) -- fork off threads to start consuming stdout & stderr withForkWait (processStream outh stdoutHandler) $ \waitOut -> withForkWait (processStream errh stderrHandler) $ \waitErr -> do -- now write any input unless (null input) $ ignoreSigPipe $ hPutStr inh input -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE ignoreSigPipe $ hClose inh -- wait on the output waitOut waitErr -- hClose outh -- hClose errh -- wait on the process ex <- waitForProcess ph return ex -- *********** -- copied from System.Process, because not exposed.. withForkWait :: IO () -> (IO () -> IO a) -> IO a withForkWait async body = do waitVar <- newEmptyMVar :: IO (MVar (Either C.SomeException ())) C.mask $ \restore -> do tid <- forkIO $ C.try (restore async) >>= putMVar waitVar let wait = takeMVar waitVar >>= either C.throwIO return restore (body wait) `C.onException` killThread tid withCreateProcess_ :: String -> CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a withCreateProcess_ fun c action = C.bracketOnError (createProcess_ fun c) cleanupProcess (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) ignoreSigPipe :: IO () -> IO () ignoreSigPipe = C.handle $ \e -> case e of IOError { ioe_type = ResourceVanished , ioe_errno = Just ioe } | Errno ioe == ePIPE -> return () _ -> C.throwIO e cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph@(ProcessHandle _ delegating_ctlc)) = do terminateProcess ph -- Note, it's important that other threads that might be reading/writing -- these handles also get killed off, since otherwise they might be holding -- the handle lock and prevent us from closing, leading to deadlock. maybe (return ()) (ignoreSigPipe . hClose) mb_stdin maybe (return ()) hClose mb_stdout maybe (return ()) hClose mb_stderr -- terminateProcess does not guarantee that it terminates the process. -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee -- that it stops. If it doesn't stop, we don't want to hang, so we wait -- asynchronously using forkIO. -- However we want to end the Ctl-C handling synchronously, so we'll do -- that synchronously, and set delegating_ctlc as False for the -- waitForProcess (which would otherwise end the Ctl-C delegation itself). when delegating_ctlc stopDelegateControlC _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) return () where resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False -- ***********