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