diff --git a/ghcup.cabal b/ghcup.cabal index b27455c..73c479d 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index df61f08..b9936ca 100644 --- a/lib/GHCup.hs +++ b/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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 42d0be4..0b075b0 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -400,6 +400,7 @@ downloadCached :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m + , MonadUnliftIO m , MonadReader AppState m ) => DownloadInfo diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index cfb4542..ac34408 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/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 = 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) - -