Use internal tmpdir

app/ghcup/GHCup/OptParse/GC.hs

@@ -56,26 +56,26 @@ data GCOptions = GCOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 gcP :: Parser GCOptions
 gcP =
   GCOptions
-  <$> 
+  <$>
     switch
       (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
-  <*> 
+  <*>
     switch
       (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
-  <*> 
+  <*>
     switch
       (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
-  <*> 
+  <*>
     switch
       (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
-  <*> 
+  <*>
     switch
       (short 'c' <> long "cache" <> help "GC the GHCup cache")
-  <*> 
+  <*>
     switch
       (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
 

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
+import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
 import           GHCup.Utils.String.QQ
@@ -33,7 +34,6 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Utils.Prelude
 import GHCup.Download (getDownloadsF)
 
 

app/ghcup/Main.hs

@@ -155,7 +155,6 @@ main = do
   versions. It maintains a self-contained ~/.ghcup directory.
 
 ENV variables:
-  * TMPDIR: where ghcup does the work (unpacking, building, ...)
   * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
   * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
 

docs/guide.md

@@ -76,7 +76,6 @@ Partial configuration is fine. Command line options always override the config f
 This is the complete list of env variables that change GHCup behavior:
 
 * `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
-* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
 * `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
 * `GHCUP_CURL_OPTS`: additional options that can be passed to curl
 * `GHCUP_WGET_OPTS`: additional options that can be passed to wget

lib/GHCup.hs

@@ -2029,6 +2029,7 @@ rmGhcupDirs = do
     , cacheDir
     , recycleDir
     , dbDir
+    , tmpDir
     } <- getDirs
 
   let envFilePath = fromGHCupPath baseDir </> "env"
@@ -2040,6 +2041,7 @@ rmGhcupDirs = do
 
   -- for xdg dirs, the order matters here
   handleRm $ rmPathForcibly logsDir
+  handleRm $ rmPathForcibly tmpDir
   handleRm $ rmPathForcibly cacheDir
 
   handleRm $ rmBinDir binDir

lib/GHCup/Types.hs

@@ -441,13 +441,14 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
 instance NFData Settings
 
 data Dirs = Dirs
-  { baseDir  :: GHCupPath
+  { baseDir    :: GHCupPath
-  , binDir   :: FilePath
+  , binDir     :: FilePath
-  , cacheDir :: GHCupPath
+  , cacheDir   :: GHCupPath
-  , logsDir  :: GHCupPath
+  , logsDir    :: GHCupPath
-  , confDir  :: GHCupPath
+  , confDir    :: GHCupPath
-  , dbDir    :: GHCupPath
+  , dbDir      :: GHCupPath
   , recycleDir :: GHCupPath -- mainly used on windows
+  , tmpDir     :: GHCupPath
   }
   deriving (Show, GHC.Generic)
 

lib/GHCup/Utils.hs

@@ -1255,15 +1255,17 @@ ensureGlobalTools
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do
   createDirRecursive' (fromGHCupPath baseDir)
   createDirRecursive' (fromGHCupPath baseDir </> "ghc")
+  createDirRecursive' (fromGHCupPath baseDir </> "hls")
   createDirRecursive' binDir
   createDirRecursive' (fromGHCupPath cacheDir)
   createDirRecursive' (fromGHCupPath logsDir)
   createDirRecursive' (fromGHCupPath confDir)
   createDirRecursive' (fromGHCupPath trashDir)
   createDirRecursive' (fromGHCupPath dbDir)
+  createDirRecursive' (fromGHCupPath tmpDir)
   pure ()
 
 

lib/GHCup/Utils/Dirs.hs

@@ -99,6 +99,9 @@ module GHCup.Utils.Dirs
   , setAccessTime
   , setModificationTime
   , isSymbolicLink
+
+  -- uhm
+  , rmPathForcibly
   )
 where
 
@@ -135,7 +138,6 @@ import           System.Directory hiding ( removeDirectory
                                          )
 import qualified System.Directory              as SD
 
-import           System.DiskSpace
 import           System.Environment
 import           System.FilePath
 import           System.IO.Temp
@@ -145,7 +147,6 @@ import qualified Data.ByteString               as BS
 import qualified Data.Text                     as T
 import qualified Data.Yaml.Aeson               as Y
 import qualified Text.Megaparsec               as MP
-import Control.Concurrent (threadDelay)
 
 
 
@@ -174,7 +175,7 @@ createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp
 
 getGHCupTmpDirs :: IO [GHCupPath]
 getGHCupTmpDirs = do
-  tmpdir <- getCanonicalTemporaryDirectory
+  tmpdir <- fromGHCupPath <$> ghcupTMPDir
   ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
     tmpdir
     (makeRegexOpts compExtended
@@ -323,6 +324,25 @@ ghcupRecycleDir :: IO GHCupPath
 ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
 
 
+-- | Defaults to '~/.ghcup/tmp.
+--
+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
+-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
+ghcupTMPDir :: IO GHCupPath
+ghcupTMPDir
+  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
+          pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
+        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
+
 
 getAllDirs :: IO Dirs
 getAllDirs = do
@@ -332,6 +352,7 @@ getAllDirs = do
   logsDir    <- ghcupLogsDir
   confDir    <- ghcupConfigDir
   recycleDir <- ghcupRecycleDir
+  tmpDir     <- ghcupTMPDir
   dbDir      <- ghcupDbDir
   pure Dirs { .. }
 
@@ -405,6 +426,7 @@ ghcupHLSDir ver = do
   let verdir = T.unpack $ prettyVer ver
   pure (basedir `appendGHCupPath` verdir)
 
+
 mkGhcupTmpDir :: ( MonadReader env m
                  , HasDirs env
                  , MonadUnliftIO m
@@ -415,29 +437,8 @@ mkGhcupTmpDir :: ( MonadReader env m
                  , MonadIO m)
               => m GHCupPath
 mkGhcupTmpDir = GHCupPath <$> do
-  tmpdir <- liftIO getCanonicalTemporaryDirectory
+  Dirs { tmpDir } <- getDirs
-
+  liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
-  let minSpace = 5000 -- a rough guess, aight?
-  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
-  when (maybe False (toBytes minSpace >) space) $ do
-    logWarn ("Possibly insufficient disk space on "
-      <> T.pack tmpdir
-      <> ". At least "
-      <> T.pack (show minSpace)
-      <> " MB are recommended, but only "
-      <> toMB (fromJust space)
-      <> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
-    logWarn
-      "...waiting for 10 seconds before continuing anyway, you can still abort..."
-    liftIO $ threadDelay 10000000 -- give the user a sec to intervene
-
-  liftIO $ createTempDirectory tmpdir "ghcup"
- where
-  toBytes mb = mb * 1024 * 1024
-  toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
-  truncate' :: Double -> Int -> Double
-  truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
-      where t = 10^n
 
 
 withGHCupTmpDir :: ( MonadReader env m
@@ -521,4 +522,13 @@ removePathForcibly :: GHCupPath -> IO ()
 removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
 
 
+rmPathForcibly :: ( MonadIO m
+                  , MonadMask m
+                  )
+               => GHCupPath
+               -> m ()
+rmPathForcibly fp
+  | isWindows = recover (liftIO $ removePathForcibly fp)
+  | otherwise = liftIO $ removePathForcibly fp
+
 

lib/GHCup/Utils/File.hs

@@ -33,7 +33,15 @@ module GHCup.Utils.File (
   removeEmptyDirectory,
   removeDirIfEmptyOrIsSymlink,
   removeEmptyDirsRecursive,
-  rmFileForce
+  rmFileForce,
+  createDirRecursive',
+  recyclePathForcibly,
+  rmDirectory,
+  recycleFile,
+  rmFile,
+  rmDirectoryLink,
+  moveFilePortable,
+  moveFile
 ) where
 
 import GHCup.Utils.Dirs
@@ -235,3 +243,98 @@ rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
 rmFileForce filepath = do
   hideError doesNotExistErrorType
     $ hideError InappropriateType $ rmFile filepath
+
+-- | More permissive version of 'createDirRecursive'. This doesn't
+-- error when the destination is a symlink to a directory.
+createDirRecursive' :: FilePath -> IO ()
+createDirRecursive' p =
+  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
+    . createDirectoryIfMissing True
+    $ p
+
+ where
+  isSymlinkDir e = do
+    ft <- pathIsSymbolicLink p
+    case ft of
+      True -> do
+        rp <- canonicalizePath p
+        rft <- doesDirectoryExist rp
+        case rft of
+          True -> pure ()
+          _ -> throwIO e
+      _ -> throwIO e
+
+
+-- https://github.com/haskell/directory/issues/110
+-- https://github.com/haskell/directory/issues/96
+-- https://www.sqlite.org/src/info/89f1848d7f
+recyclePathForcibly :: ( MonadIO m
+                       , MonadReader env m
+                       , HasDirs env
+                       , MonadMask m
+                       )
+                    => GHCupPath
+                    -> m ()
+recyclePathForcibly fp
+  | isWindows = do
+      Dirs { recycleDir } <- getDirs
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
+      let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
+      liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
+          `catch`
+          (\e -> if | isDoesNotExistError e -> pure ()
+                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
+                    | otherwise -> throwIO e)
+          `finally`
+            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removePathForcibly fp
+
+
+
+rmDirectory :: (MonadIO m, MonadMask m)
+            => GHCupPath
+            -> m ()
+rmDirectory fp
+  | isWindows = recover (liftIO $ removeDirectory fp)
+  | otherwise = liftIO $ removeDirectory fp
+
+
+-- https://www.sqlite.org/src/info/89f1848d7f
+-- https://github.com/haskell/directory/issues/96
+recycleFile :: ( MonadIO m
+               , MonadMask m
+               , MonadReader env m
+               , HasDirs env
+               )
+            => FilePath
+            -> m ()
+recycleFile fp
+  | isWindows = do
+      Dirs { recycleDir } <- getDirs
+      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
+      let dest = fromGHCupPath tmp </> takeFileName fp
+      liftIO (moveFile fp dest)
+        `catch`
+          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
+        `finally`
+          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removeFile fp
+
+
+rmFile :: ( MonadIO m
+          , MonadMask m
+          )
+      => FilePath
+      -> m ()
+rmFile fp
+  | isWindows = recover (liftIO $ removeFile fp)
+  | otherwise = liftIO $ removeFile fp
+
+
+rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
+                => FilePath
+                -> m ()
+rmDirectoryLink fp
+  | isWindows = recover (liftIO $ removeDirectoryLink fp)
+  | otherwise = liftIO $ removeDirectoryLink fp

lib/GHCup/Utils/File.hs-boot

@@ -0,0 +1,14 @@
+{-# LANGUAGE FlexibleContexts  #-}
+
+module GHCup.Utils.File (
+    recycleFile
+) where
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.Reader (MonadReader)
+import GHCup.Types.Optics (HasDirs)
+
+
+recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
+

lib/GHCup/Utils/File/Posix.hs

@@ -40,10 +40,11 @@ import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
 import           Foreign.C.String
+import           Foreign.C.Error
 import           Foreign.C.Types
 import           GHC.IO.Exception
 import           System.IO                      ( stderr, hClose, hSetBinaryMode )
-import           System.IO.Error
+import           System.IO.Error      hiding    ( catchIOError )
 import           System.FilePath
 import           System.Posix.Directory
 import           System.Posix.Error             ( throwErrnoPathIfMinus1Retry )
@@ -559,6 +560,28 @@ install from to fail' = do
             | PF.isSymbolicLink fs    = recreateSymlink from to fail'
             | otherwise               = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
 
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile = rename
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable from to = do
+  catchErrno [eXDEV] (moveFile from to) $ do
+    copyFile from to True
+    removeFile from
+
+
+catchErrno :: [Errno] -- ^ errno to catch
+           -> IO a    -- ^ action to try, which can raise an IOException
+           -> IO a    -- ^ action to carry out in case of an IOException and
+                      --   if errno matches
+           -> IO a
+catchErrno en a1 a2 =
+  catchIOError a1 $ \e -> do
+    errno <- getErrno
+    if errno `elem` en
+      then a2
+      else ioError e
 
 removeEmptyDirectory :: FilePath -> IO ()
 removeEmptyDirectory = PD.removeDirectory

lib/GHCup/Utils/File/Windows.hs

@@ -293,8 +293,18 @@ copyFile = WS.copyFile
 deleteFile :: FilePath -> IO ()
 deleteFile = WS.deleteFile
 
+
 install :: FilePath -> FilePath -> Bool -> IO ()
-install = copyFile
+install = moveFile
+
+
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile from to = Win32.moveFileEx from (Just to) 0
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable = Win32.moveFile
+
 
 removeEmptyDirectory :: FilePath -> IO ()
 removeEmptyDirectory = WS.removeDirectory

lib/GHCup/Utils/Logger.hs

@@ -19,6 +19,7 @@ import           GHCup.Types
 import           GHCup.Types.Optics
 import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
 import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
+import {-# SOURCE #-} GHCup.Utils.File (recycleFile)
 import           GHCup.Utils.String.QQ
 
 import           Control.Exception.Safe

lib/GHCup/Utils/Prelude.hs

@@ -379,109 +379,6 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
   go (x : xs) | x == _period = [_backslash, _period] ++ go xs
               | otherwise    = x : go xs
 
--- | More permissive version of 'createDirRecursive'. This doesn't
--- error when the destination is a symlink to a directory.
-createDirRecursive' :: FilePath -> IO ()
-createDirRecursive' p =
-  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
-    . createDirectoryIfMissing True
-    $ p
-
- where
-  isSymlinkDir e = do
-    ft <- pathIsSymbolicLink p
-    case ft of
-      True -> do
-        rp <- canonicalizePath p
-        rft <- doesDirectoryExist rp
-        case rft of
-          True -> pure ()
-          _ -> throwIO e
-      _ -> throwIO e
-
-
--- https://github.com/haskell/directory/issues/110
--- https://github.com/haskell/directory/issues/96
--- https://www.sqlite.org/src/info/89f1848d7f
-recyclePathForcibly :: ( MonadIO m
-                       , MonadReader env m
-                       , HasDirs env
-                       , MonadMask m
-                       )
-                    => GHCupPath
-                    -> m ()
-recyclePathForcibly fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
-      let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
-      liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
-          `catch`
-          (\e -> if | isDoesNotExistError e -> pure ()
-                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
-                    | otherwise -> throwIO e)
-          `finally`
-            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removePathForcibly fp
-
-
-rmPathForcibly :: ( MonadIO m
-                  , MonadMask m
-                  )
-               => GHCupPath
-               -> m ()
-rmPathForcibly fp
-  | isWindows = recover (liftIO $ removePathForcibly fp)
-  | otherwise = liftIO $ removePathForcibly fp
-
-
-rmDirectory :: (MonadIO m, MonadMask m)
-            => GHCupPath
-            -> m ()
-rmDirectory fp
-  | isWindows = recover (liftIO $ removeDirectory fp)
-  | otherwise = liftIO $ removeDirectory fp
-
-
--- https://www.sqlite.org/src/info/89f1848d7f
--- https://github.com/haskell/directory/issues/96
-recycleFile :: ( MonadIO m
-               , MonadMask m
-               , MonadReader env m
-               , HasDirs env
-               )
-            => FilePath
-            -> m ()
-recycleFile fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
-      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
-      let dest = fromGHCupPath tmp </> takeFileName fp
-      liftIO (moveFile fp dest)
-        `catch`
-          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
-        `finally`
-          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmFile :: ( MonadIO m
-          , MonadMask m
-          )
-      => FilePath
-      -> m ()
-rmFile fp
-  | isWindows = recover (liftIO $ removeFile fp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-                => FilePath
-                -> m ()
-rmDirectoryLink fp
-  | isWindows = recover (liftIO $ removeDirectoryLink fp)
-  | otherwise = liftIO $ removeDirectoryLink fp
 
 
 recover :: (MonadIO m, MonadMask m) => m a -> m a

lib/GHCup/Utils/Prelude/Posix.hs

@@ -1,24 +1,8 @@
 module GHCup.Utils.Prelude.Posix where
 
-import           System.Directory hiding ( removeDirectory
-                                         , removeDirectoryRecursive
-                                         , removePathForcibly
-                                         , findFiles
-                                         )
-import System.Posix.Files
-
 
 isWindows, isNotWindows :: Bool
 isWindows = False
 isNotWindows = not isWindows
 
 
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile = rename
-
-
-moveFilePortable :: FilePath -> FilePath -> IO ()
-moveFilePortable from to = do
-  copyFile from to
-  removeFile from
-

lib/GHCup/Utils/Prelude/Windows.hs

@@ -1,17 +1,6 @@
 module GHCup.Utils.Prelude.Windows where
 
-import qualified System.Win32.File             as Win32
-
-
 isWindows, isNotWindows :: Bool
 isWindows = True
 isNotWindows = not isWindows
 
-
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile from to = Win32.moveFileEx from (Just to) 0
-
-
-moveFilePortable :: FilePath -> FilePath -> IO ()
-moveFilePortable = Win32.moveFile
-