Warn when /tmp doesn't have 2500 or more of disk space

ghcup.cabal

@@ -15,12 +15,13 @@ description:
 
 category:        System
 build-type:      Simple
-extra-doc-files: CHANGELOG.md
+extra-doc-files:
-                 README.md
+  CHANGELOG.md
-                 HACKING.md
+  config.yaml
-                 RELEASING.md
+  ghcup-0.0.4.yaml
-                 config.yaml
+  HACKING.md
-                 ghcup-0.0.4.yaml
+  README.md
+  RELEASING.md
 
 source-repository head
   type:     git
@@ -96,6 +97,7 @@ library
     , concurrent-output     ^>=1.10.11
     , containers            ^>=0.6
     , cryptohash-sha256     ^>=0.11.101.0
+    , disk-free-space       ^>=0.1.0.1
     , generics-sop          ^>=0.5
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  >=3.0        && <3.2
@@ -130,6 +132,7 @@ library
     , transformers          ^>=0.5
     , unix                  ^>=2.7
     , unix-bytestring       ^>=0.3
+    , unliftio-core         ^>=0.2.0.1
     , unordered-containers  ^>=0.2.10.0
     , uri-bytestring        ^>=0.3.2.2
     , utf8-string           ^>=1.0

lib/GHCup.hs

@@ -105,6 +105,7 @@ installGHCBindist :: ( MonadFail m
                      , MonadLogger m
                      , MonadResource m
                      , MonadIO m
+                     , MonadUnliftIO m
                      )
                   => DownloadInfo    -- ^ where/how to download
                   -> Version         -- ^ the version to install
@@ -160,6 +161,7 @@ installPackedGHC :: ( MonadMask m
                     , MonadThrow m
                     , MonadLogger m
                     , MonadIO m
+                    , MonadUnliftIO m
                     )
                  => Path Abs          -- ^ Path to the packed GHC bindist
                  -> Maybe TarDir      -- ^ Subdir of the archive
@@ -232,6 +234,7 @@ installGHCBin :: ( MonadFail m
                  , MonadLogger m
                  , MonadResource m
                  , MonadIO m
+                 , MonadUnliftIO m
                  )
               => GHCupDownloads  -- ^ the download info to look up the tarball from
               -> Version         -- ^ the version to install
@@ -264,6 +267,7 @@ installCabalBindist :: ( MonadMask m
                        , MonadLogger m
                        , MonadResource m
                        , MonadIO m
+                       , MonadUnliftIO m
                        , MonadFail m
                        )
                     => DownloadInfo
@@ -344,6 +348,7 @@ installCabalBin :: ( MonadMask m
                    , MonadLogger m
                    , MonadResource m
                    , MonadIO m
+                   , MonadUnliftIO m
                    , MonadFail m
                    )
                 => GHCupDownloads
@@ -377,6 +382,7 @@ installHLSBindist :: ( MonadMask m
                      , MonadLogger m
                      , MonadResource m
                      , MonadIO m
+                     , MonadUnliftIO m
                      , MonadFail m
                      )
                   => DownloadInfo
@@ -466,6 +472,7 @@ installHLSBin :: ( MonadMask m
                  , MonadLogger m
                  , MonadResource m
                  , MonadIO m
+                 , MonadUnliftIO m
                  , MonadFail m
                  )
               => GHCupDownloads
@@ -1064,6 +1071,7 @@ compileGHC :: ( MonadMask m
               , MonadResource m
               , MonadLogger m
               , MonadIO m
+              , MonadUnliftIO m
               , MonadFail m
               )
            => GHCupDownloads
@@ -1299,6 +1307,7 @@ upgradeGHCup :: ( MonadMask m
                 , MonadThrow m
                 , MonadResource m
                 , MonadIO m
+                , MonadUnliftIO m
                 )
              => GHCupDownloads
              -> Maybe (Path Abs)  -- ^ full file destination to write ghcup into

lib/GHCup/Download.hs

@@ -400,6 +400,7 @@ downloadCached :: ( MonadMask m
                   , MonadThrow m
                   , MonadLogger m
                   , MonadIO m
+                  , MonadUnliftIO m
                   , MonadReader AppState m
                   )
                => DownloadInfo

lib/GHCup/Utils/Dirs.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE TemplateHaskell       #-}
 
 {-|
 Module      : GHCup.Utils.Dirs
@@ -36,11 +37,14 @@ import           GHCup.Utils.Prelude
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.IO.Unlift
+import           Control.Monad.Logger
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Resource
+import           Control.Monad.Trans.Resource hiding (throwM)
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import           Data.Maybe
+import           Data.String.Interpolate
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
 import           HPath
@@ -50,6 +54,7 @@ import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
+import           System.DiskSpace                                                
 import           System.Posix.Env.ByteString    ( getEnv
                                                 , getEnvDefault
                                                 )
@@ -58,11 +63,13 @@ import           System.Posix.Temp.ByteString   ( mkdtemp )
 
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml                     as Y
 import qualified System.Posix.FilePath         as FP
 import qualified System.Posix.User             as PU
 import qualified Text.Megaparsec               as MP
+import Control.Concurrent (threadDelay)
 
 
 
@@ -226,15 +233,31 @@ parseGHCupGHCDir (toFilePath -> f) = do
   throwEither $ MP.parse ghcTargetVerP "" fp
 
 
-mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
+mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
 mkGhcupTmpDir = do
   tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
-  tmp    <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
+  let fp = T.unpack $ decUTF8Safe tmpdir
+
+  let minSpace = 2500 -- a rough guess, aight?
+  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
+  when (maybe False (toBytes minSpace >) space) $ do
+    $(logWarn) [i|Insufficient disk space on #{fp}. Need at least #{minSpace} MB, 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
+
+  tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
   parseAbs tmp
+ where
+  toBytes mb = mb * 1024 * 1024
+  toMB b = 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 :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
+withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
-withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
+withGHCupTmpDir = snd <$> (withRunInIO $ \run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
 
 
 
@@ -270,5 +293,3 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
         <> joinPath ("/" : drop (length common) d2)
 
 
-
-