{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Prelude
( withSourceFile
, withSinkFile
, withSinkFileCautious
, withSystemTempDir
, withKeepSystemTempDir
, sinkProcessStderrStdout
, sinkProcessStdout
, logProcessStderrStdout
, readProcessNull
, withProcessContext
, stripCR
, 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.Error (isDoesNotExistError)
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, readProcessStdout_, workingDirL)
import Data.Store as X (Store)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
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)
=> 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)
=> 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)
=> String
-> [String]
-> RIO env ()
readProcessNull name args =
void $ proc name args readProcessStdout_
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"