hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Browse Source
This commit is contained in:
Julian Ospald
2021-04-25 17:22:07 +02:00
parent b645c4d57e
commit 7d13836fea
4 changed files with 47 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
lib/GHCup.hs
View File

@@ -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

1
lib/GHCup/Download.hs
View File

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

35
lib/GHCup/Utils/Dirs.hs
View File

@@ -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 = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> (withRunInIO $ \run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
@@ -270,5 +293,3 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
<> joinPath ("/" : drop (length common) d2)