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

Support multiple installed versions of cabal 

Fixes #23
This commit is contained in:
Julian Ospald 2020-05-11 00:18:53 +02:00
parent ede6299681
commit 6c95218daf
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 501 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
README.md
View File

@ -47,16 +47,16 @@ Common use cases are:
ghcup list ghcup list
# install the recommended GHC version # install the recommended GHC version
ghcup install ghcup install ghc
# install a specific GHC version # install a specific GHC version
ghcup install 8.2.2 ghcup install ghc 8.2.2
# set the currently "active" GHC version # set the currently "active" GHC version
ghcup set 8.4.4 ghcup set ghc 8.4.4
# install cabal-install # install cabal-install
ghcup install-cabal ghcup install cabal
# update ghcup itself # update ghcup itself
ghcup upgrade ghcup upgrade

472
app/ghcup/Main.hs
View File

@ -82,11 +82,11 @@ data Options = Options
} }
data Command data Command
= Install InstallOptions = Install (Either InstallCommand InstallOptions)
| InstallCabal InstallOptions | InstallCabalLegacy InstallOptions
| SetGHC SetGHCOptions | Set (Either SetCommand SetOptions)
| List ListOptions | List ListOptions
| Rm RmOptions | Rm (Either RmCommand RmOptions)
| DInfo | DInfo
| Compile CompileCommand | Compile CompileCommand
| Upgrade UpgradeOpts Bool | Upgrade UpgradeOpts Bool
@ -101,13 +101,19 @@ prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v'
prettyToolVer (ToolTag t) = show t prettyToolVer (ToolTag t) = show t
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
data InstallOptions = InstallOptions data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest , instPlatform :: Maybe PlatformRequest
} }
data SetGHCOptions = SetGHCOptions data SetCommand = SetGHC SetOptions
{ ghcVer :: Maybe ToolVersion | SetCabal SetOptions
data SetOptions = SetOptions
{ sToolVer :: Maybe ToolVersion
} }
data ListOptions = ListOptions data ListOptions = ListOptions
@ -116,6 +122,9 @@ data ListOptions = ListOptions
, lRawFormat :: Bool , lRawFormat :: Bool
} }
data RmCommand = RmGHC RmOptions
| RmCabal Version
data RmOptions = RmOptions data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion { ghcVer :: GHCTargetVersion
} }
@ -213,44 +222,38 @@ com =
subparser subparser
( command ( command
"install" "install"
((info ( Install
((Install <$> installOpts) <**> helper) <$> (info
( progDesc "Install or update GHC" (installParser <**> helper)
<> footerDoc (Just $ text installFooter) ( progDesc "Install or update GHC/cabal"
) <> footerDoc (Just $ text installToolFooter)
) )
)
) )
<> command <> command
"set" "set"
( SetGHC
<$> (info
(setGHCOpts <**> helper)
( progDesc "Set currently active GHC version"
<> footerDoc (Just $ text setFooter)
)
)
)
<> command
"rm"
( Rm
<$> (info (rmOpts <**> helper) (progDesc "Remove a GHC version"))
)
<> command
"install-cabal"
((info ((info
((InstallCabal <$> installOpts) <**> helper) (Set <$> setParser <**> helper)
( progDesc "Install or update cabal" ( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text installCabalFooter) <> footerDoc (Just $ text setFooter)
) )
) )
) )
<> command
"rm"
((info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
)
<> command <> command
"list" "list"
( List ((info (List <$> listOpts <**> helper)
<$> (info (listOpts <**> helper) (progDesc "Show available GHCs and other tools")
(progDesc "Show available GHCs and other tools") )
)
) )
<> command <> command
"upgrade" "upgrade"
@ -284,33 +287,95 @@ com =
) )
<> command <> command
"changelog" "changelog"
((info (fmap ChangeLog changelogP <**> helper) ((info
(progDesc "Find/show changelog" (fmap ChangeLog changelogP <**> helper)
<> footerDoc (Just $ text changeLogFooter) ( progDesc "Find/show changelog"
) <> footerDoc (Just $ text changeLogFooter)
)
) )
) )
<> commandGroup "Other commands:" <> commandGroup "Other commands:"
<> hidden <> hidden
) )
<|> subparser
( command
"install-cabal"
((info
((InstallCabalLegacy <$> installOpts) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
<> internal
)
where where
installFooter = [i|Discussion: installToolFooter :: String
Installs the specified GHC version (or a recommended default one) into installToolFooter = [i|Discussion:
a self-contained "~/.ghcup/ghc/<ghcver>" directory Installs GHC or cabal. When no command is given, installs GHC
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|] with the specified version/tag.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
setFooter :: String
setFooter = [i|Discussion: setFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned Sets the currently active GHC or cabal version. When no command is given,
symlinks for all ghc binaries of the specified version in defaults to setting GHC with the specified version/tag (if no tag
"~/.ghcup/bin/<binary>".|] is given, sets GHC to 'recommended' version).
installCabalFooter = [i|Discussion: It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
rmFooter :: String
rmFooter = [i|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
changeLogFooter :: String
changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
installCabalFooter :: String
installCabalFooter = [i|Discussion:
Installs the specified cabal-install version (or a recommended default one) Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by "cabal install cabal-install", which installs into "~/.cabal/bin" by
default. Make sure to set up your PATH appropriately, so the cabal default. Make sure to set up your PATH appropriately, so the cabal
installation takes precedence.|] installation takes precedence.|]
changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|] installParser :: Parser (Either InstallCommand InstallOptions)
installParser =
(Left <$> subparser
( command
"ghc"
( InstallGHC
<$> (info
(installOpts <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
)
<> command
"cabal"
( InstallCabal
<$> (info
(installOpts <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
)
)
<|> (Right <$> installOpts)
where
installGHCFooter :: String
installGHCFooter = [i|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
installOpts :: Parser InstallOptions installOpts :: Parser InstallOptions
@ -330,8 +395,46 @@ installOpts =
<*> optional toolVersionArgument <*> optional toolVersionArgument
setGHCOpts :: Parser SetGHCOptions setParser :: Parser (Either SetCommand SetOptions)
setGHCOpts = SetGHCOptions <$> optional toolVersionArgument setParser =
(Left <$> subparser
( command
"ghc"
( SetGHC
<$> (info
(setOpts <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
)
<> command
"cabal"
( SetCabal
<$> (info
(setOpts <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
)
)
)
<|> (Right <$> setOpts)
where
setGHCFooter :: String
setGHCFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
setCabalFooter :: String
setCabalFooter = [i|Discussion:
Sets the the current Cabal version.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
listOpts :: Parser ListOptions listOpts :: Parser ListOptions
listOpts = listOpts =
@ -357,6 +460,26 @@ listOpts =
(short 'r' <> long "raw-format" <> help "More machine-parsable format" (short 'r' <> long "raw-format" <> help "More machine-parsable format"
) )
rmParser :: Parser (Either RmCommand RmOptions)
rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
<> command
"cabal"
( RmCabal
<$> (info (versionParser' <**> helper)
(progDesc "Remove Cabal version")
)
)
)
)
<|> (Right <$> rmOpts)
rmOpts :: Parser RmOptions rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionArgument rmOpts = RmOptions <$> versionArgument
@ -534,6 +657,12 @@ versionParser = option
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version" (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
) )
versionParser' :: Parser Version
versionParser' = argument
(eitherReader (bimap show id . version . T.pack))
(metavar "VERSION")
tagEither :: String -> Either String Tag tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended "recommended" -> Right Recommended
@ -744,7 +873,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, rawOutter = appendFile logfile , rawOutter = appendFile logfile
} }
-- wrapper to run effects with settings
-------------------------
-- Effect interpreters --
-------------------------
let runInstTool = let runInstTool =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
@ -776,6 +909,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound , TagNotFound
] ]
let
runSetCabal =
runLogger
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runE @'[] . runLogger let runListGHC = runE @'[] . runLogger
let runRmGHC = let runRmGHC =
@ -811,13 +952,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. flip runReaderT settings . flip runReaderT settings
. runResourceT . runResourceT
. runE . runE
@'[ BuildFailed @'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError , DigestError
, DistroNotFound , DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch , NoCompatibleArch
, NoCompatiblePlatform , NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
] ]
@ -838,6 +982,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, DownloadFailed , DownloadFailed
] ]
---------------------------
-- Getting download info --
---------------------------
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
. flip runReaderT settings . flip runReaderT settings
@ -853,79 +1002,134 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
runLogger $ checkForUpdates dls runLogger $ checkForUpdates dls
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("GHC installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended GHC version|]
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("Cabal installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
(runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 5
let setCabal' SetOptions{..} =
(runSetCabal $ do
v <- liftE $ fromVersion dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7
let rmCabal' tv =
(runSetCabal $ do
liftE $ rmCabalVer tv
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
res <- case optCommand of res <- case optCommand of
Install (InstallOptions {..}) -> Install (Right iopts) -> do
(runInstTool $ do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
v <- liftE $ fromVersion dls instVer GHC installGHC iopts
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version Install (Left (InstallGHC iopts)) -> installGHC iopts
) Install (Left (InstallCabal iopts)) -> installCabal iopts
>>= \case InstallCabalLegacy iopts -> do
VRight _ -> do runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
runLogger $ $(logInfo) ("GHC installation successful") installCabal iopts
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
runLogger $ do Set (Right sopts) -> do
case instVer of runLogger ($(logWarn) [i|This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.|])
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|] setGHC' sopts
Nothing -> $(logError) [i|No available recommended GHC version|] Set (Left (SetGHC sopts)) -> setGHC' sopts
pure $ ExitFailure 3 Set (Left (SetCabal sopts)) -> setCabal' sopts
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
InstallCabal (InstallOptions {..}) ->
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("Cabal installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
SetGHC (SetGHCOptions {..}) ->
(runSetGHC $ do
v <- liftE $ fromVersion dls ghcVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 5
List (ListOptions {..}) -> List (ListOptions {..}) ->
(runListGHC $ do (runListGHC $ do
@ -940,15 +1144,11 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger ($(logError) [i|#{e}|]) runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6 pure $ ExitFailure 6
Rm (RmOptions {..}) -> Rm (Right rmopts) -> do
(runRmGHC $ do runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
liftE $ rmGHCVer ghcVer rmGHC' rmopts
) Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
>>= \case Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7
DInfo -> DInfo ->
do do
@ -1182,14 +1382,14 @@ checkForUpdates dls = do
forM mghc_ver $ \ghc_ver -> forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install #{prettyVer l}'|] [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)
$ $(logWarn) $ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install-cabal #{prettyVer l}'|] [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where where
latestInstalled tool = (fmap lVer . lastMay) latestInstalled tool = (fmap lVer . lastMay)

155
lib/GHCup.hs
View File

@ -38,6 +38,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
@ -53,6 +54,7 @@ import Prelude hiding ( abs
, readFile , readFile
, writeFile , writeFile
) )
import Safe hiding ( at )
import System.IO.Error import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment ) import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath ) import System.Posix.FilePath ( getSearchPath )
@ -148,24 +150,39 @@ installCabalBin :: ( MonadMask m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadFail m
) )
=> GHCupDownloads => GHCupDownloads
-> Version -> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts -> Excepts
'[ CopyError '[ AlreadyInstalled
, CopyError
, DigestError , DigestError
, DistroNotFound , DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch , NoCompatibleArch
, NoCompatiblePlatform , NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled
, UnknownArchive , UnknownArchive
] ]
m m
() ()
installCabalBin bDls ver mpfReq = do installCabalBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled ver >>= \a ->
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal ver)
Settings {..} <- lift ask Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
@ -178,13 +195,16 @@ installCabalBin bDls ver mpfReq = do
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
bindir <- liftIO ghcupBinDir
-- 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
cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
pure () pure ()
where where
@ -197,16 +217,17 @@ installCabalBin bDls ver mpfReq = do
lift $ $(logInfo) "Installing cabal" lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|] let cabalFile = [rel|cabal|]
liftIO $ createDirIfMissing newDirPerms inst liftIO $ createDirIfMissing newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile) (path </> cabalFile)
(inst </> cabalFile) (inst </> destFileName)
Overwrite Overwrite
--------------- ---------------------
--[ Set GHC ]-- --[ Set GHC/cabal ]--
--------------- ---------------------
@ -283,6 +304,40 @@ setGHC ver sghc = do
-- | Set the ~/.ghcup/bin/cabal symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
let verBS = verToBS ver
targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile))
$ throwE
$ NotInstalled Cabal (prettyVer ver)
let cabalbin = bindir </> [rel|cabal|]
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile
cabalbin
-- create symlink
let destL = toFilePath targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
liftIO $ createSymlink cabalbin destL
pure ()
------------------ ------------------
--[ List tools ]-- --[ List tools ]--
@ -386,8 +441,8 @@ listVersions av lt criteria = case lt of
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do Cabal -> do
lSet <- fmap (== v) $ cabalSet lSet <- fmap (maybe False (== v)) $ cabalSet
let lInstalled = lSet lInstalled <- cabalInstalled v
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
, lTag = tags , lTag = tags
@ -417,9 +472,9 @@ listVersions av lt criteria = case lt of
-------------- --------------------
--[ GHC rm ]-- --[ GHC/cabal rm ]--
-------------- --------------------
-- | This function may throw and crash in various ways. -- | This function may throw and crash in various ways.
@ -461,6 +516,26 @@ rmGHCVer ver = do
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)) else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | This function may throw and crash in various ways.
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled GHC (prettyVer ver))
cSet <- liftIO cabalSet
bindir <- liftIO ghcupBinDir
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile)
when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> [rel|cabal|])
------------------ ------------------
@ -671,26 +746,29 @@ Stage1Only = YES|]
compileCabal :: ( MonadReader Settings m compileCabal :: ( MonadReader Settings m
, MonadResource m , MonadResource m
, MonadMask m , MonadMask m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadFail m
) )
=> GHCupDownloads => GHCupDownloads
-> Version -- ^ version to install -> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with -> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int -> Maybe Int
-> Maybe (Path Abs) -> Maybe (Path Abs)
-> Excepts -> Excepts
'[ BuildFailed '[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError , DigestError
, DistroNotFound , DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch , NoCompatibleArch
, NoCompatiblePlatform , NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
] ]
@ -699,6 +777,17 @@ compileCabal :: ( MonadReader Settings m
compileCabal dls tver bghc jobs patchdir = do compileCabal dls tver bghc jobs patchdir = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled tver >>= \a ->
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal tver)
-- download source tarball -- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
@ -711,21 +800,25 @@ compileCabal dls tver bghc jobs patchdir = do
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
liftE $ runBuildAction destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
tmpUnpack handleIO (throwE . CopyError . show) $ liftIO $ copyFile
Nothing cbin
(compile workdir) (bindir </> destFileName)
Overwrite
-- only clean up dir if the build succeeded -- create symlink if this is the latest version
liftIO $ deleteDirRecursive tmpUnpack cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
pure () pure ()
where where
compile :: (MonadThrow m, MonadLogger m, MonadIO m) compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs => Path Abs
-> Excepts '[ProcessError , PatchFailed] m () -> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do compile workdir = do
lift $ $(logInfo) [i|Building (this may take a while)...|] lift $ $(logInfo) [i|Building (this may take a while)...|]
@ -741,14 +834,19 @@ compileCabal dls tver bghc jobs patchdir = do
pure pure
[ ("GHC" , toFilePath path) [ ("GHC" , toFilePath path)
, ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver) , ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver)
, ("HADDOCK", dn <> "/" <> "haddock" <> ver)
] ]
Left bver -> do Left bver -> do
let v' = verToBS bver let v' = verToBS bver
pure [("GHC", "ghc-" <> v'), ("GHC_PKG", "ghc-pkg-" <> v')] pure
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("HADDOCK", "haddock-" <> v')
]
cabal_bin <- liftIO $ ghcupBinDir tmp <- lift withGHCupTmpDir
newEnv <- lift liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
$ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv) newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|] lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ liftIO $ execLogged "./bootstrap.sh" lEM $ liftIO $ execLogged "./bootstrap.sh"
@ -757,6 +855,7 @@ compileCabal dls tver bghc jobs patchdir = do
[rel|cabal-bootstrap|] [rel|cabal-bootstrap|]
(Just workdir) (Just workdir)
(Just newEnv) (Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])

45
lib/GHCup/Utils.hs
View File

@ -210,19 +210,41 @@ getInstalledGHCs = do
Left _ -> pure $ Left f Left _ -> pure $ Left f
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
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
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
pure $ maybe vs (\x -> Right x:vs) cs
cabalInstalled :: Version -> IO Bool cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do cabalInstalled ver = do
reportedVer <- cabalSet vers <- fmap rights $ getInstalledCabals
pure (reportedVer == ver) pure $ elem ver $ vers
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet = do cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
mc <- liftIO $ executeOut cabalbin ["--numeric-version"] Nothing mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc cabalbin
case version $ decUTF8Safe reportedVer of ["--numeric-version"]
Left e -> throwM e Nothing
Right r -> pure r fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c))
, _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
@ -463,11 +485,11 @@ getChangeLog dls tool (Right tag) =
runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m) runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory => Path Abs -- ^ build directory
-> Maybe (Path Abs) -- ^ install location (e.g. for GHC) -> Maybe (Path Abs) -- ^ install location (e.g. for GHC)
-> Excepts e m () -> Excepts e m a
-> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do runBuildAction bdir instdir action = do
Settings {..} <- lift ask Settings {..} <- lift ask
flip v <- flip
onException onException
(do (do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
@ -491,3 +513,4 @@ runBuildAction bdir instdir action = do
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir bdir
pure v