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
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 47 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
ghcup.cabal
View File

@ -15,12 +15,13 @@ description:
category: System
build-type: Simple
extra-doc-files: CHANGELOG.md
README.md
HACKING.md
RELEASING.md
config.yaml
ghcup-0.0.4.yaml
extra-doc-files:
CHANGELOG.md
config.yaml
ghcup-0.0.4.yaml
HACKING.md
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

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)