{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Prelude
( withSystemTempDir
, withKeepSystemTempDir
, sinkProcessStderrStdout
, sinkProcessStdout
, logProcessStderrStdout
, readProcessNull
, withProcessContext
, stripCR
, prompt
, promptPassword
, promptBool
, stackProgName
, FirstTrue (..)
, fromFirstTrue
, defaultFirstTrue
, FirstFalse (..)
, fromFirstFalse
, defaultFirstFalse
, writeBinaryFileAtomic
, module X
) where
import RIO as X
import RIO.File as X
import Data.Conduit as X (ConduitM, runConduit, (.|))
import Path as X (Abs, Dir, File, Path, Rel,
toFilePath)
import Pantry as X hiding (Package (..), loadSnapshot)
import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..))
import qualified Path.IO
import System.IO.Echo (withoutInputEcho)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput)
import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcess_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import qualified RIO.Text as T
import System.Permissions (osIsWindows)
import Conduit
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
$ setStdin (byteStringInput "")
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"
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
stackProgName :: String
stackProgName = "stack"
newtype FirstTrue = FirstTrue { getFirstTrue :: Maybe Bool }
deriving (Show, Eq, Ord)
instance Semigroup FirstTrue where
FirstTrue (Just x) <> _ = FirstTrue (Just x)
FirstTrue Nothing <> x = x
instance Monoid FirstTrue where
mempty = FirstTrue Nothing
mappend = (<>)
fromFirstTrue :: FirstTrue -> Bool
fromFirstTrue = fromMaybe True . getFirstTrue
defaultFirstTrue :: (a -> FirstTrue) -> Bool
defaultFirstTrue _ = True
newtype FirstFalse = FirstFalse { getFirstFalse :: Maybe Bool }
deriving (Show, Eq, Ord)
instance Semigroup FirstFalse where
FirstFalse (Just x) <> _ = FirstFalse (Just x)
FirstFalse Nothing <> x = x
instance Monoid FirstFalse where
mempty = FirstFalse Nothing
mappend = (<>)
fromFirstFalse :: FirstFalse -> Bool
fromFirstFalse = fromMaybe False . getFirstFalse
defaultFirstFalse :: (a -> FirstFalse) -> Bool
defaultFirstFalse _ = False
writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m ()
writeBinaryFileAtomic fp builder
| osIsWindows =
liftIO $
withBinaryFile (toFilePath fp) WriteMode $ \h ->
hPutBuilder h builder
| otherwise =
liftIO $
withSinkFileCautious (toFilePath fp) $ \sink ->
runConduit $
yield builder .|
unsafeBuilderToByteString .|
sink