{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Prelude
( withSourceFile
, withSinkFile
, withSinkFileCautious
, withSystemTempDir
, withKeepSystemTempDir
, sinkProcessStderrStdout
, sinkProcessStdout
, logProcessStderrStdout
, readProcessNull
, withProcessContext
, stripCR
, hIsTerminalDeviceOrMinTTY
, prompt
, promptPassword
, promptBool
, module X
) where
import RIO as X
import Data.Conduit as X (ConduitM, runConduit, (.|))
import Path as X (Abs, Dir, File, Path, Rel,
toFilePath)
import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..))
import qualified Path.IO
import qualified System.IO as IO
import qualified System.Directory as Dir
import qualified System.FilePath as FP
import System.IO.Echo (withoutInputEcho)
import System.IO.Error (isDoesNotExistError)
#ifdef WINDOWS
import System.Win32 (isMinTTYHandle, withHandleToHANDLE)
#endif
import Data.Conduit.Binary (sourceHandle, sinkHandle)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed (withLoggedProcess_, createSource)
import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcess_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL)
import Data.Store as X (Store)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import qualified RIO.Text as T
withSourceFile :: MonadUnliftIO m => FilePath -> (ConduitM i ByteString m () -> m a) -> m a
withSourceFile fp inner = withBinaryFile fp ReadMode $ inner . sourceHandle
withSinkFile :: MonadUnliftIO m => FilePath -> (ConduitM ByteString o m () -> m a) -> m a
withSinkFile fp inner = withBinaryFile fp WriteMode $ inner . sinkHandle
withSinkFileCautious
:: MonadUnliftIO m
=> FilePath
-> (ConduitM ByteString o m () -> m a)
-> m a
withSinkFileCautious fp inner =
withRunInIO $ \run -> bracket acquire cleanup $ \(tmpFP, h) ->
run (inner $ sinkHandle h) <* (IO.hClose h *> Dir.renameFile tmpFP fp)
where
acquire = IO.openBinaryTempFile (FP.takeDirectory fp) (FP.takeFileName fp FP.<.> "tmp")
cleanup (tmpFP, h) = do
IO.hClose h
Dir.removeFile tmpFP `catch` \e ->
if isDoesNotExistError e
then return ()
else throwIO e
withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
withKeepSystemTempDir str inner = withRunInIO $ \run -> do
path <- Path.IO.getTempDir
dir <- Path.IO.createTempDir path str
run $ inner dir
sinkProcessStderrStdout
:: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)
=> String
-> [String]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e,o)
sinkProcessStderrStdout name args sinkStderr sinkStdout =
proc name args $ \pc0 -> do
let pc = setStdout createSource
$ setStderr createSource
pc0
withProcess_ pc $ \p ->
runConduit (getStderr p .| sinkStderr) `concurrently`
runConduit (getStdout p .| sinkStdout)
sinkProcessStdout
:: (HasProcessContext env, HasLogFunc env, HasCallStack)
=> String
-> [String]
-> ConduitM ByteString Void (RIO env) a
-> RIO env a
sinkProcessStdout name args sinkStdout =
proc name args $ \pc ->
withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently
$ Concurrently (runConduit $ getStderr p .| CL.sinkNull)
*> Concurrently (runConduit $ getStdout p .| sinkStdout)
logProcessStderrStdout
:: (HasCallStack, HasProcessContext env, HasLogFunc env)
=> ProcessConfig stdin stdoutIgnored stderrIgnored
-> RIO env ()
logProcessStderrStdout pc = withLoggedProcess_ pc $ \p ->
let logLines = CB.lines .| CL.mapM_ (logInfo . displayBytesUtf8)
in runConcurrently
$ Concurrently (runConduit $ getStdout p .| logLines)
*> Concurrently (runConduit $ getStderr p .| logLines)
readProcessNull :: (HasProcessContext env, HasLogFunc env, HasCallStack)
=> String
-> [String]
-> RIO env ()
readProcessNull name args =
void $ proc name args readProcess_
withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a
withProcessContext pcNew inner = do
pcOld <- view processContextL
let pcNew' = set workingDirL (view workingDirL pcOld) pcNew
local (set processContextL pcNew') inner
stripCR :: Text -> Text
stripCR = T.dropSuffix "\r"
hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
#ifdef WINDOWS
hIsTerminalDeviceOrMinTTY h = do
isTD <- hIsTerminalDevice h
if isTD
then return True
else liftIO $ withHandleToHANDLE h isMinTTYHandle
#else
hIsTerminalDeviceOrMinTTY = hIsTerminalDevice
#endif
prompt :: MonadIO m => Text -> m Text
prompt txt = liftIO $ do
T.putStr txt
hFlush stdout
T.getLine
promptPassword :: MonadIO m => Text -> m Text
promptPassword txt = liftIO $ do
T.putStr txt
hFlush stdout
password <- withoutInputEcho T.getLine
T.putStrLn ""
return password
promptBool :: MonadIO m => Text -> m Bool
promptBool txt = liftIO $ do
input <- prompt txt
case input of
"y" -> return True
"n" -> return False
_ -> do
T.putStrLn "Please press either 'y' or 'n', and then enter."
promptBool txt