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

Use Settings to avoid querying dirs every time

Browse Source
This commit is contained in:
Julian Ospald 2020-08-05 21:50:39 +02:00
parent 7163b77837
commit cafedd73a2
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
9 changed files with 140 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/ghcup-gen/Validate.hs
View File

@ -7,6 +7,7 @@ module Validate where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Types import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.Logger import GHCup.Utils.Logger
import Control.Exception.Safe import Control.Exception.Safe
@ -180,7 +181,8 @@ validateTarballs dls = do
where where
downloadAll dli = do downloadAll dli = do
let settings = Settings True False Never Curl False dirs <- liftIO getDirs
let settings = Settings True False Never Curl False dirs
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ()) , rawOutter = (\_ -> pure ())

7
app/ghcup/BrickMain.hs
View File

@ -297,14 +297,15 @@ uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings settings' :: IORef Settings
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO settings' = unsafePerformIO $ do
(newIORef Settings { cache = True dirs <- getDirs
newIORef Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, ..
} }
)
logger' :: IORef LoggerConfig logger' :: IORef LoggerConfig

28
app/ghcup/Main.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@ -818,14 +819,15 @@ bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString bindistParser = eitherDecode . BLU.fromString
toSettings :: Options -> Settings toSettings :: Options -> IO Settings
toSettings Options {..} = toSettings Options {..} = do
let cache = optCache let cache = optCache
noVerify = optNoVerify noVerify = optNoVerify
keepDirs = optKeepDirs keepDirs = optKeepDirs
downloader = optsDownloader downloader = optsDownloader
verbose = optVerbose verbose = optVerbose
in Settings { .. } dirs <- getDirs
pure $ Settings { .. }
upgradeOptsP :: Parser UpgradeOpts upgradeOptsP :: Parser UpgradeOpts
@ -901,16 +903,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer)) (footerDoc (Just $ text main_footer))
) )
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
let settings@Settings{..} = toSettings opt settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
logsDir <- toFilePath <$> ghcupLogsDir
-- create ~/.ghcup dir -- create ~/.ghcup dir
ghcdir <- ghcupBaseDir createDirRecursive newDirPerms baseDir
createDirRecursive newDirPerms ghcdir
-- logger interpreter -- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|] logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose { lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
@ -956,12 +955,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetCabal = runSetCabal =
runLogger runLogger
. flip runReaderT settings
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
] ]
let runListGHC = runLogger let runListGHC = runLogger . flip runReaderT settings
let runRm = let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT settings . runE @'[NotInstalled]
@ -1054,7 +1054,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case optCommand of case optCommand of
Upgrade _ _ -> pure () Upgrade _ _ -> pure ()
_ -> runLogger $ checkForUpdates dls pfreq _ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq
@ -1277,9 +1277,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
p <- parseAbs . E.encodeUtf8 . T.pack $ efp p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p pure $ Just p
(UpgradeAt p) -> pure $ Just p (UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do VRight v' -> do
@ -1431,7 +1429,7 @@ printListResult raw lr = do
True -> flip const True -> flip const
False -> color False -> color
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads => GHCupDownloads
-> PlatformRequest -> PlatformRequest
-> m () -> m ()

119
lib/GHCup.hs
View File

@ -121,7 +121,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver (PlatformRequest {..}) = do installGHCBindist dlinfo ver (PlatformRequest {..}) = do
let tver = (mkTVer ver) let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ ghcInstalled tver) whenM (lift $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver) $ (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version) -- download (or use cached version)
@ -133,7 +133,7 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths -- prepare paths
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo) let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
@ -230,14 +230,14 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
whenM whenM
(liftIO $ cabalInstalled ver >>= \a -> (lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False) handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x) $ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink) -- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|])) $ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
) )
$ (throwE $ AlreadyInstalled Cabal ver) $ (throwE $ AlreadyInstalled Cabal ver)
@ -252,10 +252,10 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo) let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
liftE $ installCabal' workdir bindir liftE $ installCabal' workdir binDir
-- create symlink if this is the latest version -- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
@ -328,17 +328,17 @@ installCabalBin bDls ver pfreq = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) setGHC :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> SetGHC -> SetGHC
-> Excepts '[NotInstalled] m GHCTargetVersion -> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver) let verBS = verToBS (_tvVersion ver)
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
-- symlink destination -- symlink destination
bindir <- liftIO $ ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup) -- with old ghcup)
@ -359,8 +359,8 @@ setGHC ver sghc = do
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-- create symlink -- create symlink
let fullF = bindir </> targetFile let fullF = binDir </> targetFile
destL <- ghcLinkDestination (toFilePath file) ver destL <- lift $ ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|] lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL liftIO $ createSymlink fullF destL
@ -371,12 +371,13 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadIO m, MonadLogger m) symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m)
=> Path Abs => Path Abs
-> ByteString -> ByteString
-> m () -> m ()
symlinkShareDir ghcdir verBS = do symlinkShareDir ghcdir verBS = do
destdir <- liftIO $ ghcupBaseDir Settings {dirs = Dirs {..}} <- ask
let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
let sharedir = [rel|share|] let sharedir = [rel|share|]
@ -393,7 +394,7 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setCabal ver = do setCabal ver = do
@ -401,14 +402,14 @@ setCabal ver = do
targetFile <- parseRel ("cabal-" <> verBS) targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination -- symlink destination
bindir <- liftIO $ ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile)) whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE $ throwE
$ NotInstalled Cabal (prettyVer ver) $ NotInstalled Cabal (prettyVer ver)
let cabalbin = bindir </> [rel|cabal|] let cabalbin = binDir </> [rel|cabal|]
-- delete old file (may be binary or symlink) -- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|] lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
@ -467,6 +468,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m
) )
=> GHCupDownloads => GHCupDownloads
-> Maybe Tool -> Maybe Tool
@ -478,7 +480,7 @@ listVersions av lt criteria pfreq = do
Just t -> do Just t -> do
-- get versions from GHCupDownloads -- get versions from GHCupDownloads
let avTools = availableToolVersions av t let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t) lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of case t of
-- append stray GHCs -- append stray GHCs
@ -493,7 +495,7 @@ listVersions av lt criteria pfreq = do
pure (ghcvers <> cabalvers <> ghcupvers) pure (ghcvers <> cabalvers <> ghcupvers)
where where
strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m) strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -504,7 +506,7 @@ listVersions av lt criteria pfreq = do
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- liftIO $ ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
@ -517,7 +519,7 @@ listVersions av lt criteria pfreq = do
} }
Right tver@GHCTargetVersion{ .. } -> do Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- liftIO $ ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
@ -534,7 +536,7 @@ listVersions av lt criteria pfreq = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of toListResult t (v, tags) = case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
@ -587,12 +589,12 @@ listVersions av lt criteria pfreq = do
-- This may leave GHCup without a "set" version. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- older version).
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m) rmGHCVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmGHCVer ver = do rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
dir <- liftIO $ ghcupGHCDir ver dir <- lift $ ghcupGHCDir ver
let d' = toFilePath dir let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
@ -615,36 +617,38 @@ rmGHCVer ver = do
lift $ rmMajorSymlinks ver lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version) -- then fix them (e.g. with an earlier version)
(mj, mi) <- getMajorMinorV (_tvVersion ver) (mj, mi) <- getMajorMinorV (_tvVersion ver)
getGHCForMajor mj mi (_tvTarget ver) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
Settings {dirs = Dirs {..}} <- lift ask
liftIO liftIO
$ ghcupBaseDir $ hideError doesNotExistErrorType
>>= hideError doesNotExistErrorType $ deleteFile
. deleteFile $ (baseDir </> [rel|share|])
. (</> [rel|share|])
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)) else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m) rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmCabalVer ver = do rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver)) whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver))
cSet <- liftIO cabalSet cSet <- lift $ cabalSet
Settings {dirs = Dirs {..}} <- lift ask
bindir <- liftIO ghcupBinDir
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
when (maybe False (== ver) cSet) $ do when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> [rel|cabal|]) (binDir </> [rel|cabal|])
@ -653,18 +657,19 @@ rmCabalVer ver = do
------------------ ------------------
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m) getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
diBaseDir <- liftIO $ ghcupBaseDir Settings {dirs = Dirs {..}} <- lift ask
diBinDir <- liftIO $ ghcupBinDir let diBaseDir = baseDir
diGHCDir <- liftIO $ ghcupGHCBaseDir let diBinDir = binDir
diCacheDir <- liftIO $ ghcupCacheDir diGHCDir <- lift ghcupGHCBaseDir
diArch <- lE getArchitecture let diCacheDir = cacheDir
diPlatform <- liftE $ getPlatform diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
pure $ DebugInfo { .. } pure $ DebugInfo { .. }
@ -711,7 +716,7 @@ compileGHC :: ( MonadMask m
() ()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver) whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
-- download source tarball -- download source tarball
@ -729,7 +734,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
Right g -> pure $ Right g Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction liftE $ runBuildAction
tmpUnpack tmpUnpack
@ -892,14 +897,14 @@ compileCabal :: ( MonadReader Settings m
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
whenM whenM
(liftIO $ cabalInstalled tver >>= \a -> (lift (cabalInstalled tver) >>= \a -> liftIO $
handleIO (\_ -> pure False) handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x) $ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink) -- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|])) $ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
) )
$ (throwE $ AlreadyInstalled Cabal tver) $ (throwE $ AlreadyInstalled Cabal tver)
@ -919,11 +924,11 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver) destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin cbin
(bindir </> destFileName) (binDir </> destFileName)
Overwrite Overwrite
-- create symlink if this is the latest version -- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
@ -1004,6 +1009,7 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup dls mtarget force pfreq = do upgradeGHCup dls mtarget force pfreq = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
@ -1016,7 +1022,6 @@ upgradeGHCup dls mtarget force pfreq = do
`unionFileModes` ownerExecuteMode `unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode `unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode `unionFileModes` otherExecuteMode
binDir <- liftIO $ ghcupBinDir
let fullDest = fromMaybe (binDir </> fn) mtarget let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
@ -1034,7 +1039,7 @@ upgradeGHCup dls mtarget force pfreq = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) postGHCInstall :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion{..} = do postGHCInstall ver@GHCTargetVersion{..} = do
@ -1043,4 +1048,4 @@ postGHCInstall ver@GHCTargetVersion{..} = do
-- Create ghc-x.y symlinks. This may not be the current -- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless. -- version, create it regardless.
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
getGHCForMajor mj mi _tvTarget >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) lift (getGHCForMajor mj mi _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

10
lib/GHCup/Download.hs
View File

@ -133,10 +133,10 @@ getDownloadsF urlSource = do
(OwnSpec _) -> liftE $ getDownloads urlSource (OwnSpec _) -> liftE $ getDownloads urlSource
where where
readFromCache = do readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn) lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|] [i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL let path = view pathL' ghcupURL
cacheDir <- liftIO $ ghcupCacheDir
yaml_file <- (cacheDir </>) <$> urlBaseName path yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <- bs <-
handleIO' NoSuchThing handleIO' NoSuchThing
@ -200,8 +200,8 @@ getDownloads urlSource = do
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri' let path = view pathL' uri'
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
if e if e
@ -392,15 +392,15 @@ downloadCached dli mfn = do
cache <- lift getCache cache <- lift getCache
case cache of case cache of
True -> do True -> do
cachedir <- liftIO $ ghcupCacheDir Settings {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cachedir </> fn let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> do | fileExists -> do
liftE $ checkDigest dli cachfile liftE $ checkDigest dli cachfile
pure $ cachfile pure $ cachfile
| otherwise -> liftE $ download dli cachedir mfn | otherwise -> liftE $ download dli cacheDir mfn
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn liftE $ download dli tmp mfn

4
lib/GHCup/Types.hs
View File

@ -158,14 +158,14 @@ data URLSource = GHCupURL
data Settings = Settings data Settings = Settings
{ -- * set by user { -- set by user
cache :: Bool cache :: Bool
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
-- * set on app start -- set on app start
, dirs :: Dirs , dirs :: Dirs
} }
deriving Show deriving Show

72
lib/GHCup/Utils.hs
View File

@ -97,24 +97,24 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool. -- | The symlink destination of a ghc tool.
ghcLinkDestination :: (MonadThrow m, MonadIO m) ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc. => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion -> GHCTargetVersion
-> m ByteString -> m ByteString
ghcLinkDestination tool ver = do ghcLinkDestination tool ver = do
Settings {dirs = Dirs {..}} <- ask
t <- parseRel tool t <- parseRel tool
bin <- liftIO ghcupBinDir ghcd <- ghcupGHCDir ver
ghcd <- liftIO $ ghcupGHCDir ver pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
pure (relativeSymlink bin (ghcd </> [rel|bin|] </> t))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do rmMinorSymlinks GHCTargetVersion {..} = do
bindir <- liftIO $ ghcupBinDir Settings {dirs = Dirs {..}} <- ask
files <- liftIO $ findFiles' files <- liftIO $ findFiles'
bindir binDir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget ( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion) *> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
*> (MP.chunk $ prettyVer _tvVersion) *> (MP.chunk $ prettyVer _tvVersion)
@ -122,42 +122,41 @@ rmMinorSymlinks GHCTargetVersion {..} = do
) )
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (bindir </> f) let fullF = (binDir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|] $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- | Removes the set ghc version for the given target, if any. -- | Removes the set ghc version for the given target, if any.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Maybe Text -- ^ target => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
mtv <- ghcSet target Settings {dirs = Dirs {..}} <- lift ask
mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (bindir </> f) let fullF = (binDir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup -- old ghcup
let hdc_file = (bindir </> [rel|haddock-ghc|]) let hdc_file = (binDir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|] lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m) rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> m () -> m ()
rmMajorSymlinks GHCTargetVersion {..} = do rmMajorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ findFiles' files <- liftIO $ findFiles'
bindir binDir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget ( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v') *> parseUntil1 (MP.chunk v')
*> MP.chunk v' *> MP.chunk v'
@ -165,7 +164,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do
) )
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (bindir </> f) let fullF = (binDir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|] $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@ -178,27 +177,28 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-- | Whethe the given GHC versin is installed. -- | Whethe the given GHC versin is installed.
ghcInstalled :: GHCTargetVersion -> IO Bool ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: GHCTargetVersion -> IO Bool ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
ghcSet :: (MonadThrow m, MonadIO m) ghcSet :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
ghcSet mtarget = do ghcSet mtarget = do
Settings {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
ghcBin <- (</> ghc) <$> liftIO ghcupBinDir let ghcBin = binDir </> ghc
-- link destination is of the form ../ghc/<ver>/bin/ghc -- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver> -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
@ -229,9 +229,9 @@ ghcLinkVersion bs = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- If a dir cannot be parsed, returns left.
getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion] getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs = do getInstalledGHCs = do
ghcdir <- liftIO $ ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r Right r -> pure $ Right r
@ -239,11 +239,12 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: IO [Either (Path Rel) Version] getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals = do getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir Settings {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
bindir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
@ -254,16 +255,17 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
cabalInstalled :: Version -> IO Bool cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers pure $ elem ver $ vers
-- Return the currently set cabal version, if any. -- Return the currently set cabal version, if any.
cabalSet :: (MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir Settings {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if if
| b -> do | b -> do
@ -319,7 +321,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
-- | Get the latest installed full GHC version that satisfies X.Y. -- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`. -- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadIO m, MonadThrow m) getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> Int -- ^ major version component => Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple -> Maybe Text -- ^ the target triple
@ -463,11 +465,11 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Returns unversioned relative files, e.g.: -- Returns unversioned relative files, e.g.:
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|] let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed -- fail if ghc is not installed

6
lib/GHCup/Utils/File.hs
View File

@ -17,7 +17,6 @@ Some of these functions use sophisticated logging.
-} -}
module GHCup.Utils.File where module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types import GHCup.Types
@ -123,9 +122,8 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
-> Maybe [(ByteString, ByteString)] -- ^ optional environment -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
Settings {..} <- ask Settings {dirs = Dirs {..}, ..} <- ask
ldir <- liftIO ghcupLogsDir logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd closeFd
(action verbose) (action verbose)

20
lib/GHCup/Utils/Logger.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-| {-|
Module : GHCup.Utils.Logger Module : GHCup.Utils.Logger
@ -13,9 +14,11 @@ Here we define our main logger.
-} -}
module GHCup.Utils.Logger where module GHCup.Utils.Logger where
import GHCup.Utils import GHCup.Types
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger import Control.Monad.Logger
import HPath import HPath
import HPath.IO import HPath.IO
@ -61,11 +64,12 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr rawOutter outr
initGHCupFileLogging :: Path Rel -> IO (Path Abs) initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs)
initGHCupFileLogging context = do initGHCupFileLogging context = do
logs <- ghcupLogsDir Settings {dirs = Dirs {..}} <- ask
let logfile = logs </> context let logfile = logsDir </> context
createDirRecursive newDirPerms logs liftIO $ do
hideError doesNotExistErrorType $ deleteFile logfile createDirRecursive newDirPerms logsDir
createRegularFile newFilePerms logfile hideError doesNotExistErrorType $ deleteFile logfile
pure logfile createRegularFile newFilePerms logfile
pure logfile