{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module BuildEnv.Utils
(
ProgPath(..), CallProcess(..), callProcessInIO
, TempDirPermanence(..), withTempDir
, AbstractSem(..)
, newAbstractSem, noSem, abstractQSem
, splitOn
) where
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 )
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( alter, fromList, toList )
import System.Directory
( createDirectoryIfMissing, makeAbsolute )
import System.FilePath
( (</>), (<.>), takeDirectory )
import qualified System.Process as Proc
import System.IO.Temp
( createTempDirectory
, getCanonicalTemporaryDirectory
, withSystemTempDirectory
)
import BuildEnv.Config
( AsyncSem(..), Args, TempDirPermanence(..), Counter(..)
, pATHSeparator, hostStyle
)
data ProgPath
= AbsPath { ProgPath -> [Char]
progPath :: !FilePath }
| RelPath { progPath :: !FilePath }
data CallProcess
= CP
{ CallProcess -> [Char]
cwd :: !FilePath
, :: ![FilePath]
, :: ![(String, String)]
, CallProcess -> ProgPath
prog :: !ProgPath
, CallProcess -> [[Char]]
args :: !Args
, CallProcess -> Maybe [Char]
logBasePath :: !( Maybe FilePath )
, CallProcess -> AbstractSem
sem :: !AbstractSem
}
callProcessInIO :: HasCallStack
=> Maybe Counter
-> 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
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
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
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
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)
withTempDir :: TempDirPermanence
-> String
-> (FilePath -> IO a)
-> 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
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)
newtype AbstractSem =
AbstractSem { AbstractSem -> forall r. IO r -> IO r
withAbstractSem :: forall r. IO r -> IO r }
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
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)
noSem :: AbstractSem
noSem :: AbstractSem
noSem = AbstractSem { withAbstractSem :: forall r. IO r -> IO r
withAbstractSem = forall a. a -> a
id }