Use Settings to avoid querying dirs every time
This commit is contained in:
parent
7163b77837
commit
cafedd73a2
@ -7,6 +7,7 @@ module Validate where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
import Control.Exception.Safe
|
||||
@ -180,7 +181,8 @@ validateTarballs dls = do
|
||||
|
||||
where
|
||||
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
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
|
||||
@ -297,14 +297,15 @@ uri' = unsafePerformIO (newIORef Nothing)
|
||||
|
||||
settings' :: IORef Settings
|
||||
{-# NOINLINE settings' #-}
|
||||
settings' = unsafePerformIO
|
||||
(newIORef Settings { cache = True
|
||||
settings' = unsafePerformIO $ do
|
||||
dirs <- getDirs
|
||||
newIORef Settings { cache = True
|
||||
, noVerify = False
|
||||
, keepDirs = Never
|
||||
, downloader = Curl
|
||||
, verbose = False
|
||||
, ..
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
logger' :: IORef LoggerConfig
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@ -818,14 +819,15 @@ bindistParser :: String -> Either String DownloadInfo
|
||||
bindistParser = eitherDecode . BLU.fromString
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
toSettings :: Options -> IO Settings
|
||||
toSettings Options {..} = do
|
||||
let cache = optCache
|
||||
noVerify = optNoVerify
|
||||
keepDirs = optKeepDirs
|
||||
downloader = optsDownloader
|
||||
verbose = optVerbose
|
||||
in Settings { .. }
|
||||
dirs <- getDirs
|
||||
pure $ Settings { .. }
|
||||
|
||||
|
||||
upgradeOptsP :: Parser UpgradeOpts
|
||||
@ -901,16 +903,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(footerDoc (Just $ text main_footer))
|
||||
)
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings@Settings{..} = toSettings opt
|
||||
|
||||
logsDir <- toFilePath <$> ghcupLogsDir
|
||||
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
|
||||
|
||||
-- create ~/.ghcup dir
|
||||
ghcdir <- ghcupBaseDir
|
||||
createDirRecursive newDirPerms ghcdir
|
||||
createDirRecursive newDirPerms baseDir
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging [rel|ghcup.log|]
|
||||
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = optVerbose
|
||||
, colorOutter = B.hPut stderr
|
||||
@ -956,12 +955,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let
|
||||
runSetCabal =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let runListGHC = runLogger
|
||||
let runListGHC = runLogger . flip runReaderT settings
|
||||
|
||||
let runRm =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
@ -1054,7 +1054,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
case optCommand of
|
||||
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
|
||||
pure $ Just p
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> do
|
||||
bdir <- liftIO $ ghcupBinDir
|
||||
pure (Just (bdir </> [rel|ghcup|]))
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
|
||||
|
||||
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
|
||||
VRight v' -> do
|
||||
@ -1431,7 +1429,7 @@ printListResult raw lr = do
|
||||
True -> flip const
|
||||
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
|
||||
-> PlatformRequest
|
||||
-> m ()
|
||||
|
||||
119
lib/GHCup.hs
119
lib/GHCup.hs
@ -121,7 +121,7 @@ installGHCBindist :: ( MonadFail m
|
||||
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
let tver = (mkTVer ver)
|
||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||
whenM (liftIO $ ghcInstalled tver)
|
||||
whenM (lift $ ghcInstalled tver)
|
||||
$ (throwE $ AlreadyInstalled GHC ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
@ -133,7 +133,7 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
ghcdir <- lift $ ghcupGHCDir tver
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
@ -230,14 +230,14 @@ installCabalBindist :: ( MonadMask m
|
||||
installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
whenM
|
||||
(liftIO $ cabalInstalled ver >>= \a ->
|
||||
(lift (cabalInstalled ver) >>= \a -> liftIO $
|
||||
handleIO (\_ -> pure False)
|
||||
$ fmap (\x -> a && isSymbolicLink x)
|
||||
-- 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)
|
||||
|
||||
@ -252,10 +252,10 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
-- the subdir of the archive where we do the work
|
||||
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installCabal' workdir bindir
|
||||
liftE $ installCabal' workdir binDir
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
cVers <- liftIO $ fmap rights $ getInstalledCabals
|
||||
cVers <- lift $ fmap rights $ getInstalledCabals
|
||||
let lInstCabal = headMay . reverse . sort $ cVers
|
||||
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@
|
||||
-- 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
|
||||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m GHCTargetVersion
|
||||
setGHC ver sghc = do
|
||||
let verBS = verToBS (_tvVersion ver)
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
|
||||
-- symlink destination
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
|
||||
|
||||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
@ -359,8 +359,8 @@ setGHC ver sghc = do
|
||||
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
|
||||
-- create symlink
|
||||
let fullF = bindir </> targetFile
|
||||
destL <- ghcLinkDestination (toFilePath file) ver
|
||||
let fullF = binDir </> targetFile
|
||||
destL <- lift $ ghcLinkDestination (toFilePath file) ver
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
|
||||
liftIO $ createSymlink fullF destL
|
||||
|
||||
@ -371,12 +371,13 @@ setGHC ver sghc = do
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadIO m, MonadLogger m)
|
||||
symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m)
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
destdir <- liftIO $ ghcupBaseDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let destdir = baseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|]
|
||||
@ -393,7 +394,7 @@ setGHC ver sghc = do
|
||||
|
||||
|
||||
-- | 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
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setCabal ver = do
|
||||
@ -401,14 +402,14 @@ setCabal ver = do
|
||||
targetFile <- parseRel ("cabal-" <> verBS)
|
||||
|
||||
-- symlink destination
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
|
||||
|
||||
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile))
|
||||
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Cabal (prettyVer ver)
|
||||
|
||||
let cabalbin = bindir </> [rel|cabal|]
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
|
||||
-- delete old file (may be binary or symlink)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
|
||||
@ -467,6 +468,7 @@ listVersions :: ( MonadCatch m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Maybe Tool
|
||||
@ -478,7 +480,7 @@ listVersions av lt criteria pfreq = do
|
||||
Just t -> do
|
||||
-- get versions from GHCupDownloads
|
||||
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
|
||||
-- append stray GHCs
|
||||
@ -493,7 +495,7 @@ listVersions av lt criteria pfreq = do
|
||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||
|
||||
where
|
||||
strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m)
|
||||
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayGHCs avTools = do
|
||||
@ -504,7 +506,7 @@ listVersions av lt criteria pfreq = do
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
|
||||
fromSrc <- liftIO $ ghcSrcInstalled tver
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
@ -517,7 +519,7 @@ listVersions av lt criteria pfreq = do
|
||||
}
|
||||
Right tver@GHCTargetVersion{ .. } -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
|
||||
fromSrc <- liftIO $ ghcSrcInstalled tver
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
@ -534,7 +536,7 @@ listVersions av lt criteria pfreq = do
|
||||
pure Nothing
|
||||
|
||||
-- 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
|
||||
GHC -> do
|
||||
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.
|
||||
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
|
||||
-- older version).
|
||||
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||
rmGHCVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmGHCVer ver = do
|
||||
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
|
||||
dir <- liftIO $ ghcupGHCDir ver
|
||||
isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
|
||||
dir <- lift $ ghcupGHCDir ver
|
||||
let d' = toFilePath dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
|
||||
@ -615,36 +617,38 @@ rmGHCVer ver = do
|
||||
lift $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
(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
|
||||
$ ghcupBaseDir
|
||||
>>= hideError doesNotExistErrorType
|
||||
. deleteFile
|
||||
. (</> [rel|share|])
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteFile
|
||||
$ (baseDir </> [rel|share|])
|
||||
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
|
||||
|
||||
|
||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||
-- 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
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
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)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
|
||||
|
||||
when (maybe False (== ver) cSet) $ do
|
||||
cVers <- liftIO $ fmap rights $ getInstalledCabals
|
||||
cVers <- lift $ fmap rights $ getInstalledCabals
|
||||
case headMay . reverse . sort $ cVers of
|
||||
Just latestver -> setCabal latestver
|
||||
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
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
let diBaseDir = baseDir
|
||||
let diBinDir = binDir
|
||||
diGHCDir <- lift ghcupGHCBaseDir
|
||||
let diCacheDir = cacheDir
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
@ -711,7 +716,7 @@ compileGHC :: ( MonadMask m
|
||||
()
|
||||
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
||||
whenM (liftIO $ ghcInstalled tver)
|
||||
whenM (lift $ ghcInstalled tver)
|
||||
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
|
||||
|
||||
-- download source tarball
|
||||
@ -729,7 +734,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
|
||||
Right g -> pure $ Right g
|
||||
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
ghcdir <- lift $ ghcupGHCDir tver
|
||||
|
||||
liftE $ runBuildAction
|
||||
tmpUnpack
|
||||
@ -892,14 +897,14 @@ compileCabal :: ( MonadReader Settings m
|
||||
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
whenM
|
||||
(liftIO $ cabalInstalled tver >>= \a ->
|
||||
(lift (cabalInstalled tver) >>= \a -> liftIO $
|
||||
handleIO (\_ -> pure False)
|
||||
$ fmap (\x -> a && isSymbolicLink x)
|
||||
-- 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)
|
||||
|
||||
@ -919,11 +924,11 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
||||
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
cbin
|
||||
(bindir </> destFileName)
|
||||
(binDir </> destFileName)
|
||||
Overwrite
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
cVers <- liftIO $ fmap rights $ getInstalledCabals
|
||||
cVers <- lift $ fmap rights $ getInstalledCabals
|
||||
let lInstCabal = headMay . reverse . sort $ cVers
|
||||
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
|
||||
|
||||
@ -1004,6 +1009,7 @@ upgradeGHCup :: ( MonadMask m
|
||||
m
|
||||
Version
|
||||
upgradeGHCup dls mtarget force pfreq = do
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
||||
let latestVer = fromJust $ getLatest dls GHCup
|
||||
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
||||
@ -1016,7 +1022,6 @@ upgradeGHCup dls mtarget force pfreq = do
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
binDir <- liftIO $ ghcupBinDir
|
||||
let fullDest = fromMaybe (binDir </> fn) mtarget
|
||||
liftIO $ hideError NoSuchThing $ deleteFile fullDest
|
||||
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
|
||||
-- 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
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
postGHCInstall ver@GHCTargetVersion{..} = do
|
||||
@ -1043,4 +1048,4 @@ postGHCInstall ver@GHCTargetVersion{..} = do
|
||||
-- Create ghc-x.y symlinks. This may not be the current
|
||||
-- version, create it regardless.
|
||||
(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)
|
||||
|
||||
@ -133,10 +133,10 @@ getDownloadsF urlSource = do
|
||||
(OwnSpec _) -> liftE $ getDownloads urlSource
|
||||
where
|
||||
readFromCache = do
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
cacheDir <- liftIO $ ghcupCacheDir
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
@ -200,8 +200,8 @@ getDownloads urlSource = do
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
let path = view pathL' uri'
|
||||
cacheDir <- liftIO $ ghcupCacheDir
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
@ -392,15 +392,15 @@ downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cachedir </> fn
|
||||
let cachfile = cacheDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure $ cachfile
|
||||
| otherwise -> liftE $ download dli cachedir mfn
|
||||
| otherwise -> liftE $ download dli cacheDir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
@ -158,14 +158,14 @@ data URLSource = GHCupURL
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ -- * set by user
|
||||
{ -- set by user
|
||||
cache :: Bool
|
||||
, noVerify :: Bool
|
||||
, keepDirs :: KeepDirs
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
|
||||
-- * set on app start
|
||||
-- set on app start
|
||||
, dirs :: Dirs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@ -97,24 +97,24 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
-- | 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.
|
||||
-> GHCTargetVersion
|
||||
-> m ByteString
|
||||
ghcLinkDestination tool ver = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
t <- parseRel tool
|
||||
bin <- liftIO ghcupBinDir
|
||||
ghcd <- liftIO $ ghcupGHCDir ver
|
||||
pure (relativeSymlink bin (ghcd </> [rel|bin|] </> t))
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
|
||||
|
||||
|
||||
-- | 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
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
bindir
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
|
||||
*> (MP.chunk $ prettyVer _tvVersion)
|
||||
@ -122,42 +122,41 @@ rmMinorSymlinks GHCTargetVersion {..} = do
|
||||
)
|
||||
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
-- | 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
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain target = do
|
||||
mtv <- ghcSet target
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
mtv <- lift $ ghcSet target
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = (bindir </> [rel|haddock-ghc|])
|
||||
let hdc_file = (binDir </> [rel|haddock-ghc|])
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
|
||||
-- | 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
|
||||
-> m ()
|
||||
rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
bindir
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk v')
|
||||
*> MP.chunk v'
|
||||
@ -165,7 +164,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
)
|
||||
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
@ -178,27 +177,28 @@ rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
|
||||
|
||||
-- | 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
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
liftIO $ doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
-- | 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
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
-- | 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
|
||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
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
|
||||
-- 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>.
|
||||
-- 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
|
||||
ghcdir <- liftIO $ ghcupGHCBaseDir
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
|
||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
||||
Right r -> pure $ Right r
|
||||
@ -239,11 +239,12 @@ getInstalledGHCs = do
|
||||
|
||||
|
||||
-- | 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
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
bindir
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
|
||||
Just (Right r) -> pure $ Right r
|
||||
@ -254,16 +255,17 @@ getInstalledCabals = do
|
||||
|
||||
|
||||
-- | 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
|
||||
vers <- fmap rights $ getInstalledCabals
|
||||
pure $ elem ver $ vers
|
||||
|
||||
|
||||
-- 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
|
||||
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
|
||||
if
|
||||
| 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.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> Maybe Text -- ^ the target triple
|
||||
@ -463,11 +465,11 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
--
|
||||
-- - @["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
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
|
||||
-- fail if ghc is not installed
|
||||
|
||||
@ -17,7 +17,6 @@ Some of these functions use sophisticated logging.
|
||||
-}
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
|
||||
@ -123,9 +122,8 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe spath args lfile chdir env = do
|
||||
Settings {..} <- ask
|
||||
ldir <- liftIO ghcupLogsDir
|
||||
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||
Settings {dirs = Dirs {..}, ..} <- ask
|
||||
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
|
||||
closeFd
|
||||
(action verbose)
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Logger
|
||||
@ -13,9 +14,11 @@ Here we define our main logger.
|
||||
-}
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Utils
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Logger
|
||||
import HPath
|
||||
import HPath.IO
|
||||
@ -61,11 +64,12 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs)
|
||||
initGHCupFileLogging context = do
|
||||
logs <- ghcupLogsDir
|
||||
let logfile = logs </> context
|
||||
createDirRecursive newDirPerms logs
|
||||
hideError doesNotExistErrorType $ deleteFile logfile
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let logfile = logsDir </> context
|
||||
liftIO $ do
|
||||
createDirRecursive newDirPerms logsDir
|
||||
hideError doesNotExistErrorType $ deleteFile logfile
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
|
||||
Loading…
Reference in New Issue
Block a user