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

Merge remote-tracking branch 'origin/merge-requests/127'

Browse Source
This commit is contained in:
Julian Ospald 2021-08-11 12:28:48 +02:00
commit bd18fd9aa1
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 286 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
app/ghcup/BrickMain.hs
View File

@ -442,25 +442,26 @@ install' _ (_, ListResult {..}) = do
, DownloadFailed , DownloadFailed
, NoUpdate , NoUpdate
, TarDirDoesNotExist , TarDirDoesNotExist
, FileAlreadyExistsError
] ]
run (do run (do
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer $> vi liftE $ installGHCBin lVer Nothing $> vi
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer $> vi liftE $ installCabalBin lVer Nothing $> vi
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi liftE $ upgradeGHCup Nothing False $> vi
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer $> vi liftE $ installHLSBin lVer Nothing $> vi
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer $> vi liftE $ installStackBin lVer Nothing $> vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do

40
app/ghcup/Main.hs
View File

@ -138,6 +138,7 @@ data InstallOptions = InstallOptions
, instPlatform :: Maybe PlatformRequest , instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI , instBindist :: Maybe URI
, instSet :: Bool , instSet :: Bool
, isolateDir :: Maybe FilePath
} }
data SetCommand = SetGHC SetOptions data SetCommand = SetGHC SetOptions
@ -185,6 +186,7 @@ data GHCCompileOptions = GHCCompileOptions
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String , buildFlavour :: Maybe String
, hadrian :: Bool , hadrian :: Bool
, isolateDir :: Maybe FilePath
} }
data UpgradeOpts = UpgradeInplace data UpgradeOpts = UpgradeInplace
@ -574,7 +576,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool = installOpts tool =
(\p (u, v) b -> InstallOptions v p u b) (\p (u, v) b is -> InstallOptions v p u b is)
<$> optional <$> optional
(option (option
(eitherReader platformParser) (eitherReader platformParser)
@ -603,6 +605,15 @@ installOpts tool =
(long "set" <> help (long "set" <> help
"Set as active version after install" "Set as active version after install"
) )
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated dir instead of the default one"
)
)
setParser :: Parser (Either SetCommand SetOptions) setParser :: Parser (Either SetCommand SetOptions)
@ -1000,6 +1011,15 @@ ghcCompileOpts =
<*> switch <*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)" (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
) )
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
toolVersionParser :: Parser ToolVersion toolVersionParser :: Parser ToolVersion
@ -1215,6 +1235,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
bindistParser :: String -> Either String URI bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
toSettings :: Options -> IO (Settings, KeyBindings) toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do toSettings options = do
@ -1454,6 +1478,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist , TarDirDoesNotExist
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
, FileAlreadyExistsError
] ]
let runInstTool mInstPlatform action' = do let runInstTool mInstPlatform action' = do
@ -1620,7 +1645,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of (case instBindist of
Nothing -> runInstTool instPlatform $ do Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) liftE $ installGHCBin (_tvVersion v) isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
Just uri -> do Just uri -> do
@ -1630,6 +1655,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
) )
@ -1661,7 +1687,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of (case instBindist of
Nothing -> runInstTool instPlatform $ do Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) liftE $ installCabalBin (_tvVersion v) isolateDir
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
@ -1670,6 +1696,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir
pure vi pure vi
) )
>>= \case >>= \case
@ -1692,7 +1719,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of (case instBindist of
Nothing -> runInstTool instPlatform $ do Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) liftE $ installHLSBin (_tvVersion v) isolateDir
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
@ -1701,6 +1728,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir
pure vi pure vi
) )
>>= \case >>= \case
@ -1723,7 +1751,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of (case instBindist of
Nothing -> runInstTool instPlatform $ do Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) liftE $ installStackBin (_tvVersion v) isolateDir
pure vi pure vi
Just uri -> do Just uri -> do
s' <- appState s' <- appState
@ -1732,6 +1760,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installStackBindist liftE $ installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
isolateDir
pure vi pure vi
) )
>>= \case >>= \case
@ -1961,6 +1990,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
addConfArgs addConfArgs
buildFlavour buildFlavour
hadrian hadrian
isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $

168
lib/GHCup.hs
View File

@ -186,6 +186,7 @@ installGHCBindist :: ( MonadFail m
) )
=> DownloadInfo -- ^ where/how to download => DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install -> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -201,10 +202,15 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver = do installGHCBindist dlinfo ver isoFilepath = 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 (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
_ -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -214,8 +220,14 @@ installGHCBindist dlinfo ver = do
toolchainSanityChecks toolchainSanityChecks
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|]
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
where where
@ -339,6 +351,7 @@ installGHCBin :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version -- ^ the version to install => Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -354,9 +367,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver = do installGHCBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver installGHCBindist dlinfo ver isoFilepath
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as -- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@ -375,6 +388,7 @@ installCabalBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -387,15 +401,18 @@ installCabalBindist :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m m
() ()
installCabalBindist dlinfo ver = do installCabalBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- for regular install check if any previous versions installed
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False) handleIO (\_ -> pure False)
@ -405,6 +422,8 @@ installCabalBindist dlinfo ver = do
) )
(throwE $ AlreadyInstalled Cabal ver) (throwE $ AlreadyInstalled Cabal ver)
_ -> pure () -- check isn't required in isolated installs
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -416,31 +435,39 @@ installCabalBindist dlinfo ver = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installCabal' workdir binDir case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|]
liftE $ installCabalUnpacked workdir isoDir ver
-- create symlink if this is the latest version Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir ver
-- create symlink if this is the latest version for regular installs
cVers <- lift $ 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
where -- | Install an unpacked cabal distribution.
-- | Install an unpacked cabal distribution. installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m () -> Version
installCabal' path inst = do -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst ver = do
lift $ $(logInfo) "Installing cabal" lift $ $(logInfo) "Installing cabal"
let cabalFile = "cabal" let cabalFile = "cabal"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName let destPath = inst </> destFileName
whenM
(liftIO $ doesFileExist destPath)
(throwE $ FileAlreadyExistsError destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt) (path </> cabalFile <> exeExt)
destPath destPath
lift $ chmod_755 destPath lift $ chmod_755 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and -- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for -- creates a default @cabal -> cabal-x.y.z.q@ symlink for
-- the latest installed version. -- the latest installed version.
@ -458,6 +485,7 @@ installCabalBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath -- isolated install Path, if user provided any
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -470,12 +498,13 @@ installCabalBin :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m m
() ()
installCabalBin ver = do installCabalBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo Cabal ver dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver installCabalBindist dlinfo ver isoFilepath
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as -- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@ -494,6 +523,7 @@ installHLSBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -509,15 +539,20 @@ installHLSBindist :: ( MonadMask m
] ]
m m
() ()
installHLSBindist dlinfo ver = do installHLSBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of
Nothing ->
-- we only check for already installed in regular (non-isolated) installs
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver) (throwE $ AlreadyInstalled HLS ver)
_ -> pure ()
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -529,20 +564,27 @@ installHLSBindist dlinfo ver = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installHLS' workdir binDir case isoFilepath of
Just isoDir -> do
lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|]
liftE $ installHLSUnpacked workdir isoDir ver
-- create symlink if this is the latest version Nothing -> do
liftE $ installHLSUnpacked workdir binDir ver
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
where
-- | Install an unpacked hls distribution. -- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version
-> Excepts '[CopyError] m () -> Excepts '[CopyError] m ()
installHLS' path inst = do installHLSUnpacked path inst ver = do
lift $ $(logInfo) "Installing HLS" lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -569,7 +611,6 @@ installHLSBindist dlinfo ver = do
(inst </> toF) (inst </> toF)
lift $ chmod_755 (inst </> toF) lift $ chmod_755 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@ -- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m installHLSBin :: ( MonadMask m
@ -586,6 +627,7 @@ installHLSBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -601,9 +643,9 @@ installHLSBin :: ( MonadMask m
] ]
m m
() ()
installHLSBin ver = do installHLSBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo HLS ver dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver installHLSBindist dlinfo ver isoFilepath
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and -- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@ -623,6 +665,7 @@ installStackBin :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Version => Version
-> Maybe FilePath
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -638,9 +681,9 @@ installStackBin :: ( MonadMask m
] ]
m m
() ()
installStackBin ver = do installStackBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo Stack ver dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver installStackBindist dlinfo ver isoFilepath
-- | Like 'installStackBin', except takes the 'DownloadInfo' as -- | Like 'installStackBin', except takes the 'DownloadInfo' as
@ -659,6 +702,7 @@ installStackBindist :: ( MonadMask m
) )
=> DownloadInfo => DownloadInfo
-> Version -> Version
-> Maybe FilePath
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
@ -674,15 +718,19 @@ installStackBindist :: ( MonadMask m
] ]
m m
() ()
installStackBindist dlinfo ver = do installStackBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|] lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- check previous versions in case of regular installs
whenM (lift (stackInstalled ver)) whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver) (throwE $ AlreadyInstalled Stack ver)
_ -> pure () -- don't do shit for isolates
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -694,20 +742,26 @@ installStackBindist dlinfo ver = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installStack' workdir binDir case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|]
liftE $ installStackUnpacked workdir isoDir ver
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir ver
-- create symlink if this is the latest version -- create symlink if this is the latest version and a regular install
sVers <- lift $ fmap rights getInstalledStacks sVers <- lift $ fmap rights getInstalledStacks
let lInstStack = headMay . reverse . sort $ sVers let lInstStack = headMay . reverse . sort $ sVers
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
where
-- | Install an unpacked stack distribution. -- | Install an unpacked stack distribution.
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version
-> Excepts '[CopyError] m () -> Excepts '[CopyError] m ()
installStack' path inst = do installStackUnpacked path inst ver = do
lift $ $(logInfo) "Installing stack" lift $ $(logInfo) "Installing stack"
let stackFile = "stack" let stackFile = "stack"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -719,8 +773,6 @@ installStackBindist dlinfo ver = do
lift $ chmod_755 destPath lift $ chmod_755 destPath
--------------------- ---------------------
--[ Set GHC/cabal ]-- --[ Set GHC/cabal ]--
--------------------- ---------------------
@ -1700,6 +1752,7 @@ compileGHC :: ( MonadMask m
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Bool -> Bool
-> Maybe FilePath -- ^ isolate dir
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -1718,7 +1771,7 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
= do = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -1788,12 +1841,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
alreadyInstalled <- lift $ ghcInstalled installVer alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver) alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
when alreadyInstalled $ do when alreadyInstalled $ do
case isolateDir of
Just isoDir ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |]
Nothing ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|] lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
lift $ $(logWarn) lift $ $(logWarn)
"...waiting for 10 seconds before continuing, you can still abort..." "...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- lift $ ghcupGHCDir installVer ghcdir <- case isolateDir of
Just isoDir -> pure isoDir
Nothing -> lift $ ghcupGHCDir installVer
bghc <- case bstrap of bghc <- case bstrap of
Right g -> pure $ Right g Right g -> pure $ Right g
@ -1810,10 +1869,15 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
pure (b, bmk) pure (b, bmk)
) )
case isolateDir of
Nothing ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|] lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver liftE $ rmGHCVer tver
_ -> pure ()
forM_ mBindist $ \bindist -> do forM_ mBindist $ \bindist -> do
liftE $ installPackedGHC bindist liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*") (Just $ RegexDir "ghc-.*")
@ -1822,11 +1886,15 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
case isolateDir of
-- set and make symlinks for regular (non-isolated) installs
Nothing -> do
reThrowAll GHCupSetError $ postGHCInstall tver reThrowAll GHCupSetError $ postGHCInstall tver
-- restore -- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
_ -> pure ()
pure tver pure tver
where where
@ -2184,6 +2252,28 @@ upgradeGHCup mtarget force' = do
--[ Other ]-- --[ Other ]--
------------- -------------
-- | Does basic checks for isolated installs
-- Isolated Directory:
-- 1. if it doesn't exist -> proceed
-- 2. if it exists and is empty -> proceed
-- 3. if it exists and is non-empty -> panic and leave the house
isolatedInstallSanityCheck :: ( MonadIO m
, MonadThrow m
) =>
FilePath ->
Excepts '[IsolatedDirNotEmpty] m ()
isolatedInstallSanityCheck isoDir = do
dirExists <- liftIO $ doesDirectoryExist isoDir
if not dirExists
then pure ()
else do
len <- liftIO $ length <$> listDirectory isoDir
let isDirEmpty = len == 0
if isDirEmpty
then pure ()
else (throwE $ IsolatedDirNotEmpty isoDir)
-- | 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.

18
lib/GHCup/Errors.hs
View File

@ -134,6 +134,14 @@ instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') = pPrint (AlreadyInstalled tool ver') =
text [i|#{tool}-#{prettyShow ver'} is already installed|] text [i|#{tool}-#{prettyShow ver'} is already installed|]
-- | The Directory for isolated install already exists and is not empty
-- | This is done to prevent any overwriting
data IsolatedDirNotEmpty = IsolatedDirNotEmpty {path :: FilePath}
instance Pretty IsolatedDirNotEmpty where
pPrint (IsolatedDirNotEmpty path) = do
text [i| The directory for isolated install already exists and is NOT EMPTY : #{path}|]
-- | The tool is not installed. Some operations rely on a tool -- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version). -- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool GHCTargetVersion data NotInstalled = NotInstalled Tool GHCTargetVersion
@ -168,6 +176,16 @@ instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) = pPrint (FileDoesNotExistError file) =
text [i|File "#{file}" does not exist.|] text [i|File "#{file}" does not exist.|]
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
-- (e.g. This is done to prevent any overwriting)
data FileAlreadyExistsError = FileAlreadyExistsError FilePath
deriving Show
instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
text [i|File "#{file}" Already exists.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show deriving Show