1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4module Stack.Prelude 5 ( withSystemTempDir 6 , withKeepSystemTempDir 7 , sinkProcessStderrStdout 8 , sinkProcessStdout 9 , logProcessStderrStdout 10 , readProcessNull 11 , withProcessContext 12 , stripCR 13 , prompt 14 , promptPassword 15 , promptBool 16 , stackProgName 17 , FirstTrue (..) 18 , fromFirstTrue 19 , defaultFirstTrue 20 , FirstFalse (..) 21 , fromFirstFalse 22 , defaultFirstFalse 23 , writeBinaryFileAtomic 24 , module X 25 ) where 26 27import RIO as X 28import RIO.File as X hiding (writeBinaryFileAtomic) 29import Data.Conduit as X (ConduitM, runConduit, (.|)) 30import Path as X (Abs, Dir, File, Path, Rel, 31 toFilePath) 32import Pantry as X hiding (Package (..), loadSnapshot) 33 34import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..)) 35 36import qualified Path.IO 37 38import System.IO.Echo (withoutInputEcho) 39 40import qualified Data.Conduit.Binary as CB 41import qualified Data.Conduit.List as CL 42import Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput) 43import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcessWait_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL, waitExitCode) 44 45import qualified Data.Text.IO as T 46import qualified RIO.Text as T 47 48-- | Path version 49withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a 50withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner 51 52-- | Like `withSystemTempDir`, but the temporary directory is not deleted. 53withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a 54withKeepSystemTempDir str inner = withRunInIO $ \run -> do 55 path <- Path.IO.getTempDir 56 dir <- Path.IO.createTempDir path str 57 run $ inner dir 58 59-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers. 60-- 61-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ExitCodeException' if the process itself fails. 62sinkProcessStderrStdout 63 :: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack) 64 => String -- ^ Command 65 -> [String] -- ^ Command line arguments 66 -> ConduitM ByteString Void (RIO env) e -- ^ Sink for stderr 67 -> ConduitM ByteString Void (RIO env) o -- ^ Sink for stdout 68 -> RIO env (e,o) 69sinkProcessStderrStdout name args sinkStderr sinkStdout = 70 proc name args $ \pc0 -> do 71 let pc = setStdout createSource 72 $ setStderr createSource 73 -- Don't use closed, since that can break ./configure scripts 74 -- See https://github.com/commercialhaskell/stack/pull/4722 75 $ setStdin (byteStringInput "") 76 pc0 77 withProcessWait_ pc $ \p -> 78 (runConduit (getStderr p .| sinkStderr) `concurrently` 79 runConduit (getStdout p .| sinkStdout)) <* waitExitCode p 80 81-- | Consume the stdout of a process feeding strict 'ByteString's to a consumer. 82-- If the process fails, spits out stdout and stderr as error log 83-- level. Should not be used for long-running processes or ones with 84-- lots of output; for that use 'sinkProcessStderrStdout'. 85-- 86-- Throws a 'ReadProcessException' if unsuccessful. 87sinkProcessStdout 88 :: (HasProcessContext env, HasLogFunc env, HasCallStack) 89 => String -- ^ Command 90 -> [String] -- ^ Command line arguments 91 -> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout 92 -> RIO env a 93sinkProcessStdout name args sinkStdout = 94 proc name args $ \pc -> 95 withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently 96 $ Concurrently (runConduit $ getStderr p .| CL.sinkNull) 97 *> Concurrently (runConduit $ getStdout p .| sinkStdout) 98 99logProcessStderrStdout 100 :: (HasCallStack, HasProcessContext env, HasLogFunc env) 101 => ProcessConfig stdin stdoutIgnored stderrIgnored 102 -> RIO env () 103logProcessStderrStdout pc = withLoggedProcess_ pc $ \p -> 104 let logLines = CB.lines .| CL.mapM_ (logInfo . displayBytesUtf8) 105 in runConcurrently 106 $ Concurrently (runConduit $ getStdout p .| logLines) 107 *> Concurrently (runConduit $ getStderr p .| logLines) 108 109-- | Read from the process, ignoring any output. 110-- 111-- Throws a 'ReadProcessException' exception if the process fails. 112readProcessNull :: (HasProcessContext env, HasLogFunc env, HasCallStack) 113 => String -- ^ Command 114 -> [String] -- ^ Command line arguments 115 -> RIO env () 116readProcessNull name args = 117 -- We want the output to appear in any exceptions, so we capture and drop it 118 void $ proc name args readProcess_ 119 120-- | Use the new 'ProcessContext', but retain the working directory 121-- from the parent environment. 122withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a 123withProcessContext pcNew inner = do 124 pcOld <- view processContextL 125 let pcNew' = set workingDirL (view workingDirL pcOld) pcNew 126 local (set processContextL pcNew') inner 127 128-- | Remove a trailing carriage return if present 129stripCR :: Text -> Text 130stripCR = T.dropSuffix "\r" 131 132-- | Prompt the user by sending text to stdout, and taking a line of 133-- input from stdin. 134prompt :: MonadIO m => Text -> m Text 135prompt txt = liftIO $ do 136 T.putStr txt 137 hFlush stdout 138 T.getLine 139 140-- | Prompt the user by sending text to stdout, and collecting a line 141-- of input from stdin. While taking input from stdin, input echoing is 142-- disabled, to hide passwords. 143-- 144-- Based on code from cabal-install, Distribution.Client.Upload 145promptPassword :: MonadIO m => Text -> m Text 146promptPassword txt = liftIO $ do 147 T.putStr txt 148 hFlush stdout 149 -- Save/restore the terminal echoing status (no echoing for entering 150 -- the password). 151 password <- withoutInputEcho T.getLine 152 -- Since the user's newline is not echoed, one needs to be inserted. 153 T.putStrLn "" 154 return password 155 156-- | Prompt the user by sending text to stdout, and collecting a line of 157-- input from stdin. If something other than "y" or "n" is entered, then 158-- print a message indicating that "y" or "n" is expected, and ask 159-- again. 160promptBool :: MonadIO m => Text -> m Bool 161promptBool txt = liftIO $ do 162 input <- prompt txt 163 case input of 164 "y" -> return True 165 "n" -> return False 166 _ -> do 167 T.putStrLn "Please press either 'y' or 'n', and then enter." 168 promptBool txt 169 170-- | Name of the 'stack' program. 171-- 172-- NOTE: Should be defined in "Stack.Constants", but not doing so due to the 173-- GHC stage restrictions. 174stackProgName :: String 175stackProgName = "stack" 176 177-- | Like @First Bool@, but the default is @True@. 178newtype FirstTrue = FirstTrue { getFirstTrue :: Maybe Bool } 179 deriving (Show, Eq, Ord) 180instance Semigroup FirstTrue where 181 FirstTrue (Just x) <> _ = FirstTrue (Just x) 182 FirstTrue Nothing <> x = x 183instance Monoid FirstTrue where 184 mempty = FirstTrue Nothing 185 mappend = (<>) 186 187-- | Get the 'Bool', defaulting to 'True' 188fromFirstTrue :: FirstTrue -> Bool 189fromFirstTrue = fromMaybe True . getFirstTrue 190 191-- | Helper for filling in default values 192defaultFirstTrue :: (a -> FirstTrue) -> Bool 193defaultFirstTrue _ = True 194 195-- | Like @First Bool@, but the default is @False@. 196newtype FirstFalse = FirstFalse { getFirstFalse :: Maybe Bool } 197 deriving (Show, Eq, Ord) 198instance Semigroup FirstFalse where 199 FirstFalse (Just x) <> _ = FirstFalse (Just x) 200 FirstFalse Nothing <> x = x 201instance Monoid FirstFalse where 202 mempty = FirstFalse Nothing 203 mappend = (<>) 204 205-- | Get the 'Bool', defaulting to 'False' 206fromFirstFalse :: FirstFalse -> Bool 207fromFirstFalse = fromMaybe False . getFirstFalse 208 209-- | Helper for filling in default values 210defaultFirstFalse :: (a -> FirstFalse) -> Bool 211defaultFirstFalse _ = False 212 213-- | Write a @Builder@ to a file and atomically rename. 214writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m () 215writeBinaryFileAtomic fp builder = 216 liftIO $ 217 withBinaryFileAtomic (toFilePath fp) WriteMode (`hPutBuilder` builder) 218