diff --git a/README.md b/README.md index 46b1309..3fcae8b 100644 --- a/README.md +++ b/README.md @@ -47,16 +47,16 @@ Common use cases are: ghcup list # install the recommended GHC version -ghcup install +ghcup install ghc # install a specific GHC version -ghcup install 8.2.2 +ghcup install ghc 8.2.2 # set the currently "active" GHC version -ghcup set 8.4.4 +ghcup set ghc 8.4.4 # install cabal-install -ghcup install-cabal +ghcup install cabal # update ghcup itself ghcup upgrade diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index aab3e51..d7f3a88 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -82,11 +82,11 @@ data Options = Options } data Command - = Install InstallOptions - | InstallCabal InstallOptions - | SetGHC SetGHCOptions + = Install (Either InstallCommand InstallOptions) + | InstallCabalLegacy InstallOptions + | Set (Either SetCommand SetOptions) | List ListOptions - | Rm RmOptions + | Rm (Either RmCommand RmOptions) | DInfo | Compile CompileCommand | Upgrade UpgradeOpts Bool @@ -101,13 +101,19 @@ prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v' prettyToolVer (ToolTag t) = show t +data InstallCommand = InstallGHC InstallOptions + | InstallCabal InstallOptions + data InstallOptions = InstallOptions { instVer :: Maybe ToolVersion , instPlatform :: Maybe PlatformRequest } -data SetGHCOptions = SetGHCOptions - { ghcVer :: Maybe ToolVersion +data SetCommand = SetGHC SetOptions + | SetCabal SetOptions + +data SetOptions = SetOptions + { sToolVer :: Maybe ToolVersion } data ListOptions = ListOptions @@ -116,6 +122,9 @@ data ListOptions = ListOptions , lRawFormat :: Bool } +data RmCommand = RmGHC RmOptions + | RmCabal Version + data RmOptions = RmOptions { ghcVer :: GHCTargetVersion } @@ -213,44 +222,38 @@ com = subparser ( command "install" - ((info - ((Install <$> installOpts) <**> helper) - ( progDesc "Install or update GHC" - <> footerDoc (Just $ text installFooter) - ) - ) + ( Install + <$> (info + (installParser <**> helper) + ( progDesc "Install or update GHC/cabal" + <> footerDoc (Just $ text installToolFooter) + ) + ) ) <> command "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 - ((InstallCabal <$> installOpts) <**> helper) - ( progDesc "Install or update cabal" - <> footerDoc (Just $ text installCabalFooter) + (Set <$> setParser <**> helper) + ( progDesc "Set currently active GHC/cabal version" + <> footerDoc (Just $ text setFooter) ) ) ) + <> command + "rm" + ((info + (Rm <$> rmParser <**> helper) + ( progDesc "Remove a GHC/cabal version" + <> footerDoc (Just $ text rmFooter) + ) + ) + ) + <> command "list" - ( List - <$> (info (listOpts <**> helper) - (progDesc "Show available GHCs and other tools") - ) + ((info (List <$> listOpts <**> helper) + (progDesc "Show available GHCs and other tools") + ) ) <> command "upgrade" @@ -284,33 +287,95 @@ com = ) <> command "changelog" - ((info (fmap ChangeLog changelogP <**> helper) - (progDesc "Find/show changelog" - <> footerDoc (Just $ text changeLogFooter) - ) + ((info + (fmap ChangeLog changelogP <**> helper) + ( progDesc "Find/show changelog" + <> footerDoc (Just $ text changeLogFooter) + ) ) ) <> commandGroup "Other commands:" <> hidden ) + <|> subparser + ( command + "install-cabal" + ((info + ((InstallCabalLegacy <$> installOpts) <**> helper) + ( progDesc "Install or update cabal" + <> footerDoc (Just $ text installCabalFooter) + ) + ) + ) + <> internal + ) where - installFooter = [i|Discussion: - Installs the specified GHC version (or a recommended default one) into - a self-contained "~/.ghcup/ghc/" directory - and symlinks the ghc binaries to "~/.ghcup/bin/-".|] + installToolFooter :: String + installToolFooter = [i|Discussion: + Installs GHC or cabal. When no command is given, installs GHC + with the specified version/tag. + It is recommended to always specify a subcommand ('ghc' or 'cabal').|] + + setFooter :: String setFooter = [i|Discussion: - Sets the the current GHC version by creating non-versioned - symlinks for all ghc binaries of the specified version in - "~/.ghcup/bin/".|] - installCabalFooter = [i|Discussion: + Sets the currently active GHC or cabal version. When no command is given, + defaults to setting GHC with the specified version/tag (if no tag + is given, sets GHC to 'recommended' version). + 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) into "~/.ghcup/bin", so it can be overwritten by later "cabal install cabal-install", which installs into "~/.cabal/bin" by default. Make sure to set up your PATH appropriately, so the cabal 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/" directory + and symlinks the ghc binaries to "~/.ghcup/bin/-".|] installOpts :: Parser InstallOptions @@ -330,8 +395,46 @@ installOpts = <*> optional toolVersionArgument -setGHCOpts :: Parser SetGHCOptions -setGHCOpts = SetGHCOptions <$> optional toolVersionArgument +setParser :: Parser (Either SetCommand SetOptions) +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/".|] + + setCabalFooter :: String + setCabalFooter = [i|Discussion: + Sets the the current Cabal version.|] + + +setOpts :: Parser SetOptions +setOpts = SetOptions <$> optional toolVersionArgument listOpts :: Parser ListOptions listOpts = @@ -357,6 +460,26 @@ listOpts = (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 = RmOptions <$> versionArgument @@ -534,6 +657,12 @@ versionParser = option (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 s' = case fmap toLower s' of "recommended" -> Right Recommended @@ -744,7 +873,11 @@ Report bugs at |] , rawOutter = appendFile logfile } - -- wrapper to run effects with settings + + ------------------------- + -- Effect interpreters -- + ------------------------- + let runInstTool = runLogger . flip runReaderT settings @@ -776,6 +909,14 @@ Report bugs at |] , TagNotFound ] + let + runSetCabal = + runLogger + . runE + @'[ NotInstalled + , TagNotFound + ] + let runListGHC = runE @'[] . runLogger let runRmGHC = @@ -811,13 +952,16 @@ Report bugs at |] . flip runReaderT settings . runResourceT . runE - @'[ BuildFailed + @'[ AlreadyInstalled + , BuildFailed + , CopyError , DigestError , DistroNotFound , DownloadFailed , NoCompatibleArch , NoCompatiblePlatform , NoDownload + , NotInstalled , PatchFailed , UnknownArchive ] @@ -838,6 +982,11 @@ Report bugs at |] , DownloadFailed ] + + --------------------------- + -- Getting download info -- + --------------------------- + (GHCupInfo treq dls) <- ( runLogger . flip runReaderT settings @@ -853,79 +1002,134 @@ Report bugs at |] exitWith (ExitFailure 2) 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 - Install (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 + Install (Right iopts) -> do + runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) + installGHC iopts + Install (Left (InstallGHC iopts)) -> installGHC iopts + Install (Left (InstallCabal iopts)) -> installCabal iopts + InstallCabalLegacy iopts -> do + runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|]) + installCabal iopts - 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 - 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 + Set (Right sopts) -> do + runLogger ($(logWarn) [i|This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.|]) + setGHC' sopts + Set (Left (SetGHC sopts)) -> setGHC' sopts + Set (Left (SetCabal sopts)) -> setCabal' sopts List (ListOptions {..}) -> (runListGHC $ do @@ -940,15 +1144,11 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger ($(logError) [i|#{e}|]) pure $ ExitFailure 6 - Rm (RmOptions {..}) -> - (runRmGHC $ do - liftE $ rmGHCVer ghcVer - ) - >>= \case - VRight _ -> pure ExitSuccess - VLeft e -> do - runLogger ($(logError) [i|#{e}|]) - pure $ ExitFailure 7 + Rm (Right rmopts) -> do + runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|]) + rmGHC' rmopts + Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts + Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts DInfo -> do @@ -1182,14 +1382,14 @@ checkForUpdates dls = do forM mghc_ver $ \ghc_ver -> when (l > ghc_ver) $ $(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 mcabal_ver <- latestInstalled Cabal forM mcabal_ver $ \cabal_ver -> when (l > cabal_ver) $ $(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 latestInstalled tool = (fmap lVer . lastMay) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 967dd94..8ac1679 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -38,6 +38,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) import Data.ByteString ( ByteString ) +import Data.Either import Data.List import Data.Maybe import Data.String.Interpolate @@ -53,6 +54,7 @@ import Prelude hiding ( abs , readFile , writeFile ) +import Safe hiding ( at ) import System.IO.Error import System.Posix.Env.ByteString ( getEnvironment ) import System.Posix.FilePath ( getSearchPath ) @@ -148,24 +150,39 @@ installCabalBin :: ( MonadMask m , MonadLogger m , MonadResource m , MonadIO m + , MonadFail m ) => GHCupDownloads -> Version -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Excepts - '[ CopyError + '[ AlreadyInstalled + , CopyError , DigestError , DistroNotFound , DownloadFailed , NoCompatibleArch , NoCompatiblePlatform , NoDownload + , NotInstalled , UnknownArchive ] m () installCabalBin bDls ver mpfReq = do 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 pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq @@ -178,13 +195,16 @@ installCabalBin bDls ver mpfReq = do liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack - -- prepare paths - bindir <- liftIO ghcupBinDir - -- the subdir of the archive where we do the work let workdir = maybe tmpUnpack (tmpUnpack ) (view dlSubdir dlinfo) 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 () where @@ -197,16 +217,17 @@ installCabalBin bDls ver mpfReq = do lift $ $(logInfo) "Installing cabal" let cabalFile = [rel|cabal|] liftIO $ createDirIfMissing newDirPerms inst + destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver) handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile) - (inst cabalFile) + (inst destFileName) 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 ]-- @@ -386,8 +441,8 @@ listVersions av lt criteria = case lt of fromSrc <- ghcSrcInstalled tver pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } Cabal -> do - lSet <- fmap (== v) $ cabalSet - let lInstalled = lSet + lSet <- fmap (maybe False (== v)) $ cabalSet + lInstalled <- cabalInstalled v pure ListResult { lVer = v , lCross = Nothing , 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. @@ -461,6 +516,26 @@ rmGHCVer ver = do 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 , MonadResource m , MonadMask m , MonadLogger m , MonadIO m + , MonadFail m ) => GHCupDownloads - -> Version -- ^ version to install + -> Version -- ^ version to install -> Either Version (Path Abs) -- ^ version to bootstrap with -> Maybe Int -> Maybe (Path Abs) -> Excepts - '[ BuildFailed + '[ AlreadyInstalled + , BuildFailed + , CopyError , DigestError , DistroNotFound , DownloadFailed , NoCompatibleArch , NoCompatiblePlatform , NoDownload + , NotInstalled , PatchFailed , UnknownArchive ] @@ -699,6 +777,17 @@ compileCabal :: ( MonadReader Settings m compileCabal dls tver bghc jobs patchdir = do 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 dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload 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 + cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir) - liftE $ runBuildAction - tmpUnpack - Nothing - (compile workdir) + destFileName <- lift $ parseRel ("cabal-" <> verToBS tver) + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + cbin + (bindir destFileName) + Overwrite - -- only clean up dir if the build succeeded - liftIO $ deleteDirRecursive tmpUnpack + -- create symlink if this is the latest version + cVers <- liftIO $ fmap rights $ getInstalledCabals + let lInstCabal = headMay . reverse . sort $ cVers + when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver pure () where - compile :: (MonadThrow m, MonadLogger m, MonadIO m) + compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m) => Path Abs - -> Excepts '[ProcessError , PatchFailed] m () + -> Excepts '[ProcessError , PatchFailed] m (Path Abs) compile workdir = do lift $ $(logInfo) [i|Building (this may take a while)...|] @@ -741,14 +834,19 @@ compileCabal dls tver bghc jobs patchdir = do pure [ ("GHC" , toFilePath path) , ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver) + , ("HADDOCK", dn <> "/" <> "haddock" <> ver) ] Left bver -> do 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 - newEnv <- lift - $ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv) + tmp <- lift withGHCupTmpDir + liftIO $ createDirRecursive newDirPerms (tmp [rel|bin|]) + newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv) lift $ $(logDebug) [i|Environment: #{newEnv}|] lEM $ liftIO $ execLogged "./bootstrap.sh" @@ -757,6 +855,7 @@ compileCabal dls tver bghc jobs patchdir = do [rel|cabal-bootstrap|] (Just workdir) (Just newEnv) + pure $ (tmp [rel|bin/cabal|]) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 423328c..43d9f32 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -210,19 +210,41 @@ getInstalledGHCs = do 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 ver = do - reportedVer <- cabalSet - pure (reportedVer == ver) + vers <- fmap rights $ getInstalledCabals + pure $ elem ver $ vers -cabalSet :: (MonadIO m, MonadThrow m) => m Version + +cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) cabalSet = do cabalbin <- ( [rel|cabal|]) <$> liftIO ghcupBinDir - mc <- liftIO $ executeOut cabalbin ["--numeric-version"] Nothing - let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc - case version $ decUTF8Safe reportedVer of - Left e -> throwM e - Right r -> pure r + mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut + cabalbin + ["--numeric-version"] + Nothing + 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) => Path Abs -- ^ build directory -> Maybe (Path Abs) -- ^ install location (e.g. for GHC) - -> Excepts e m () - -> Excepts '[BuildFailed] m () + -> Excepts e m a + -> Excepts '[BuildFailed] m a runBuildAction bdir instdir action = do Settings {..} <- lift ask - flip + v <- flip onException (do forM_ instdir $ \dir -> @@ -491,3 +513,4 @@ runBuildAction bdir instdir action = do when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive bdir + pure v