{-# LANGUAGE CPP #-}

-- | Temporary file-system management
module GHC.Utils.TmpFs
    ( TmpFs
    , initTmpFs
    , forkTmpFsFrom
    , mergeTmpFsInto
    , PathsToClean(..)
    , emptyPathsToClean
    , TempFileLifetime(..)
    , TempDir (..)
    , cleanTempDirs
    , cleanTempFiles
    , cleanCurrentModuleTempFiles
    , keepCurrentModuleTempFiles
    , addFilesToClean
    , changeTempFilesLifetime
    , newTempName
    , newTempLibName
    , newTempSubDir
    , withSystemTempDirectory
    , withTempDirectory
    )
where

import GHC.Prelude

import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Misc
import GHC.Utils.Exception as Exception
import GHC.Driver.Phases

import Data.List (partition)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.IORef
import System.Directory
import System.FilePath
import System.IO.Error

#if !defined(mingw32_HOST_OS)
import qualified System.Posix.Internals
#endif

-- | Temporary file-system
data TmpFs = TmpFs
  { TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
      -- ^ Maps system temporary directory (passed via settings or DynFlags) to
      -- an actual temporary directory for this process.
      --
      -- It's a Map probably to support changing the system temporary directory
      -- over time.
      --
      -- Shared with forked TmpFs.

  , TmpFs -> IORef Int
tmp_next_suffix :: IORef Int
      -- ^ The next available suffix to uniquely name a temp file, updated
      -- atomically.
      --
      -- Shared with forked TmpFs.

  , TmpFs -> FilePath
tmp_dir_prefix :: String

  , TmpFs -> IORef PathsToClean
tmp_files_to_clean :: IORef PathsToClean
      -- ^ Files to clean (per session or per module)
      --
      -- Not shared with forked TmpFs.
  , TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean :: IORef PathsToClean
      -- ^ Subdirs to clean (per session or per module)
      --
      -- Not shared with forked TmpFs.
  }

-- | A collection of paths that must be deleted before ghc exits.
data PathsToClean = PathsToClean
    { PathsToClean -> Set FilePath
ptcGhcSession :: !(Set FilePath)
        -- ^ Paths that will be deleted at the end of runGhc(T)

    , PathsToClean -> Set FilePath
ptcCurrentModule :: !(Set FilePath)
        -- ^ Paths that will be deleted the next time
        -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of
        -- the session.
    }

-- | Used when a temp file is created. This determines which component Set of
-- PathsToClean will get the temp file
data TempFileLifetime
  = TFL_CurrentModule
  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
  -- end of upweep_mod
  | TFL_GhcSession
  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
  -- runGhc(T)
  deriving (Int -> TempFileLifetime -> ShowS
[TempFileLifetime] -> ShowS
TempFileLifetime -> FilePath
(Int -> TempFileLifetime -> ShowS)
-> (TempFileLifetime -> FilePath)
-> ([TempFileLifetime] -> ShowS)
-> Show TempFileLifetime
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TempFileLifetime -> ShowS
showsPrec :: Int -> TempFileLifetime -> ShowS
$cshow :: TempFileLifetime -> FilePath
show :: TempFileLifetime -> FilePath
$cshowList :: [TempFileLifetime] -> ShowS
showList :: [TempFileLifetime] -> ShowS
Show)

newtype TempDir = TempDir FilePath

-- | An empty PathsToClean
emptyPathsToClean :: PathsToClean
emptyPathsToClean :: PathsToClean
emptyPathsToClean = Set FilePath -> Set FilePath -> PathsToClean
PathsToClean Set FilePath
forall a. Set a
Set.empty Set FilePath
forall a. Set a
Set.empty

-- | Merge two PathsToClean
mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
x PathsToClean
y = PathsToClean
    { ptcGhcSession :: Set FilePath
ptcGhcSession    = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union (PathsToClean -> Set FilePath
ptcGhcSession PathsToClean
x) (PathsToClean -> Set FilePath
ptcGhcSession PathsToClean
y)
    , ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union (PathsToClean -> Set FilePath
ptcCurrentModule PathsToClean
x) (PathsToClean -> Set FilePath
ptcCurrentModule PathsToClean
y)
    }

-- | Initialise an empty TmpFs
initTmpFs :: IO TmpFs
initTmpFs :: IO TmpFs
initTmpFs = do
    files   <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
    subdirs <- newIORef emptyPathsToClean
    dirs    <- newIORef Map.empty
    next    <- newIORef 0
    return $ TmpFs
        { tmp_files_to_clean   = files
        , tmp_subdirs_to_clean = subdirs
        , tmp_dirs_to_clean    = dirs
        , tmp_next_suffix      = next
        , tmp_dir_prefix       = "tmp"
        }

-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary
-- directories with the given TmpFs
--
-- It's not safe to use the subdirs created by the original TmpFs with the
-- forked one. Use @newTempSubDir@ to create new subdirs instead.
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
old = do
    files <- PathsToClean -> IO (IORef PathsToClean)
forall a. a -> IO (IORef a)
newIORef PathsToClean
emptyPathsToClean
    subdirs <- newIORef emptyPathsToClean
    counter <- newIORef 0
    prefix  <- newTempSuffix old


    return $ TmpFs
        { tmp_files_to_clean   = files
        , tmp_subdirs_to_clean = subdirs
        , tmp_dirs_to_clean    = tmp_dirs_to_clean old
        , tmp_next_suffix      = counter
        , tmp_dir_prefix       = prefix
        }

-- | Merge the first TmpFs into the second.
--
-- The first TmpFs is returned emptied.
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
src TmpFs
dst = do
    src_files <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, PathsToClean))
-> IO PathsToClean
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
src) (\PathsToClean
s -> (PathsToClean
emptyPathsToClean, PathsToClean
s))
    src_subdirs <- atomicModifyIORef' (tmp_subdirs_to_clean src) (\PathsToClean
s -> (PathsToClean
emptyPathsToClean, PathsToClean
s))
    atomicModifyIORef' (tmp_files_to_clean dst) (\PathsToClean
s -> (PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
src_files PathsToClean
s, ()))
    atomicModifyIORef' (tmp_subdirs_to_clean dst) (\PathsToClean
s -> (PathsToClean -> PathsToClean -> PathsToClean
mergePathsToClean PathsToClean
src_subdirs PathsToClean
s, ()))


cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs Logger
logger TmpFs
tmpfs
   = IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do let ref :: IORef (Map FilePath FilePath)
ref = TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
tmpfs
        ds <- IORef (Map FilePath FilePath)
-> (Map FilePath FilePath
    -> (Map FilePath FilePath, Map FilePath FilePath))
-> IO (Map FilePath FilePath)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map FilePath FilePath)
ref ((Map FilePath FilePath
  -> (Map FilePath FilePath, Map FilePath FilePath))
 -> IO (Map FilePath FilePath))
-> (Map FilePath FilePath
    -> (Map FilePath FilePath, Map FilePath FilePath))
-> IO (Map FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ \Map FilePath FilePath
ds -> (Map FilePath FilePath
forall k a. Map k a
Map.empty, Map FilePath FilePath
ds)
        removeTmpDirs logger (Map.elems ds)

-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@.
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles :: Logger -> TmpFs -> IO ()
cleanTempFiles Logger
logger TmpFs
tmpfs
   = IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger) (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
        ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger) (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs)
  where
    removeWith :: ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith [FilePath] -> IO b
remove IORef PathsToClean
ref = do
      to_delete <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
        \PathsToClean
            { ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths
            , ptcGhcSession :: PathsToClean -> Set FilePath
ptcGhcSession = Set FilePath
gs_paths
            } -> ( PathsToClean
emptyPathsToClean
                  , Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
gs_paths)
      remove to_delete

-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@
-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is
-- used in an OPTIONS_GHC pragma.
-- This function removes the temporary file from the TmpFs so we no longer remove
-- it at the env when cleanTempFiles is called.
keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
   = IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do to_keep_files <- IORef PathsToClean -> IO [FilePath]
keep  (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
        to_keep_subdirs <- keep  (tmp_subdirs_to_clean tmpfs)
        -- Remove any folders which contain any files we want to keep from the
        -- directories we are tracking. A new temporary directory will be created
        -- the next time a temporary file is needed (by perhaps another module).
        keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs)
  where
    keepDirs :: [FilePath] -> IORef (Map k FilePath) -> IO ()
keepDirs [FilePath]
keeps IORef (Map k FilePath)
ref = do
      let keep_dirs :: Set FilePath
keep_dirs = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takeDirectory [FilePath]
keeps)
      IORef (Map k FilePath)
-> (Map k FilePath -> (Map k FilePath, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map k FilePath)
ref  ((Map k FilePath -> (Map k FilePath, ())) -> IO ())
-> (Map k FilePath -> (Map k FilePath, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map k FilePath
m -> ((FilePath -> Bool) -> Map k FilePath -> Map k FilePath
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\FilePath
fp -> FilePath
fp FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set FilePath
keep_dirs) Map k FilePath
m, ())

    keep :: IORef PathsToClean -> IO [FilePath]
keep IORef PathsToClean
ref = do
        to_keep <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
            \ptc :: PathsToClean
ptc@PathsToClean{ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths} ->
                (PathsToClean
ptc {ptcCurrentModule = Set.empty}, Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths)
        debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep))
        return to_keep

-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@
-- That have lifetime TFL_CurrentModule.
-- If a file must be cleaned eventually, but must survive a
-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
   = IO () -> IO ()
forall a. IO a -> IO a
mask_
   (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger) (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
        ([FilePath] -> IO ()) -> IORef PathsToClean -> IO ()
forall {b}. ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith (Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger) (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs)
  where
    removeWith :: ([FilePath] -> IO b) -> IORef PathsToClean -> IO b
removeWith [FilePath] -> IO b
remove IORef PathsToClean
ref = do
        to_delete <- IORef PathsToClean
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PathsToClean
ref ((PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath])
-> (PathsToClean -> (PathsToClean, [FilePath])) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
            \ptc :: PathsToClean
ptc@PathsToClean{ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths} ->
                (PathsToClean
ptc {ptcCurrentModule = Set.empty}, Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_paths)
        remove to_delete

-- | Ensure that new_files are cleaned on the next call of
-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
-- If any of new_files are already tracked, they will have their lifetime
-- updated.
addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
new_files =
  IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs) TempFileLifetime
lifetime [FilePath]
new_files

addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addSubdirsToClean TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
new_subdirs =
  IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean (TmpFs -> IORef PathsToClean
tmp_subdirs_to_clean TmpFs
tmpfs) TempFileLifetime
lifetime [FilePath]
new_subdirs

addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()
addToClean IORef PathsToClean
ref TempFileLifetime
lifetime [FilePath]
new_filepaths = IORef PathsToClean -> (PathsToClean -> PathsToClean) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef PathsToClean
ref ((PathsToClean -> PathsToClean) -> IO ())
-> (PathsToClean -> PathsToClean) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \PathsToClean
    { ptcCurrentModule :: PathsToClean -> Set FilePath
ptcCurrentModule = Set FilePath
cm_paths
    , ptcGhcSession :: PathsToClean -> Set FilePath
ptcGhcSession = Set FilePath
gs_paths
    } -> case TempFileLifetime
lifetime of
      TempFileLifetime
TFL_CurrentModule -> PathsToClean
        { ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath
cm_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_filepaths_set
        , ptcGhcSession :: Set FilePath
ptcGhcSession = Set FilePath
gs_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_filepaths_set
        }
      TempFileLifetime
TFL_GhcSession -> PathsToClean
        { ptcCurrentModule :: Set FilePath
ptcCurrentModule = Set FilePath
cm_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set FilePath
new_filepaths_set
        , ptcGhcSession :: Set FilePath
ptcGhcSession = Set FilePath
gs_paths Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set FilePath
new_filepaths_set
        }
  where
    new_filepaths_set :: Set FilePath
new_filepaths_set = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
new_filepaths

-- | Update the lifetime of files already being tracked. If any files are
-- not being tracked they will be discarded.
changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime TmpFs
tmpfs TempFileLifetime
lifetime [FilePath]
files = do
  PathsToClean
    { ptcCurrentModule = cm_paths
    , ptcGhcSession = gs_paths
    } <- IORef PathsToClean -> IO PathsToClean
forall a. IORef a -> IO a
readIORef (TmpFs -> IORef PathsToClean
tmp_files_to_clean TmpFs
tmpfs)
  let old_set = case TempFileLifetime
lifetime of
        TempFileLifetime
TFL_CurrentModule -> Set FilePath
gs_paths
        TempFileLifetime
TFL_GhcSession -> Set FilePath
cm_paths
      existing_files = [FilePath
f | FilePath
f <- [FilePath]
files, FilePath
f FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
old_set]
  addFilesToClean tmpfs lifetime existing_files

-- Return a unique numeric temp file suffix
newTempSuffix :: TmpFs -> IO String
newTempSuffix :: TmpFs -> IO FilePath
newTempSuffix TmpFs
tmpfs = do
  n <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TmpFs -> IORef Int
tmp_next_suffix TmpFs
tmpfs) ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
n -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
n)
  return $ tmp_dir_prefix tmpfs ++ "_" ++ show n


-- Find a temporary name that doesn't already exist.
newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath
newTempName :: Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
lifetime FilePath
extn
  = do d <- Logger -> TmpFs -> TempDir -> IO FilePath
getTempDir Logger
logger TmpFs
tmpfs TempDir
tmp_dir
       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
  where
    findTempName :: FilePath -> IO FilePath
    findTempName :: FilePath -> IO FilePath
findTempName FilePath
prefix
      = do suffix <- TmpFs -> IO FilePath
newTempSuffix TmpFs
tmpfs
           let filename = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
suffix FilePath -> ShowS
<.> FilePath
extn
           b <- doesFileExist filename
           if b then findTempName prefix
                else do -- clean it up later
                        addFilesToClean tmpfs lifetime [filename]
                        return filename

-- | Create a new temporary subdirectory that doesn't already exist
-- The temporary subdirectory is automatically removed at the end of the
-- GHC session, but its contents aren't. Make sure to leave the directory
-- empty before the end of the session, either by removing content
-- directly or by using @addFilesToClean@.
--
-- If the created subdirectory is not empty, it will not be removed (along
-- with its parent temporary directory) and a warning message will be
-- printed at verbosity 2 and higher.
newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath
newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath
newTempSubDir Logger
logger TmpFs
tmpfs TempDir
tmp_dir
  = do d <- Logger -> TmpFs -> TempDir -> IO FilePath
getTempDir Logger
logger TmpFs
tmpfs TempDir
tmp_dir
       findTempDir (d </> "ghc_")
  where
    findTempDir :: FilePath -> IO FilePath
    findTempDir :: FilePath -> IO FilePath
findTempDir FilePath
prefix
      = do suffix <- TmpFs -> IO FilePath
newTempSuffix TmpFs
tmpfs
           let name = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
suffix
           b <- doesDirectoryExist name
           if b then findTempDir prefix
                else (do
                  createDirectory name
                  addSubdirsToClean tmpfs TFL_GhcSession [name]
                  return name)
            `Exception.catchIO` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                  then FilePath -> IO FilePath
findTempDir FilePath
prefix else IOException -> IO FilePath
forall a. HasCallStack => IOException -> IO a
ioError IOException
e

newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix
  -> IO (FilePath, FilePath, String)
newTempLibName :: Logger
-> TmpFs
-> TempDir
-> TempFileLifetime
-> FilePath
-> IO (FilePath, FilePath, FilePath)
newTempLibName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
lifetime FilePath
extn
  = do d <- Logger -> TmpFs -> TempDir -> IO FilePath
getTempDir Logger
logger TmpFs
tmpfs TempDir
tmp_dir
       findTempName d ("ghc_")
  where
    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
    findTempName :: FilePath -> FilePath -> IO (FilePath, FilePath, FilePath)
findTempName FilePath
dir FilePath
prefix
      = do suffix <- TmpFs -> IO FilePath
newTempSuffix TmpFs
tmpfs -- See Note [Deterministic base name]
           let libname = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
suffix
               filename = FilePath
dir FilePath -> ShowS
</> FilePath
"lib" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
libname FilePath -> ShowS
<.> FilePath
extn
           b <- doesFileExist filename
           if b then findTempName dir prefix
                else do -- clean it up later
                        addFilesToClean tmpfs lifetime [filename]
                        return (filename, dir, libname)


-- Return our temporary directory within tmp_dir, creating one if we
-- don't have one yet.
getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath
getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath
getTempDir Logger
logger TmpFs
tmpfs (TempDir FilePath
tmp_dir) = do
    mapping <- IORef (Map FilePath FilePath) -> IO (Map FilePath FilePath)
forall a. IORef a -> IO a
readIORef IORef (Map FilePath FilePath)
dir_ref
    case Map.lookup tmp_dir mapping of
        Maybe FilePath
Nothing -> do
            pid <- IO Int
getProcessID
            let prefix = FilePath
tmp_dir FilePath -> ShowS
</> FilePath
"ghc" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pid FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"_"
            mask_ $ mkTempDir prefix
        Just FilePath
dir -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
  where
    dir_ref :: IORef (Map FilePath FilePath)
dir_ref = TmpFs -> IORef (Map FilePath FilePath)
tmp_dirs_to_clean TmpFs
tmpfs

    mkTempDir :: FilePath -> IO FilePath
    mkTempDir :: FilePath -> IO FilePath
mkTempDir FilePath
prefix = do
        suffix <- TmpFs -> IO FilePath
newTempSuffix TmpFs
tmpfs
        let our_dir = FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
suffix

        -- 1. Speculatively create our new directory.
        createDirectory our_dir

        -- 2. Update the tmp_dirs_to_clean mapping unless an entry already exists
        -- (i.e. unless another thread beat us to it).
        their_dir <- atomicModifyIORef' dir_ref $ \Map FilePath FilePath
mapping ->
            case FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
tmp_dir Map FilePath FilePath
mapping of
                Just FilePath
dir -> (Map FilePath FilePath
mapping, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)
                Maybe FilePath
Nothing  -> (FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
tmp_dir FilePath
our_dir Map FilePath FilePath
mapping, Maybe FilePath
forall a. Maybe a
Nothing)

        -- 3. If there was an existing entry, return it and delete the
        -- directory we created.  Otherwise return the directory we created.
        case their_dir of
            Maybe FilePath
Nothing  -> do
                Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                    FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Created temporary directory:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
our_dir
                FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
our_dir
            Just FilePath
dir -> do
                FilePath -> IO ()
removeDirectory FilePath
our_dir
                FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
      IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                      then FilePath -> IO FilePath
mkTempDir FilePath
prefix else IOException -> IO FilePath
forall a. HasCallStack => IOException -> IO a
ioError IOException
e

{- Note [Deterministic base name]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The filename of temporary files, especially the basename of C files, can end
up in the output in some form, e.g. as part of linker debug information. In the
interest of bit-wise exactly reproducible compilation (#4012), the basename of
the temporary file no longer contains random information (it used to contain
the process id).

This is ok, as the temporary directory used contains the pid (see getTempDir).

In addition to this, multiple threads can race against each other creating temporary
files. Therefore we supply a prefix when creating temporary files, when a thread is
forked, each thread must be given an TmpFs with a unique prefix. This is achieved
by forkTmpFsFrom creating a fresh prefix from the parent TmpFs.
-}

manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
manyWithTrace :: Logger -> FilePath -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
manyWithTrace Logger
_ FilePath
_ [FilePath] -> IO ()
_ [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- do silent nothing on zero filepaths
manyWithTrace Logger
logger FilePath
phase [FilePath] -> IO ()
act [FilePath]
paths
  = Logger -> FilePath -> FilePath -> IO () -> IO ()
forall a. Logger -> FilePath -> FilePath -> IO a -> IO a
traceCmd Logger
logger FilePath
phase (FilePath
"Deleting: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
paths) ([FilePath] -> IO ()
act [FilePath]
paths)

removeTmpDirs :: Logger -> [FilePath] -> IO ()
removeTmpDirs :: Logger -> [FilePath] -> IO ()
removeTmpDirs Logger
logger
  = Logger -> FilePath -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
manyWithTrace Logger
logger FilePath
"Deleting temp dirs"
                  ((FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
removeDirectory))

removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
removeTmpSubdirs Logger
logger
  = Logger -> FilePath -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
manyWithTrace Logger
logger FilePath
"Deleting temp subdirs"
                  ((FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
removeDirectory))

removeTmpFiles :: Logger -> [FilePath] -> IO ()
removeTmpFiles :: Logger -> [FilePath] -> IO ()
removeTmpFiles Logger
logger [FilePath]
fs
  = IO () -> IO ()
warnNon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger -> FilePath -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
manyWithTrace Logger
logger FilePath
"Deleting temp files"
                  ((FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
removeFile)) [FilePath]
deletees
  where
     -- Flat out refuse to delete files that are likely to be source input
     -- files (is there a worse bug than having a compiler delete your source
     -- files?)
     --
     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
     -- the condition.
    warnNon :: IO () -> IO ()
warnNon IO ()
act
     | [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
non_deletees = IO ()
act
     | Bool
otherwise         = do
        Logger -> SDoc -> IO ()
putMsg Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"WARNING - NOT deleting source files:"
                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text [FilePath]
non_deletees))
        IO ()
act

    ([FilePath]
non_deletees, [FilePath]
deletees) = (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition FilePath -> Bool
isHaskellUserSrcFilename [FilePath]
fs

removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith Logger
logger FilePath -> IO ()
remover FilePath
f = FilePath -> IO ()
remover FilePath
f IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO`
  (\IOException
e ->
   let msg :: SDoc
msg = if IOException -> Bool
isDoesNotExistError IOException
e
             then FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: deleting non-existent" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
f
             else FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Warning: exception raised when deleting"
                                            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e)
   in Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 SDoc
msg
  )

#if defined(mingw32_HOST_OS)
-- relies on Int == Int32 on Windows
foreign import ccall unsafe "_getpid" getProcessID :: IO Int
#else
getProcessID :: IO Int
getProcessID :: IO Int
getProcessID = IO CPid
System.Posix.Internals.c_getpid IO CPid -> (CPid -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (CPid -> Int) -> CPid -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPid -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
#endif

-- The following three functions are from the `temporary` package.

-- | Create and use a temporary directory in the system standard temporary
-- directory.
--
-- Behaves exactly the same as 'withTempDirectory', except that the parent
-- temporary directory will be that returned by 'getTemporaryDirectory'.
withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.
                        -> (FilePath -> IO a) -- ^ Callback that can use the directory
                        -> IO a
withSystemTempDirectory :: forall a. FilePath -> (FilePath -> IO a) -> IO a
withSystemTempDirectory FilePath
template FilePath -> IO a
action =
  IO FilePath
getTemporaryDirectory IO FilePath -> (FilePath -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
tmpDir -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
tmpDir FilePath
template FilePath -> IO a
action


-- | Create and use a temporary directory.
--
-- Creates a new temporary directory inside the given directory, making use
-- of the template. The temp directory is deleted after use. For example:
--
-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
                  -> String   -- ^ Directory name template. See 'openTempFile'.
                  -> (FilePath -> IO a) -- ^ Callback that can use the directory
                  -> IO a
withTempDirectory :: forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory FilePath
targetDir FilePath
template =
  IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    (FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
targetDir FilePath
template)
    (IO () -> IO ()
ignoringIOErrors (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeDirectoryRecursive)

ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors IO ()
ioe = IO ()
ioe IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())


createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory :: FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
dir FilePath
template = do
  pid <- IO Int
getProcessID
  findTempName pid
  where findTempName :: Int -> IO FilePath
findTempName Int
x = do
            let path :: FilePath
path = FilePath
dir FilePath -> ShowS
</> FilePath
template FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x
            FilePath -> IO ()
createDirectory FilePath
path
            FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
          IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`Exception.catchIO` \IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e
                          then Int -> IO FilePath
findTempName (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) else IOException -> IO FilePath
forall a. HasCallStack => IOException -> IO a
ioError IOException
e