{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      :  BuildEnv.Utils

-- Description :  Utilities for @build-env@

--

-- Various utilities:

--

--  - Spawning of processes in particular environments; see 'callProcessInIO'.

--  - Semaphores.

--

module BuildEnv.Utils
    ( -- * Call a process in a given environment

      ProgPath(..), CallProcess(..), callProcessInIO

      -- * Create temporary directories

    , TempDirPermanence(..), withTempDir

      -- * Abstract semaphores

    , AbstractSem(..)
    , newAbstractSem, noSem, abstractQSem

      -- * Other utilities

    , splitOn

    ) where

-- base

import Control.Concurrent.QSem
  ( QSem, newQSem, signalQSem, waitQSem )
import Control.Exception
  ( bracket_ )
import Data.List
  ( intercalate )
import Data.Maybe
  ( fromMaybe )
import Data.IORef
  ( readIORef )
import System.Environment
  ( getEnvironment )
import System.Exit
  ( ExitCode(..), exitWith )
import System.IO
  ( IOMode(..), hPutStrLn, withFile )
import qualified System.IO as System.Handle
  ( stderr )
import GHC.IO.Handle
  ( hDuplicateTo )
import GHC.Stack
  ( HasCallStack )

-- containers

import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( alter, fromList, toList )

-- directory

import System.Directory
  ( createDirectoryIfMissing, makeAbsolute )

-- filepath

import System.FilePath
  ( (</>), (<.>), takeDirectory )

-- process

import qualified System.Process as Proc

-- temporary

import System.IO.Temp
    ( createTempDirectory
    , getCanonicalTemporaryDirectory
    , withSystemTempDirectory
    )

-- build-env

import BuildEnv.Config
  ( AsyncSem(..), Args, TempDirPermanence(..), Counter(..)
  , pATHSeparator, hostStyle
  )

--------------------------------------------------------------------------------


-- | The path of a program to run.

data ProgPath
  -- | An absolute path, or an executable in @PATH@.

  = AbsPath { ProgPath -> [Char]
progPath :: !FilePath }
  -- | A relative path. What it is relative to depends on context.

  | RelPath { progPath :: !FilePath }

-- | Arguments to 'callProcess'.

data CallProcess
  = CP
  { CallProcess -> [Char]
cwd          :: !FilePath
     -- ^ Working directory.

  , CallProcess -> [[Char]]
extraPATH    :: ![FilePath]
     -- ^ Absolute filepaths to add to PATH.

  , CallProcess -> [([Char], [Char])]
extraEnvVars :: ![(String, String)]
     -- ^ Extra envi!ronment variables to add before running the command.

  , CallProcess -> ProgPath
prog         :: !ProgPath
     -- ^ The program to run.

     --

     -- If it's a relative path, it should be relative to the @cwd@ field.

  , CallProcess -> [[Char]]
args         :: !Args
     -- ^ Arguments to the program.

  , CallProcess -> Maybe [Char]
logBasePath  :: !( Maybe FilePath )
     -- ^ Log @stdout@ to @basePath.stdout@ and @stderr@ to @basePath.stderr@.

  , CallProcess -> AbstractSem
sem          :: !AbstractSem
     -- ^ Lock to take when calling the process

     -- and waiting for it to return, to avoid

     -- contention in concurrent situations.

  }

-- | Run a command and wait for it to complete.

--

-- Crashes if the process returns with non-zero exit code.

--

-- See 'CallProcess' for a description of the options.

callProcessInIO :: HasCallStack
                => Maybe Counter
                    -- ^ Optional counter. Used when the command fails,

                    -- to report the progress that has been made so far.

                -> CallProcess
                -> IO ()
callProcessInIO :: HasCallStack => Maybe Counter -> CallProcess -> IO ()
callProcessInIO Maybe Counter
mbCounter ( CP { [Char]
cwd :: [Char]
cwd :: CallProcess -> [Char]
cwd, [[Char]]
extraPATH :: [[Char]]
extraPATH :: CallProcess -> [[Char]]
extraPATH, [([Char], [Char])]
extraEnvVars :: [([Char], [Char])]
extraEnvVars :: CallProcess -> [([Char], [Char])]
extraEnvVars, ProgPath
prog :: ProgPath
prog :: CallProcess -> ProgPath
prog, [[Char]]
args :: [[Char]]
args :: CallProcess -> [[Char]]
args, Maybe [Char]
logBasePath :: Maybe [Char]
logBasePath :: CallProcess -> Maybe [Char]
logBasePath, AbstractSem
sem :: AbstractSem
sem :: CallProcess -> AbstractSem
sem } ) = do
  [Char]
absProg <-
    case ProgPath
prog of
      AbsPath [Char]
p -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
p
      RelPath [Char]
p -> [Char] -> IO [Char]
makeAbsolute forall a b. (a -> b) -> a -> b
$ [Char]
cwd [Char] -> [Char] -> [Char]
</> [Char]
p
        -- Needs to be an absolute path, as per the @process@ documentation:

        --

        --   If cwd is provided, it is implementation-dependent whether

        --   relative paths are resolved with respect to cwd or the current

        --   working directory, so absolute paths should be used

        --   to ensure portability.

        --

        -- We always want the program to be interpreted relative to the cwd

        -- argument, so we prepend @cwd@ and then make it absolute.

  let argsStr :: [Char]
argsStr
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args = [Char]
""
        | Bool
otherwise = [Char]
" " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
args
      command :: [[Char]]
command =
        [ [Char]
"  > " forall a. [a] -> [a] -> [a]
++ [Char]
absProg forall a. [a] -> [a] -> [a]
++ [Char]
argsStr
        , [Char]
"  CWD = " forall a. [a] -> [a] -> [a]
++ [Char]
cwd ]
  Maybe [([Char], [Char])]
env <-
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
extraPATH Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], [Char])]
extraEnvVars
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    else do [([Char], [Char])]
env0 <- IO [([Char], [Char])]
getEnvironment
            let env1 :: Map [Char] [Char]
env1 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
env0 forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraEnvVars
                env2 :: [([Char], [Char])]
env2 = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k. Ord k => k -> [[Char]] -> Map k [Char] -> Map k [Char]
augmentSearchPath [Char]
"PATH" [[Char]]
extraPATH Map [Char] [Char]
env1
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [([Char], [Char])]
env2
  let withHandles :: ( ( Proc.StdStream, Proc.StdStream ) -> IO () ) -> IO ()
      withHandles :: ((StdStream, StdStream) -> IO ()) -> IO ()
withHandles (StdStream, StdStream) -> IO ()
action = case Maybe [Char]
logBasePath of
        Maybe [Char]
Nothing -> (StdStream, StdStream) -> IO ()
action ( StdStream
Proc.Inherit, StdStream
Proc.Inherit )
        Just [Char]
logPath -> do
          let stdoutFile :: [Char]
stdoutFile = [Char]
logPath [Char] -> [Char] -> [Char]
<.> [Char]
"stdout"
              stderrFile :: [Char]
stderrFile = [Char]
logPath [Char] -> [Char] -> [Char]
<.> [Char]
"stderr"
          Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeDirectory [Char]
logPath
          forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
stdoutFile IOMode
AppendMode \ Handle
stdoutFileHandle ->
            forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
stderrFile IOMode
AppendMode \ Handle
stderrFileHandle -> do
              Handle -> Handle -> IO ()
hDuplicateTo Handle
System.Handle.stderr Handle
stderrFileHandle
                -- Write stderr to the log file and to the terminal.

              Handle -> [Char] -> IO ()
hPutStrLn Handle
stdoutFileHandle ( [[Char]] -> [Char]
unlines [[Char]]
command )
              (StdStream, StdStream) -> IO ()
action ( Handle -> StdStream
Proc.UseHandle Handle
stdoutFileHandle, Handle -> StdStream
Proc.UseHandle Handle
stderrFileHandle )
  ((StdStream, StdStream) -> IO ()) -> IO ()
withHandles \ ( StdStream
stdoutStream, StdStream
stderrStream ) -> do
    let processArgs :: CreateProcess
processArgs =
          ( [Char] -> [[Char]] -> CreateProcess
Proc.proc [Char]
absProg [[Char]]
args )
            { cwd :: Maybe [Char]
Proc.cwd     = if [Char]
cwd forall a. Eq a => a -> a -> Bool
== [Char]
"." then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [Char]
cwd
            , env :: Maybe [([Char], [Char])]
Proc.env     = Maybe [([Char], [Char])]
env
            , std_out :: StdStream
Proc.std_out = StdStream
stdoutStream
            , std_err :: StdStream
Proc.std_err = StdStream
stderrStream }
    ExitCode
res <- AbstractSem -> forall r. IO r -> IO r
withAbstractSem AbstractSem
sem do
      (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- [Char]
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Proc.createProcess_ [Char]
"createProcess" CreateProcess
processArgs
        -- Use 'createProcess_' to avoid closing handles prematurely.

      ProcessHandle -> IO ExitCode
Proc.waitForProcess ProcessHandle
ph
    case ExitCode
res of
      ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitFailure Int
i -> do
        [[Char]]
progressReport <-
          case Maybe Counter
mbCounter of
            Maybe Counter
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just ( Counter { IORef Word
$sel:counterRef:Counter :: Counter -> IORef Word
counterRef :: IORef Word
counterRef, Word
$sel:counterMax:Counter :: Counter -> Word
counterMax :: Word
counterMax } ) -> do
              Word
progress <- forall a. IORef a -> IO a
readIORef IORef Word
counterRef
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ [Char]
"After " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word
progress forall a. Semigroup a => a -> a -> a
<> [Char]
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word
counterMax ]
        let msg :: [[Char]]
msg = [ [Char]
"callProcess failed with non-zero exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i forall a. [a] -> [a] -> [a]
++ [Char]
". Command:" ]
                     forall a. [a] -> [a] -> [a]
++ [[Char]]
command forall a. [a] -> [a] -> [a]
++ [[Char]]
progressReport
        case StdStream
stderrStream of
          Proc.UseHandle Handle
errHandle ->
            Handle -> [Char] -> IO ()
hPutStrLn Handle
errHandle
              ( [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ [[Char]]
msg forall a. [a] -> [a] -> [a]
++ [ [Char]
"Logs are available at: " forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe [Char]
"" Maybe [Char]
logBasePath forall a. Semigroup a => a -> a -> a
<> [Char]
".{stdout, stderr}" ] )
          StdStream
_ -> [Char] -> IO ()
putStrLn ([[Char]] -> [Char]
unlines [[Char]]
msg)
        forall a. ExitCode -> IO a
exitWith ExitCode
res

-- | Add filepaths to the given key in a key/value environment.

augmentSearchPath :: Ord k => k -> [FilePath] -> Map k String -> Map k String
augmentSearchPath :: forall k. Ord k => k -> [[Char]] -> Map k [Char] -> Map k [Char]
augmentSearchPath k
_   []    = forall a. a -> a
id
augmentSearchPath k
var [[Char]]
paths = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe [Char] -> Maybe [Char]
f k
var
  where
    pathsVal :: [Char]
pathsVal = forall a. [a] -> [[a]] -> [a]
intercalate (Style -> [Char]
pATHSeparator Style
hostStyle) [[Char]]
paths
    f :: Maybe [Char] -> Maybe [Char]
f Maybe [Char]
Nothing  = forall a. a -> Maybe a
Just [Char]
pathsVal
    f (Just [Char]
p) = forall a. a -> Maybe a
Just ([Char]
p forall a. Semigroup a => a -> a -> a
<> (Style -> [Char]
pATHSeparator Style
hostStyle) forall a. Semigroup a => a -> a -> a
<> [Char]
pathsVal)

-- | Perform an action with a fresh temporary directory.

withTempDir :: TempDirPermanence  -- ^ whether to delete the temporary directory

                                  -- after the action completes

            -> String             -- ^ directory name template

            -> (FilePath -> IO a) -- ^ action to perform

            -> IO a
withTempDir :: forall a. TempDirPermanence -> [Char] -> ([Char] -> IO a) -> IO a
withTempDir TempDirPermanence
del [Char]
name [Char] -> IO a
k =
  case TempDirPermanence
del of
    TempDirPermanence
DeleteTempDirs
      -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
name [Char] -> IO a
k
    TempDirPermanence
Don'tDeleteTempDirs
      -> do [Char]
root <- IO [Char]
getCanonicalTemporaryDirectory
            [Char] -> [Char] -> IO [Char]
createTempDirectory [Char]
root [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO a
k

-- | Utility list 'splitOn' function.

splitOn :: Char -> String -> [String]
splitOn :: Char -> [Char] -> [[Char]]
splitOn Char
c = [Char] -> [[Char]]
go
  where
    go :: [Char] -> [[Char]]
go [Char]
"" = []
    go [Char]
s
      | ([Char]
a,[Char]
as) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
c) [Char]
s
      = [Char]
a forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
go (forall a. Int -> [a] -> [a]
drop Int
1 [Char]
as)

--------------------------------------------------------------------------------

-- Semaphores.


-- | Abstract acquire/release mechanism.

newtype AbstractSem =
  AbstractSem { AbstractSem -> forall r. IO r -> IO r
withAbstractSem :: forall r. IO r -> IO r }

-- | Create a semaphore-based acquire/release mechanism.

newAbstractSem :: AsyncSem -> IO AbstractSem
newAbstractSem :: AsyncSem -> IO AbstractSem
newAbstractSem AsyncSem
whatSem =
  case AsyncSem
whatSem of
    AsyncSem
NoSem -> forall (m :: * -> *) a. Monad m => a -> m a
return AbstractSem
noSem
    NewQSem Word16
n -> do
      QSem
qsem <- Int -> IO QSem
newQSem ( forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n )
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ QSem -> AbstractSem
abstractQSem QSem
qsem

-- | Abstract acquire/release mechanism controlled by the given 'QSem'.

abstractQSem :: QSem -> AbstractSem
abstractQSem :: QSem -> AbstractSem
abstractQSem QSem
sem =
  (forall r. IO r -> IO r) -> AbstractSem
AbstractSem forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)

-- | No acquire/release mechanism required.

noSem :: AbstractSem
noSem :: AbstractSem
noSem = AbstractSem { withAbstractSem :: forall r. IO r -> IO r
withAbstractSem = forall a. a -> a
id }