From b036c9861fb1f39d3bb06f88aa1ae22f3799c29c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 2 May 2022 19:54:37 +0200 Subject: [PATCH] Re-enable upgrade functionality for all configurations Adds a --fail-if-shadowed switch. --- app/ghcup/BrickMain.hs | 3 +- app/ghcup/GHCup/OptParse.hs | 6 ++-- app/ghcup/GHCup/OptParse/Upgrade.hs | 13 ++++---- app/ghcup/Main.hs | 46 +++++++++++------------------ docs/guide.md | 7 +++++ ghcup.cabal | 13 +------- lib/GHCup.hs | 25 +++++++++------- lib/GHCup/Errors.hs | 19 ++++++++++++ 8 files changed, 73 insertions(+), 59 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index fe2bf2a..4108310 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -437,6 +437,7 @@ install' _ (_, ListResult {..}) = do , TarDirDoesNotExist , FileAlreadyExistsError , ProcessError + , GHCupShadowed ] run (do @@ -452,7 +453,7 @@ install' _ (_, ListResult {..}) = do liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce) GHCup -> do let vi = snd <$> getLatest dls GHCup - liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce) + liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) HLS -> do let vi = getVersionInfo lVer HLS dls liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce) diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs index 77fbb00..9904c60 100644 --- a/app/ghcup/GHCup/OptParse.hs +++ b/app/ghcup/GHCup/OptParse.hs @@ -96,7 +96,7 @@ data Command | Config ConfigCommand | Whereis WhereisOptions WhereisCommand #ifndef DISABLE_UPGRADE - | Upgrade UpgradeOpts Bool + | Upgrade UpgradeOpts Bool Bool #endif | ToolRequirements ToolReqOpts | ChangeLog ChangeLogOptions @@ -222,18 +222,18 @@ com = (info (List <$> listOpts <**> helper) (progDesc "Show available GHCs and other tools") ) -#ifndef DISABLE_UPGRADE <> command "upgrade" (info ( (Upgrade <$> upgradeOptsP <*> switch (short 'f' <> long "force" <> help "Force update") + <*> switch + (long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)") ) <**> helper ) (progDesc "Upgrade ghcup") ) -#endif <> command "compile" ( Compile diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index 8578228..bceb4dc 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -59,15 +59,16 @@ data UpgradeOpts = UpgradeInplace --[ Parsers ]-- --------------- - + upgradeOptsP :: Parser UpgradeOpts upgradeOptsP = flag' UpgradeInplace (short 'i' <> long "inplace" <> help - "Upgrade ghcup in-place (wherever it's at)" + "Upgrade ghcup in-place" ) - <|> ( UpgradeAt + <|> + ( UpgradeAt <$> option str (short 't' <> long "target" <> metavar "TARGET_DIR" <> help @@ -92,6 +93,7 @@ type UpgradeEffects = '[ DigestError , FileDoesNotExistError , CopyError , DownloadFailed + , GHCupShadowed ] @@ -120,18 +122,19 @@ upgrade :: ( Monad m ) => UpgradeOpts -> Bool + -> Bool -> Dirs -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -upgrade uOpts force' Dirs{..} runAppState runLogger = do +upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do target <- case uOpts of UpgradeInplace -> Just <$> liftIO getExecutablePath (UpgradeAt p) -> pure $ Just p UpgradeGHCupDir -> pure (Just (binDir "ghcup" <> exeExt)) runUpgrade runAppState (do - v' <- liftE $ upgradeGHCup target force' + v' <- liftE $ upgradeGHCup target force' fatal GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (v', dls) ) >>= \case diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c52b066..2dd0f6e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -141,9 +141,7 @@ main = do ) let listCommands = infoOption ("install set rm install-cabal list" -#ifndef DISABLE_UPGRADE <> " upgrade" -#endif <> " compile debug-info tool-requirements changelog" ) ( long "list-commands" @@ -245,14 +243,10 @@ Report bugs at |] alreadyInstalling' <- alreadyInstalling optCommand newTool when (not alreadyInstalling') $ case t of -#ifdef DISABLE_UPGRADE - GHCup -> pure () -#else GHCup -> runLogger $ logWarn ("New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'") -#endif _ -> runLogger $ logWarn ("New " <> T.pack (prettyShow t) @@ -296,26 +290,24 @@ Report bugs at |] s' <- appState liftIO $ brickMain s' >> pure ExitSuccess #endif - Install installCommand -> install installCommand settings appState runLogger - InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger - Set setCommand -> set setCommand runAppState runLeanAppState runLogger - UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger - List lo -> list lo no_color runAppState - Rm rmCommand -> rm rmCommand runAppState runLogger - DInfo -> dinfo runAppState runLogger - Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger - Config configCommand -> config configCommand settings keybindings runLogger + Install installCommand -> install installCommand settings appState runLogger + InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger + Set setCommand -> set setCommand runAppState runLeanAppState runLogger + UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger + List lo -> list lo no_color runAppState + Rm rmCommand -> rm rmCommand runAppState runLogger + DInfo -> dinfo runAppState runLogger + Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger + Config configCommand -> config configCommand settings keybindings runLogger Whereis whereisOptions - whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger -#ifndef DISABLE_UPGRADE - Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger -#endif - ToolRequirements topts -> toolRequirements topts runAppState runLogger - ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger - Nuke -> nuke appState runLogger - Prefetch pfCom -> prefetch pfCom runAppState runLogger - GC gcOpts -> gc gcOpts runAppState runLogger - Run runCommand -> run runCommand appState leanAppstate runLogger + whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger + Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger + ToolRequirements topts -> toolRequirements topts runAppState runLogger + ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger + Nuke -> nuke appState runLogger + Prefetch pfCom -> prefetch pfCom runAppState runLogger + GC gcOpts -> gc gcOpts runAppState runLogger + Run runCommand -> run runCommand appState leanAppstate runLogger case res of ExitSuccess -> pure () @@ -353,9 +345,7 @@ Report bugs at |] (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver -#ifndef DISABLE_UPGRADE - alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True -#endif + alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True alreadyInstalling _ _ = pure False cmp' :: ( HasLog env diff --git a/docs/guide.md b/docs/guide.md index e54b754..9bfb949 100644 --- a/docs/guide.md +++ b/docs/guide.md @@ -57,6 +57,13 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro) and make sure your bashrc sources the startup script (`/usr/share/bash-completion/bash_completion` on some distros). +## Portability + +`ghcup` is very portable. There are a few exceptions though: + +1. `ghcup tui` is only available on non-windows platforms +2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future + # Configuration A configuration file can be put in `~/.ghcup/config.yaml`. The default config file diff --git a/ghcup.cabal b/ghcup.cabal index a0247f5..708b53d 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -48,13 +48,6 @@ flag no-exe default: False manual: True -flag disable-upgrade - description: - Disable upgrade functionality. This is mainly to support brew packagers. - - default: False - manual: True - library exposed-modules: GHCup @@ -204,6 +197,7 @@ executable ghcup GHCup.OptParse.Set GHCup.OptParse.ToolRequirements GHCup.OptParse.UnSet + GHCup.OptParse.Upgrade GHCup.OptParse.Whereis hs-source-dirs: app/ghcup @@ -277,11 +271,6 @@ executable ghcup if flag(no-exe) buildable: False - if flag(disable-upgrade) - cpp-options: -DDISABLE_UPGRADE - - else - other-modules: GHCup.OptParse.Upgrade test-suite ghcup-test type: exitcode-stdio-1.0 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 39f079a..b358b02 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -2587,6 +2587,7 @@ upgradeGHCup :: ( MonadMask m => Maybe FilePath -- ^ full file destination to write ghcup into -> Bool -- ^ whether to force update regardless -- of currently installed version + -> Bool -- ^ whether to throw an error if ghcup is shadowed -> Excepts '[ CopyError , DigestError @@ -2595,10 +2596,11 @@ upgradeGHCup :: ( MonadMask m , DownloadFailed , NoDownload , NoUpdate + , GHCupShadowed ] m Version -upgradeGHCup mtarget force' = do +upgradeGHCup mtarget force' fatal = do Dirs {..} <- lift getDirs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -2625,15 +2627,18 @@ upgradeGHCup mtarget force' = do lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup." liftIO (isShadowed destFile) >>= \case Nothing -> pure () - Just pa -> lift $ logWarn $ "ghcup is shadowed by " - <> T.pack pa - <> ". The upgrade will not be in effect, unless you remove " - <> T.pack pa - <> " or make sure " - <> T.pack destDir - <> " comes before " - <> T.pack (takeFileName pa) - <> " in PATH." + Just pa + | fatal -> throwE (GHCupShadowed pa destFile latestVer) + | otherwise -> + lift $ logWarn $ "ghcup is shadowed by " + <> T.pack pa + <> ". The upgrade will not be in effect, unless you remove " + <> T.pack pa + <> " or make sure " + <> T.pack destDir + <> " comes before " + <> T.pack (takeDirectory pa) + <> " in PATH." pure latestVer diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 4d8b183..df72bd2 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -27,6 +27,7 @@ import Data.CaseInsensitive ( CI ) import Data.Text ( Text ) import Data.Versions import Haskus.Utils.Variant +import System.FilePath import Text.PrettyPrint hiding ( (<>) ) import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import URI.ByteString @@ -291,6 +292,24 @@ instance Pretty HadrianNotFound where pPrint HadrianNotFound = text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" +data GHCupShadowed = GHCupShadowed + FilePath -- shadow binary + FilePath -- upgraded binary + Version -- upgraded version + deriving Show + +instance Pretty GHCupShadowed where + pPrint (GHCupShadowed sh up _) = + text ("ghcup is shadowed by " + <> sh + <> ". The upgrade will not be in effect, unless you remove " + <> sh + <> " or make sure " + <> takeDirectory up + <> " comes before " + <> takeDirectory sh + <> " in PATH." + ) ------------------------- --[ High-level errors ]--