{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HIE.Bios.Process
  ( CreateProcess(..)
  -- * Run processes with extra environment variables
  , readProcessWithCwd
  , readProcessWithCwd_
  , readProcessWithCwd'
  , readProcessWithOutputs
  , getCleanEnvironment
  -- * File Caching
  , cacheFile
  -- * Find file utilities
  , findFileUpwards
  , findFileUpwardsPredicate
  , findFile
  )
  where

import Control.Applicative (optional)
import Control.DeepSeq
import Control.Exception (handleJust)
import System.Exit
import System.Directory hiding (findFile)
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Conduit.Process
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit as C
import qualified Data.Conduit.Text as C
import qualified Data.HashMap.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import System.Environment
import System.FilePath
import System.IO (hClose, hGetContents, hSetBuffering, BufferMode(LineBuffering), withFile, IOMode(..))
import System.IO.Error (isPermissionError)
import System.IO.Temp

import HIE.Bios.Types
import Control.Monad.Extra (unlessM)
import System.PosixCompat (setFileMode, accessModes)
import HIE.Bios.Environment (getCacheDir)

-- | Wrapper around 'readCreateProcess' that sets the working directory and
-- clears the environment, suitable for invoking cabal/stack and raw ghc commands.
readProcessWithCwd :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd :: LogAction IO (WithSeverity Log)
-> FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd LogAction IO (WithSeverity Log)
l FilePath
dir FilePath
cmd [FilePath]
args FilePath
stdin = CradleLoadResultT IO FilePath -> IO (CradleLoadResult FilePath)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO FilePath -> IO (CradleLoadResult FilePath))
-> CradleLoadResultT IO FilePath -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
-> FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> CradleLoadResultT IO FilePath
readProcessWithCwd_ LogAction IO (WithSeverity Log)
l FilePath
dir FilePath
cmd [FilePath]
args FilePath
stdin

readProcessWithCwd_ :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ :: LogAction IO (WithSeverity Log)
-> FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> CradleLoadResultT IO FilePath
readProcessWithCwd_ LogAction IO (WithSeverity Log)
l FilePath
dir FilePath
cmd [FilePath]
args FilePath
stdin = do
  [(FilePath, FilePath)]
cleanEnv <- IO [(FilePath, FilePath)]
-> CradleLoadResultT IO [(FilePath, FilePath)]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
getCleanEnvironment
  let createdProc' :: CreateProcess
createdProc' = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args) { cwd = Just dir, env = Just cleanEnv }
  LogAction IO (WithSeverity Log)
-> CreateProcess -> FilePath -> CradleLoadResultT IO FilePath
readProcessWithCwd' LogAction IO (WithSeverity Log)
l CreateProcess
createdProc' FilePath
stdin

-- | Wrapper around 'readCreateProcessWithExitCode', wrapping the result in
-- a 'CradleLoadResult'. Provides better error messages than raw 'readCreateProcess'.
readProcessWithCwd' :: LogAction IO (WithSeverity Log) -> CreateProcess -> String -> CradleLoadResultT IO String
readProcessWithCwd' :: LogAction IO (WithSeverity Log)
-> CreateProcess -> FilePath -> CradleLoadResultT IO FilePath
readProcessWithCwd' LogAction IO (WithSeverity Log)
l CreateProcess
createdProcess FilePath
stdin = do
  Maybe (ExitCode, FilePath, FilePath)
mResult <- IO (Maybe (ExitCode, FilePath, FilePath))
-> CradleLoadResultT IO (Maybe (ExitCode, FilePath, FilePath))
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ExitCode, FilePath, FilePath))
 -> CradleLoadResultT IO (Maybe (ExitCode, FilePath, FilePath)))
-> IO (Maybe (ExitCode, FilePath, FilePath))
-> CradleLoadResultT IO (Maybe (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$ IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (IO (ExitCode, FilePath, FilePath)
 -> IO (Maybe (ExitCode, FilePath, FilePath)))
-> IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$ CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode CreateProcess
createdProcess FilePath
stdin
  IO () -> CradleLoadResultT IO ()
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& CreateProcess -> Log
LogCreateProcessRun CreateProcess
createdProcess Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  let cmdString :: FilePath
cmdString = CmdSpec -> FilePath
prettyCmdSpec (CmdSpec -> FilePath) -> CmdSpec -> FilePath
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
createdProcess
  case Maybe (ExitCode, FilePath, FilePath)
mResult of
    Just (ExitCode
ExitSuccess, FilePath
stdo, FilePath
_) -> FilePath -> CradleLoadResultT IO FilePath
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
stdo
    Just (ExitCode
exitCode, FilePath
stdo, FilePath
stde) -> CradleError -> CradleLoadResultT IO FilePath
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE (CradleError -> CradleLoadResultT IO FilePath)
-> CradleError -> CradleLoadResultT IO FilePath
forall a b. (a -> b) -> a -> b
$
      [FilePath] -> ExitCode -> [FilePath] -> [FilePath] -> CradleError
CradleError [] ExitCode
exitCode
        ([FilePath
"Error when calling " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
cmdString, FilePath
stdo, FilePath
stde] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> CreateProcess -> [FilePath]
prettyProcessEnv CreateProcess
createdProcess)
        []
    Maybe (ExitCode, FilePath, FilePath)
Nothing -> CradleError -> CradleLoadResultT IO FilePath
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE (CradleError -> CradleLoadResultT IO FilePath)
-> CradleError -> CradleLoadResultT IO FilePath
forall a b. (a -> b) -> a -> b
$
      [FilePath] -> ExitCode -> [FilePath] -> [FilePath] -> CradleError
CradleError [] ExitCode
ExitSuccess
        ([FilePath
"Couldn't execute " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
cmdString] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> CreateProcess -> [FilePath]
prettyProcessEnv CreateProcess
createdProcess)
        []


-- | Some environments (e.g. stack exec) include GHC_PACKAGE_PATH.
-- Cabal v2 *will* complain, even though or precisely because it ignores them.
-- Unset them from the environment to sidestep this
getCleanEnvironment :: IO [(String, String)]
getCleanEnvironment :: IO [(FilePath, FilePath)]
getCleanEnvironment = do
  HashMap FilePath FilePath -> [(FilePath, FilePath)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap FilePath FilePath -> [(FilePath, FilePath)])
-> ([(FilePath, FilePath)] -> HashMap FilePath FilePath)
-> [(FilePath, FilePath)]
-> [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HashMap FilePath FilePath -> HashMap FilePath FilePath
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete FilePath
"GHC_PACKAGE_PATH" (HashMap FilePath FilePath -> HashMap FilePath FilePath)
-> ([(FilePath, FilePath)] -> HashMap FilePath FilePath)
-> [(FilePath, FilePath)]
-> HashMap FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, FilePath)] -> HashMap FilePath FilePath
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment

type Outputs = [OutputName]
type OutputName = String

-- | Call a given process with temp files for the process to write to.
-- * The process can discover the temp files paths by reading the environment.
-- * The contents of the temp files are returned by this function, if any.
-- * The logging function is called every time the process emits anything to stdout or stderr.
-- it can be used to report progress of the process to a user.
-- * The process is executed in the given directory.
readProcessWithOutputs
  :: Outputs  -- ^ Names of the outputs produced by this process
  -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs.
  -> FilePath -- ^ Working directory. Process is executed in this directory.
  -> CreateProcess -- ^ Parameters for the process to be executed.
  -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])])
readProcessWithOutputs :: [FilePath]
-> LogAction IO (WithSeverity Log)
-> FilePath
-> CreateProcess
-> IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
readProcessWithOutputs [FilePath]
outputNames LogAction IO (WithSeverity Log)
l FilePath
workDir CreateProcess
cp = (ContT
   (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
   IO
   (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
 -> ((ExitCode, [FilePath], [FilePath],
      [(FilePath, Maybe [FilePath])])
     -> IO
          (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])]))
 -> IO
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])]))
-> ((ExitCode, [FilePath], [FilePath],
     [(FilePath, Maybe [FilePath])])
    -> IO
         (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])]))
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
-> IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContT
  (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
  IO
  (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
-> ((ExitCode, [FilePath], [FilePath],
     [(FilePath, Maybe [FilePath])])
    -> IO
         (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])]))
-> IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
-> IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContT
   (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
   IO
   (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
 -> IO
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])]))
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
-> IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
forall a b. (a -> b) -> a -> b
$ do
  [(FilePath, FilePath)]
old_env <- IO [(FilePath, FilePath)]
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     [(FilePath, FilePath)]
forall a.
IO a
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
getCleanEnvironment
  [(FilePath, FilePath)]
output_files <- (FilePath
 -> ContT
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
      IO
      (FilePath, FilePath))
-> [FilePath]
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     [(FilePath, FilePath)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([(FilePath, FilePath)]
-> FilePath
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (FilePath, FilePath)
forall a.
[(FilePath, FilePath)]
-> FilePath -> ContT a IO (FilePath, FilePath)
withOutput [(FilePath, FilePath)]
old_env) [FilePath]
outputNames

  let process :: CreateProcess
process = CreateProcess
cp { env = Just $ output_files ++ fromMaybe old_env (env cp),
                     cwd = Just workDir
                    }

    -- Windows line endings are not converted so you have to filter out `'r` characters
  let loggingConduit :: ConduitT ByteString c IO [FilePath]
loggingConduit = ConduitT ByteString Text IO ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
C.decodeUtf8  ConduitT ByteString Text IO ()
-> ConduitT Text c IO [FilePath]
-> ConduitT ByteString c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| ConduitT Text Text IO ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
C.lines ConduitT Text Text IO ()
-> ConduitT Text c IO [FilePath] -> ConduitT Text c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| (Element Text -> Bool) -> ConduitT Text Text IO ()
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
(Element seq -> Bool) -> ConduitT seq seq m ()
C.filterE (Element Text -> Element Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Element Text
'\r')
        ConduitT Text Text IO ()
-> ConduitT Text c IO [FilePath] -> ConduitT Text c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| (Text -> FilePath) -> ConduitT Text FilePath IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
C.map Text -> FilePath
T.unpack ConduitT Text FilePath IO ()
-> ConduitT FilePath c IO [FilePath]
-> ConduitT Text c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| (FilePath -> IO ()) -> ConduitT FilePath FilePath IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ConduitT a a m ()
C.iterM (\FilePath
msg -> LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& FilePath -> Log
LogProcessOutput FilePath
msg Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug) ConduitT FilePath FilePath IO ()
-> ConduitT FilePath c IO [FilePath]
-> ConduitT FilePath c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| ConduitT FilePath c IO [FilePath]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
C.sinkList
  IO ()
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     ()
forall a.
IO a
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ContT
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
      IO
      ())
-> IO ()
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& CreateProcess -> Log
LogCreateProcessRun CreateProcess
process Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  (ExitCode
ex, [FilePath]
stdo, [FilePath]
stde) <- IO (ExitCode, [FilePath], [FilePath])
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (ExitCode, [FilePath], [FilePath])
forall a.
IO a
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [FilePath], [FilePath])
 -> ContT
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
      IO
      (ExitCode, [FilePath], [FilePath]))
-> IO (ExitCode, [FilePath], [FilePath])
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (ExitCode, [FilePath], [FilePath])
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO [FilePath]
-> ConduitT ByteString Void IO [FilePath]
-> IO (ExitCode, [FilePath], [FilePath])
forall (m :: * -> *) a b.
MonadUnliftIO m =>
CreateProcess
-> ConduitT () ByteString m ()
-> ConduitT ByteString Void m a
-> ConduitT ByteString Void m b
-> m (ExitCode, a, b)
sourceProcessWithStreams CreateProcess
process ConduitT () ByteString IO ()
forall a. Monoid a => a
mempty ConduitT ByteString Void IO [FilePath]
forall {c}. ConduitT ByteString c IO [FilePath]
loggingConduit ConduitT ByteString Void IO [FilePath]
forall {c}. ConduitT ByteString c IO [FilePath]
loggingConduit

  [(FilePath, Maybe [FilePath])]
res <- [(FilePath, FilePath)]
-> ((FilePath, FilePath)
    -> ContT
         (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
         IO
         (FilePath, Maybe [FilePath]))
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     [(FilePath, Maybe [FilePath])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FilePath, FilePath)]
output_files (((FilePath, FilePath)
  -> ContT
       (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
       IO
       (FilePath, Maybe [FilePath]))
 -> ContT
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
      IO
      [(FilePath, Maybe [FilePath])])
-> ((FilePath, FilePath)
    -> ContT
         (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
         IO
         (FilePath, Maybe [FilePath]))
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     [(FilePath, Maybe [FilePath])]
forall a b. (a -> b) -> a -> b
$ \(FilePath
name,FilePath
path) ->
          IO (FilePath, Maybe [FilePath])
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (FilePath, Maybe [FilePath])
forall a.
IO a
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, Maybe [FilePath])
 -> ContT
      (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
      IO
      (FilePath, Maybe [FilePath]))
-> IO (FilePath, Maybe [FilePath])
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (FilePath, Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ (FilePath
name,) (Maybe [FilePath] -> (FilePath, Maybe [FilePath]))
-> IO (Maybe [FilePath]) -> IO (FilePath, Maybe [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe [FilePath])
readOutput FilePath
path

  (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
forall a.
a
-> ContT
     (ExitCode, [FilePath], [FilePath], [(FilePath, Maybe [FilePath])])
     IO
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, [FilePath]
stdo, [FilePath]
stde, [(FilePath, Maybe [FilePath])]
res)

    where
      readOutput :: FilePath -> IO (Maybe [String])
      readOutput :: FilePath -> IO (Maybe [FilePath])
readOutput FilePath
path = do
        Bool
haveFile <- FilePath -> IO Bool
doesFileExist FilePath
path
        if Bool
haveFile
          then FilePath
-> IOMode
-> (Handle -> IO (Maybe [FilePath]))
-> IO (Maybe [FilePath])
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
path IOMode
ReadMode ((Handle -> IO (Maybe [FilePath])) -> IO (Maybe [FilePath]))
-> (Handle -> IO (Maybe [FilePath])) -> IO (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering
            !FilePath
res <- FilePath -> FilePath
forall a. NFData a => a -> a
force (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO FilePath
hGetContents Handle
handle
            Maybe [FilePath] -> IO (Maybe [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [FilePath] -> IO (Maybe [FilePath]))
-> Maybe [FilePath] -> IO (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just ([FilePath] -> Maybe [FilePath]) -> [FilePath] -> Maybe [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') FilePath
res
          else
            Maybe [FilePath] -> IO (Maybe [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [FilePath]
forall a. Maybe a
Nothing

      withOutput :: [(String,String)] -> OutputName -> ContT a IO (OutputName, String)
      withOutput :: forall a.
[(FilePath, FilePath)]
-> FilePath -> ContT a IO (FilePath, FilePath)
withOutput [(FilePath, FilePath)]
env' FilePath
name =
        case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
name [(FilePath, FilePath)]
env' of
          Just file :: FilePath
file@(Char
_:FilePath
_) -> (((FilePath, FilePath) -> IO a) -> IO a)
-> ContT a IO (FilePath, FilePath)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((FilePath, FilePath) -> IO a) -> IO a)
 -> ContT a IO (FilePath, FilePath))
-> (((FilePath, FilePath) -> IO a) -> IO a)
-> ContT a IO (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ \(FilePath, FilePath) -> IO a
action -> do
            FilePath -> IO ()
removeFileIfExists FilePath
file
            (FilePath, FilePath) -> IO a
action (FilePath
name, FilePath
file)
          Maybe FilePath
_ -> (((FilePath, FilePath) -> IO a) -> IO a)
-> ContT a IO (FilePath, FilePath)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((FilePath, FilePath) -> IO a) -> IO a)
 -> ContT a IO (FilePath, FilePath))
-> (((FilePath, FilePath) -> IO a) -> IO a)
-> ContT a IO (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ \(FilePath, FilePath) -> IO a
action -> FilePath -> (FilePath -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
name ((FilePath -> Handle -> IO a) -> IO a)
-> (FilePath -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ FilePath
file Handle
h -> do
            Handle -> IO ()
hClose Handle
h
            FilePath -> IO ()
removeFileIfExists FilePath
file
            (FilePath, FilePath) -> IO a
action (FilePath
name, FilePath
file)

-- | Create and cache a file in hie-bios's cache directory.
--
-- @'cacheFile' fpName srcHash populate@. 'fpName' is the pattern name of the
-- cached file you want to create. 'srcHash' is the hash that is appended to
-- the file pattern and is expected to change whenever you want to invalidate
-- the cache.
--
-- If the cached file's 'srcHash' changes, then a new file is created, but
-- the old cached file name will not be deleted.
--
-- If the file does not exist yet, 'populate' is invoked with cached file
-- location and it is expected that the caller persists the given filepath in
-- the File System.
cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath
cacheFile :: FilePath -> FilePath -> (FilePath -> IO ()) -> IO FilePath
cacheFile FilePath
fpName FilePath
srcHash FilePath -> IO ()
populate = do
  FilePath
cacheDir <- FilePath -> IO FilePath
getCacheDir FilePath
""
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
cacheDir
  let newFpName :: FilePath
newFpName = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> (FilePath -> FilePath
dropExtensions FilePath
fpName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
srcHash) FilePath -> FilePath -> FilePath
<.> FilePath -> FilePath
takeExtensions FilePath
fpName
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist FilePath
newFpName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO ()
populate FilePath
newFpName
    FilePath -> IO ()
setMode FilePath
newFpName
  FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
newFpName
  where
    setMode :: FilePath -> IO ()
setMode FilePath
wrapper_fp = FilePath -> FileMode -> IO ()
setFileMode FilePath
wrapper_fp FileMode
accessModes

------------------------------------------------------------------------------
-- Utilities


-- | Searches upwards for the first directory containing a file.
findFileUpwards :: FilePath -> FilePath -> MaybeT IO FilePath
findFileUpwards :: FilePath -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath
filename FilePath
dir = do
  Bool
cnts <-
    IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe Bool) -> (Bool -> IO Bool) -> IO Bool -> IO Bool
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
        -- Catch permission errors
        (\(IOError
e :: IOError) -> if IOError -> Bool
isPermissionError IOError
e then Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False else Maybe Bool
forall a. Maybe a
Nothing)
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
filename))
  case Bool
cnts of
    Bool
False | FilePath
dir' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir -> FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No cabal files"
            | Bool
otherwise   -> FilePath -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath
filename FilePath
dir'
    Bool
True -> FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
  where dir' :: FilePath
dir' = FilePath -> FilePath
takeDirectory FilePath
dir

-- | Searches upwards for the first directory containing a file to match
-- the predicate.
--
-- *WARNING*, this scans all the files of all the directories upward. If
-- appliable, prefer to use 'findFileUpwards'
findFileUpwardsPredicate :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwardsPredicate :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwardsPredicate FilePath -> Bool
p FilePath
dir = do
  [FilePath]
cnts <-
    IO [FilePath] -> MaybeT IO [FilePath]
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO [FilePath] -> MaybeT IO [FilePath])
-> IO [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe [FilePath])
-> ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
        -- Catch permission errors
        (\(IOError
e :: IOError) -> if IOError -> Bool
isPermissionError IOError
e then [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [] else Maybe [FilePath]
forall a. Maybe a
Nothing)
        [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ((FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile FilePath -> Bool
p FilePath
dir)

  case [FilePath]
cnts of
    [] | FilePath
dir' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir -> FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No cabal files"
            | Bool
otherwise   -> (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwardsPredicate FilePath -> Bool
p FilePath
dir'
    FilePath
_ : [FilePath]
_ -> FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
  where dir' :: FilePath
dir' = FilePath -> FilePath
takeDirectory FilePath
dir

-- | Sees if any file in the directory matches the predicate
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile FilePath -> Bool
p FilePath
dir = do
  Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
  if Bool
b then IO [FilePath]
getFiles IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesPredFileExist else [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    getFiles :: IO [FilePath]
getFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
p ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
    doesPredFileExist :: FilePath -> IO Bool
doesPredFileExist FilePath
file = FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists FilePath
f = do
  Bool
yes <- FilePath -> IO Bool
doesFileExist FilePath
f
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes (FilePath -> IO ()
removeFile FilePath
f)