diff --git a/shelly.cabal b/shelly.cabal --- a/shelly.cabal +++ b/shelly.cabal @@ -1,6 +1,6 @@ Name: shelly -Version: 1.1.0.0 +Version: 1.2.0.0 Synopsis: shell-like (systems) programming in Haskell Description: Shelly provides convenient systems programming in Haskell, diff --git a/src/Shelly.hs b/src/Shelly.hs --- a/src/Shelly.hs +++ b/src/Shelly.hs @@ -26,12 +26,17 @@ Sh, ShIO, shelly, shellyNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit -- * Running external commands. - , run, run_, runFoldLines, cmd, FoldCallback, runHandle, runHandles + , run, run_, runFoldLines, cmd, FoldCallback , (-|-), lastStderr, setStdin, lastExitCode , command, command_, command1, command1_ , sshPairs, sshPairs_ , ShellArg (..) + -- * Running commands Using handles + , runHandle, runHandles, transferLinesAndCombine, transferFoldHandleLines + , ReusedHandle(..) + + -- * Modifying and querying environment. , setenv, get_env, get_env_text, getenv, get_env_def, appendToPath @@ -94,6 +99,7 @@ import Data.Foldable (foldl') import Data.Maybe import System.IO ( hClose, stderr, stdout, openTempFile ) +import System.IO.Error (isPermissionError, catchIOError, isEOFError, isIllegalOperation) import System.Exit import System.Environment import Control.Applicative @@ -105,20 +111,18 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE import System.Process( CmdSpec(..), StdStream(CreatePipe, UseHandle), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle ) -import System.IO.Error (isPermissionError) import qualified Data.Text as T import qualified Data.ByteString as BS import Data.ByteString (ByteString) -import Data.Monoid (mempty) +import Data.Monoid (Monoid, mempty, mappend) #if __GLASGOW_HASKELL__ < 704 -import Data.Monoid (Monoid, mappend) infixr 5 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend #else -import Data.Monoid ( mappend, (<>)) +import Data.Monoid ((<>)) #endif import Filesystem.Path.CurrentOS hiding (concat, fromText, (), (<.>)) @@ -169,7 +173,6 @@ instance ShellArg FilePath where toTextArg = toTextIgnore instance ShellArg String where toTextArg = T.pack - -- | used to create the variadic function 'cmd' class ShellCommand t where cmdAll :: FilePath -> [Text] -> t @@ -236,27 +239,38 @@ fromText :: Text -> FilePath fromText = FP.fromText -printGetTextList :: Handle -> Handle -> IO Text -printGetTextList h1 h2 = printFoldHandleLines mempty (|>) h1 h2 >>= +-- | Transfer from one handle to another +-- For example, send contents of a process output to stdout. +-- does not close the write handle. +-- +-- Also, return the complete contents being streamed line by line. +transferLinesAndCombine :: Handle -> Handle -> IO Text +transferLinesAndCombine h1 h2 = transferFoldHandleLines mempty (|>) h1 h2 >>= return . lineSeqToText lineSeqToText :: Seq Text -> Text lineSeqToText = T.intercalate "\n" . foldl' (flip (:)) [] -{- -getContent :: Handle -> IO Text -getContent h = fmap B.toLazyText $ foldHandleLines (B.fromText "") foldBuilder h --} - type FoldCallback a = (a -> Text -> a) -printFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a -printFoldHandleLines start foldLine readHandle writeHandle = go start +-- | Transfer from one handle to another +-- For example, send contents of a process output to stdout. +-- does not close the write handle. +-- +-- Also, fold over the contents being streamed line by line +transferFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a +transferFoldHandleLines start foldLine readHandle writeHandle = go start where + catchIOErrors action = catchIOError + (fmap Just action) + (\e -> if isEOFError e || isIllegalOperation e -- handle was closed + then return Nothing + else ioError e) go acc = do - line <- TIO.hGetLine readHandle - TIO.hPutStrLn writeHandle line >> go (foldLine acc line) - `catchany` \_ -> return acc + mLine <- catchIOErrors (TIO.hGetLine readHandle) + case mLine of + Nothing -> return acc + Just line -> TIO.hPutStrLn writeHandle line >> go (foldLine acc line) foldHandleLines :: a -> FoldCallback a -> Handle -> IO a foldHandleLines start foldLine readHandle = go start @@ -277,13 +291,13 @@ stateVar <- ask liftIO (writeIORef stateVar newState) -runCommandNoEscape :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) -runCommandNoEscape mstdin st exe args = liftIO $ shellyProcess mstdin st $ +runCommandNoEscape :: [ReusedHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) +runCommandNoEscape handles st exe args = liftIO $ shellyProcess handles st $ ShellCommand $ T.unpack $ T.intercalate " " (toTextIgnore exe : args) -runCommand :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) -runCommand mstdin st exe args = findExe exe >>= \fullExe -> - liftIO $ shellyProcess mstdin st $ +runCommand :: [ReusedHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) +runCommand handles st exe args = findExe exe >>= \fullExe -> + liftIO $ shellyProcess handles st $ RawCommand (unpack fullExe) (map T.unpack args) where findExe :: FilePath -> Sh FilePath @@ -310,23 +324,54 @@ -shellyProcess :: (Maybe Handle) -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle) -shellyProcess mstdin st cmdSpec = do - (Just hin, Just hout, Just herr, pHandle) <- createProcess CreateProcess { - cmdspec = cmdSpec - , cwd = Just $ unpack $ sDirectory st - , env = Just $ sEnvironment st - , std_in = case mstdin of - Nothing -> CreatePipe - Just handle -> UseHandle handle - , std_out = CreatePipe, std_err = CreatePipe - , close_fds = False +shellyProcess :: [ReusedHandle] -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle) +shellyProcess reusedHandles st cmdSpec = do + (createdInH, createdOutH, createdErrorH, pHandle) <- createProcess CreateProcess { + cmdspec = cmdSpec + , cwd = Just $ unpack $ sDirectory st + , env = Just $ sEnvironment st + , std_in = reuse mIn + , std_out = reuse mOut + , std_err = reuse mError + , close_fds = False #if MIN_VERSION_process(1,1,0) - , create_group = False + , create_group = False #endif - } - return (hin, hout, herr, pHandle) + } + return (just $ createdInH <|> mInH, + just $ createdOutH <|> mOutH, + just $ createdErrorH <|> mErrorH, pHandle) + where + just :: Maybe a -> a + just Nothing = error "error in shelly creating process" + just (Just j) = j + mInH = getHandle mIn reusedHandles + mOutH = getHandle mOut reusedHandles + mErrorH = getHandle mError reusedHandles + + reuse :: (ReusedHandle -> Maybe Handle) -> StdStream + reuse mHandle = createOrUse $ getHandle mHandle reusedHandles + + getHandle :: (ReusedHandle -> Maybe Handle) -> [ReusedHandle] -> Maybe Handle + getHandle _ [] = Nothing + getHandle mHandle (h:hs) = case mHandle h of + Just already -> Just already + Nothing -> getHandle mHandle hs + + createOrUse :: Maybe Handle -> StdStream + createOrUse mHandle = case mHandle of + Just already -> UseHandle already + Nothing -> CreatePipe + + mIn, mOut, mError :: (ReusedHandle -> Maybe Handle) + mIn (InHandle h) = Just h + mIn _ = Nothing + mOut (OutHandle h) = Just h + mOut _ = Nothing + mError (ErrorHandle h) = Just h + mError _ = Nothing + {- -- | use for commands requiring usage of sudo. see 'run_sudo'. -- Use this pattern for priveledge separation @@ -935,15 +980,13 @@ -> (Handle -> Sh a) -- ^ stdout handle -> Sh a runHandle exe args withHandle = - runHandles exe args Nothing $ \outH errH -> do + runHandles exe args [] $ \_ outH errH -> do errVar <- liftIO $ do errVar' <- newEmptyMVar - _ <- forkIO $ printGetTextList errH stderr >>= putMVar errVar' + _ <- forkIO $ transferLinesAndCombine errH stderr >>= putMVar errVar' return errVar' - -- liftIO_ $ forkIO $ getContent errH >>= putMVar errVar - -- - res <- withHandle outH + res <- withHandle outH errs <- liftIO $ takeMVar errVar modify $ \state' -> state' { sStderr = errs } @@ -952,10 +995,10 @@ -- | Similar to 'run' but gives direct access to all input and output handles. runHandles :: FilePath -- ^ command -> [Text] -- ^ arguments - -> (Maybe Handle) -- ^ stdin - -> (Handle -> Handle -> Sh a) -- ^ stdout and stderr + -> [ReusedHandle] -- ^ optionally connect process i/o handles to existing handles + -> (Handle -> Handle -> Handle -> Sh a) -- ^ stdin, stdout and stderr -> Sh a -runHandles exe args mStdinHandle withHandles = do +runHandles exe args reusedHandles withHandles = do -- clear stdin before beginning command execution origstate <- get let mStdin = sStdin origstate @@ -967,22 +1010,22 @@ trace cmdString bracketOnWindowsError - ((sRun state) mStdinHandle state exe args) + ((sRun state) reusedHandles state exe args) (\(_,_,_,procH) -> (liftIO $ terminateProcess procH)) (\(inH,outH,errH,procH) -> do liftIO $ case mStdin of - Just input -> - TIO.hPutStr inH input >> hClose inH - -- stdin is cleared from state below + Just input -> TIO.hPutStr inH input Nothing -> return () - result <- withHandles outH errH + result <- withHandles inH outH errH (ex, code) <- liftIO $ do + ex' <- waitForProcess procH + hClose outH hClose errH + hClose inH - ex' <- waitForProcess procH return $ case ex' of ExitSuccess -> (ex', 0) ExitFailure n -> (ex', n) @@ -1013,19 +1056,19 @@ -- stderr is still being placed in memory under the assumption it is always relatively small runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a runFoldLines start cb exe args = - runHandles exe args Nothing $ \outH errH -> do + runHandles exe args [] $ \inH outH errH -> do (errVar, outVar) <- liftIO $ do + hClose inH -- setStdin was taken care of before the process even ran errVar' <- newEmptyMVar outVar' <- newEmptyMVar - _ <- forkIO $ printGetTextList errH stderr >>= putMVar errVar' + _ <- forkIO $ transferLinesAndCombine errH stderr >>= putMVar errVar' return (errVar', outVar') - -- liftIO_ $ forkIO $ getContent errH >>= putMVar errVar state <- get errs <- liftIO $ do void $ if sPrintStdout state then - forkIO $ printFoldHandleLines start cb outH stdout >>= putMVar outVar + forkIO $ transferFoldHandleLines start cb outH stdout >>= putMVar outVar else forkIO $ foldHandleLines start cb outH >>= putMVar outVar takeMVar errVar diff --git a/src/Shelly/Base.hs b/src/Shelly/Base.hs --- a/src/Shelly/Base.hs +++ b/src/Shelly/Base.hs @@ -6,7 +6,7 @@ -- However, Shelly went back to exposing a single module module Shelly.Base ( - ShIO, Sh, unSh, runSh, State(..), FilePath, Text, + ShIO, Sh, unSh, runSh, State(..), ReusedHandle(..), FilePath, Text, relPath, path, absPath, canonic, canonicalize, test_d, test_s, unpack, gets, get, modify, trace, @@ -67,13 +67,17 @@ , sDirectory :: FilePath -- ^ working directory , sPrintStdout :: Bool -- ^ print stdout of command that is executed , sPrintCommands :: Bool -- ^ print command that is executed - , sRun :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) -- ^ command runner, a different runner is used when escaping, probably better to just hold the escaping flag + , sRun :: [ReusedHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) -- ^ command runner, a different runner is used when escaping, probably better to just hold the escaping flag , sEnvironment :: [(String, String)] , sPathExecutables :: Maybe [(FilePath, S.Set FilePath)] -- ^ cache of executables in the PATH , sTracing :: Bool -- ^ should we trace command execution , sTrace :: Text -- ^ the trace of command execution , sErrExit :: Bool -- ^ should we exit immediately on any error } + +data ReusedHandle = InHandle Handle + | OutHandle Handle + | ErrorHandle Handle -- | A monadic-conditional version of the "when" guard. whenM :: Monad m => m Bool -> m () -> m ()