Only query directories once
This commit is contained in:
parent
122c54b51e
commit
7163b77837
@ -158,14 +158,25 @@ data URLSource = GHCupURL
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
{ -- * set by user
|
||||
cache :: Bool
|
||||
, noVerify :: Bool
|
||||
, keepDirs :: KeepDirs
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
|
||||
-- * set on app start
|
||||
, dirs :: Dirs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: Path Abs
|
||||
, binDir :: Path Abs
|
||||
, cacheDir :: Path Abs
|
||||
, logsDir :: Path Abs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data KeepDirs = Always
|
||||
| Errors
|
||||
|
@ -576,24 +576,18 @@ runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
Settings {..} <- lift ask
|
||||
v <- flip
|
||||
onException
|
||||
(do
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteDirRecursive bdir
|
||||
)
|
||||
v <-
|
||||
flip onException exAction
|
||||
$ catchAllE
|
||||
(\es -> do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteDirRecursive bdir
|
||||
exAction
|
||||
throwE (BuildFailed bdir es)
|
||||
)
|
||||
$ action
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
@ -11,7 +12,16 @@ Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Utils.Dirs where
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
, ghcupGHCBaseDir
|
||||
, ghcupGHCDir
|
||||
, parseGHCupGHCDir
|
||||
, mkGhcupTmpDir
|
||||
, withGHCupTmpDir
|
||||
, relativeSymlink
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
@ -47,9 +57,9 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ GHCup directories ]--
|
||||
-------------------------
|
||||
------------------------------
|
||||
--[ GHCup base directories ]--
|
||||
------------------------------
|
||||
|
||||
|
||||
-- | ~/.ghcup by default
|
||||
@ -74,29 +84,6 @@ ghcupBaseDir = do
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
|
||||
|
||||
|
||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||
-- The dir may be of the form
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | See 'ghcupToolParser'.
|
||||
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (toFilePath -> f) = do
|
||||
fp <- throwEither $ E.decodeUtf8' f
|
||||
throwEither $ MP.parse ghcTargetVerP "" fp
|
||||
|
||||
|
||||
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
|
||||
-- (which, sadly is not strictly xdg spec).
|
||||
@ -112,6 +99,7 @@ ghcupBinDir = do
|
||||
pure (home </> [rel|.local/bin|])
|
||||
else ghcupBaseDir <&> (</> [rel|bin|])
|
||||
|
||||
|
||||
-- | Defaults to '~/.ghcup/cache'.
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
@ -129,6 +117,7 @@ ghcupCacheDir = do
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else ghcupBaseDir <&> (</> [rel|cache|])
|
||||
|
||||
|
||||
-- | Defaults to '~/.ghcup/logs'.
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
@ -147,6 +136,49 @@ ghcupLogsDir = do
|
||||
else ghcupBaseDir <&> (</> [rel|logs|])
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
getDirs = do
|
||||
baseDir <- ghcupBaseDir
|
||||
binDir <- ghcupBinDir
|
||||
cacheDir <- ghcupCacheDir
|
||||
logsDir <- ghcupLogsDir
|
||||
pure Dirs { .. }
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ GHCup directories ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs)
|
||||
ghcupGHCBaseDir = do
|
||||
Settings {..} <- ask
|
||||
pure (baseDir dirs </> [rel|ghc|])
|
||||
|
||||
|
||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||
-- The dir may be of the form
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: (MonadReader Settings m, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
Settings {..} <- ask
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | See 'ghcupToolParser'.
|
||||
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (toFilePath -> f) = do
|
||||
fp <- throwEither $ E.decodeUtf8' f
|
||||
throwEither $ MP.parse ghcTargetVerP "" fp
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
@ -158,6 +190,8 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
@ -191,4 +225,3 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
||||
|
||||
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user