diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for ghcup +## 0.1.17.8 -- XXXX-XX-XX + +* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361) + - this also fixes a significant bug on installation failure when combining `--isolate DIR` with `--force` +* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353) +* Re-enable upgrade functionality for all configurations wrt [#250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250) + +## 0.1.17.7 -- 2022-04-21 + +* Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345) + ## 0.1.17.6 -- 2022-03-18 * Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -437,6 +437,7 @@ , TarDirDoesNotExist , FileAlreadyExistsError , ProcessError + , GHCupShadowed ] run (do @@ -446,19 +447,19 @@ case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls - liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce) + liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce) Cabal -> do let vi = getVersionInfo lVer Cabal dls - liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce) + liftE $ installCabalBin lVer GHCupInternal 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) + liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) Stack -> do let vi = getVersionInfo lVer Stack dls - liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce) + liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) ) >>= \case VRight (vi, Dirs{..}, Just ce) -> do diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs --- a/app/ghcup/GHCup/OptParse.hs +++ b/app/ghcup/GHCup/OptParse.hs @@ -96,7 +96,7 @@ | Config ConfigCommand | Whereis WhereisOptions WhereisCommand #ifndef DISABLE_UPGRADE - | Upgrade UpgradeOpts Bool + | Upgrade UpgradeOpts Bool Bool #endif | ToolRequirements ToolReqOpts | ChangeLog ChangeLogOptions @@ -222,18 +222,18 @@ (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/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -283,7 +283,7 @@ (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from" ) <*> - optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)" + optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)" <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"]) )) ))) @@ -469,7 +469,7 @@ ghcs jobs ovewrwiteVer - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) cabalProject cabalProjectLocal patches @@ -524,7 +524,7 @@ addConfArgs buildFlavour hadrian - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $ diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -216,10 +216,10 @@ Nothing -> False Just GHC -> False Just _ -> True - + -------------- --[ Footer ]-- -------------- @@ -395,7 +395,7 @@ (v, vi) <- liftE $ fromVersion instVer GHC void $ liftE $ sequenceE (installGHCBin (_tvVersion v) - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing @@ -406,7 +406,7 @@ void $ liftE $ sequenceE (installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (_tvVersion v) - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing @@ -467,7 +467,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal void $ liftE $ sequenceE (installCabalBin v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi @@ -477,7 +477,7 @@ void $ liftE $ sequenceE (installCabalBindist (DownloadInfo uri Nothing "") v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi @@ -518,7 +518,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS void $ liftE $ sequenceE (installHLSBin v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi @@ -529,7 +529,7 @@ void $ liftE $ sequenceE (installHLSBindist (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi @@ -578,7 +578,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack void $ liftE $ sequenceE (installStackBin v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi @@ -588,7 +588,7 @@ void $ liftE $ sequenceE (installStackBindist (DownloadInfo uri Nothing "") v - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -61,6 +61,7 @@ , runHLSVer :: Maybe ToolVersion , runStackVer :: Maybe ToolVersion , runBinDir :: Maybe FilePath + , runQuick :: Bool , runCOMMAND :: [String] } @@ -70,8 +71,8 @@ --[ Parsers ]-- --------------- - - + + runOpts :: Parser RunOptions runOpts = RunOptions @@ -121,6 +122,8 @@ <> completer (bashCompleter "directory") ) ) + <*> switch + (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.") <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits.")) @@ -219,29 +222,15 @@ -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode run RunOptions{..} runAppState leanAppstate runLogger = do - r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' + r <- if not runQuick then runRUN runAppState $ do toolchain <- liftE resolveToolchainFull - tmp <- case runBinDir of - Just bindir -> do - liftIO $ createDirRecursive' bindir - liftIO $ canonicalizePath bindir - Nothing -> do - d <- liftIO $ predictableTmpDir toolchain - liftIO $ createDirRecursive' d - liftIO $ canonicalizePath d + tmp <- liftIO $ createTmpDir toolchain liftE $ installToolChainFull toolchain tmp pure tmp else runLeanRUN leanAppstate $ do toolchain <- resolveToolchain - tmp <- case runBinDir of - Just bindir -> do - liftIO $ createDirRecursive' bindir - liftIO $ canonicalizePath bindir - Nothing -> do - d <- liftIO $ predictableTmpDir toolchain - liftIO $ createDirRecursive' d - liftIO $ canonicalizePath d + tmp <- liftIO $ createTmpDir toolchain liftE $ installToolChain toolchain tmp pure tmp case r of @@ -269,9 +258,16 @@ where - isToolTag :: ToolVersion -> Bool - isToolTag (ToolTag _) = True - isToolTag _ = False + createTmpDir :: Toolchain -> IO FilePath + createTmpDir toolchain = + case runBinDir of + Just bindir -> do + createDirRecursive' bindir + canonicalizePath bindir + Nothing -> do + d <- predictableTmpDir toolchain + createDirRecursive' d + canonicalizePath d -- TODO: doesn't work for cross resolveToolchainFull :: ( MonadFail m @@ -351,25 +347,25 @@ Just (GHC, v) -> do unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin (_tvVersion v) - Nothing + GHCupInternal False setTool GHC v tmp Just (Cabal, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin (_tvVersion v) - Nothing + GHCupInternal False setTool Cabal v tmp Just (Stack, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin (_tvVersion v) - Nothing + GHCupInternal False setTool Stack v tmp Just (HLS, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin (_tvVersion v) - Nothing + GHCupInternal False setTool HLS v tmp _ -> pure () diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -59,15 +59,16 @@ --[ 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 @@ , FileDoesNotExistError , CopyError , DownloadFailed + , GHCupShadowed ] @@ -120,18 +122,19 @@ ) => 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 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -141,9 +141,7 @@ ) 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 @@ 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 @@ 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 @@ (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/ghcup.cabal b/ghcup.cabal --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup -version: 0.1.17.6 +version: 0.1.17.8 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 @@ -48,13 +48,6 @@ 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 @@ GHCup.OptParse.Set GHCup.OptParse.ToolRequirements GHCup.OptParse.UnSet + GHCup.OptParse.Upgrade GHCup.OptParse.Whereis hs-source-dirs: app/ghcup @@ -277,11 +271,6 @@ 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 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -187,7 +187,7 @@ ) => DownloadInfo -- ^ where/how to download -> Version -- ^ the version to install - -> Maybe FilePath -- ^ isolated filepath if user passed any + -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled @@ -205,22 +205,22 @@ ] m () -installGHCBindist dlinfo ver isoFilepath forceInstall = do +installGHCBindist dlinfo ver installDir forceInstall = do let tver = mkTVer ver lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver - + if | not forceInstall , regularGHCInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled GHC ver | forceInstall , regularGHCInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed GHC version first!" liftE $ rmGHCVer tver @@ -229,18 +229,19 @@ -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing - -- prepare paths - ghcdir <- lift $ ghcupGHCDir tver toolchainSanityChecks - case isoFilepath of - Just isoDir -> do -- isolated install + case installDir of + IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall - Nothing -> do -- regular install - liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + -- prepare paths + ghcdir <- lift $ ghcupGHCDir tver + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall + -- make symlinks & stuff when regular install, liftE $ postGHCInstall tver @@ -271,7 +272,7 @@ ) => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive - -> FilePath -- ^ Path to install to + -> InstallDirResolved -> Version -- ^ The GHC version -> Bool -- ^ Force install -> Excepts @@ -297,9 +298,13 @@ workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) msubdir - + liftE $ runBuildAction tmpUnpack - (Just inst) + (case inst of + IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other + -- user files if '--force' is supplied + GHCupDir d -> Just d + ) (installUnpackedGHC workdir inst ver) @@ -315,11 +320,11 @@ , MonadUnliftIO m , MonadMask m ) - => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) - -> FilePath -- ^ Path to install to - -> Version -- ^ The GHC version + => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) + -> InstallDirResolved -- ^ Path to install to + -> Version -- ^ The GHC version -> Excepts '[ProcessError] m () -installUnpackedGHC path inst ver +installUnpackedGHC path (fromInstallDir -> inst) ver | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need @@ -340,7 +345,7 @@ lift $ logInfo "Installing GHC (this may take a while)" lEM $ execLogged "sh" - ("./configure" : ("--prefix=" <> inst) + ("./configure" : ("--prefix=" <> inst) : alpineArgs ) (Just path) @@ -369,7 +374,7 @@ , MonadUnliftIO m ) => Version -- ^ the version to install - -> Maybe FilePath -- ^ isolated install filepath, if user passed any + -> InstallDir -> Bool -- ^ force install -> Excepts '[ AlreadyInstalled @@ -387,9 +392,9 @@ ] m () -installGHCBin ver isoFilepath forceInstall = do +installGHCBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo GHC ver - liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall + liftE $ installGHCBindist dlinfo ver installDir forceInstall -- | Like 'installCabalBin', except takes the 'DownloadInfo' as @@ -408,8 +413,8 @@ ) => DownloadInfo -> Version - -> Maybe FilePath -- ^ isolated install filepath, if user provides any. - -> Bool -- ^ Force install + -> InstallDir + -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled , CopyError @@ -425,7 +430,7 @@ ] m () -installCabalBindist dlinfo ver isoFilepath forceInstall = do +installCabalBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq @@ -437,18 +442,18 @@ if | not forceInstall , regularCabalInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled Cabal ver - + | forceInstall , regularCabalInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed version first!" liftE $ rmCabalVer ver | otherwise -> pure () - + -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -460,34 +465,37 @@ -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - case isoFilepath of - Just isoDir -> do -- isolated install + case installDir of + IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir - liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall + liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - Nothing -> do -- regular install - liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall + GHCupInternal -> do -- regular install + liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall - + -- | Install an unpacked cabal distribution.Symbol installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Maybe Version -- ^ Nothing for isolated install + -> InstallDirResolved -- ^ Path to install to + -> Version -> Bool -- ^ Force Install -> Excepts '[CopyError, FileAlreadyExistsError] m () -installCabalUnpacked path inst mver' forceInstall = do +installCabalUnpacked path inst ver forceInstall = do lift $ logInfo "Installing cabal" let cabalFile = "cabal" - liftIO $ createDirRecursive' inst + liftIO $ createDirRecursive' (fromInstallDir inst) let destFileName = cabalFile - <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' + <> (case inst of + IsolateDirResolved _ -> "" + GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) <> exeExt - let destPath = inst destFileName + let destPath = fromInstallDir inst destFileName unless forceInstall -- Overwrite it when it IS a force install (liftE $ throwIfFileAlreadyExists destPath) - + copyFileE (path cabalFile <> exeExt) destPath @@ -510,7 +518,7 @@ , MonadFail m ) => Version - -> Maybe FilePath -- isolated install Path, if user provided any + -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled @@ -527,9 +535,9 @@ ] m () -installCabalBin ver isoFilepath forceInstall = do +installCabalBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver isoFilepath forceInstall + installCabalBindist dlinfo ver installDir forceInstall -- | Like 'installHLSBin, except takes the 'DownloadInfo' as @@ -548,8 +556,8 @@ ) => DownloadInfo -> Version - -> Maybe FilePath -- ^ isolated install path, if user passed any - -> Bool -- ^ Force install + -> InstallDir -- ^ isolated install path, if user passed any + -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled , CopyError @@ -567,7 +575,7 @@ ] m () -installHLSBindist dlinfo ver isoFilepath forceInstall = do +installHLSBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install hls version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq @@ -578,17 +586,17 @@ if | not forceInstall , regularHLSInstalled - , Nothing <- isoFilepath -> do -- regular install + , GHCupInternal <- installDir -> do -- regular install throwE $ AlreadyInstalled HLS ver | forceInstall , regularHLSInstalled - , Nothing <- isoFilepath -> do -- regular forced install + , GHCupInternal <- installDir -> do -- regular forced install lift $ logInfo "Removing the currently installed version of HLS before force installing!" liftE $ rmHLSVer ver | otherwise -> pure () - + -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -604,22 +612,23 @@ if | not forceInstall , not legacy - , (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp + , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) | otherwise -> pure () - case isoFilepath of - Just isoDir -> do + case installDir of + IsolateDir isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir if legacy - then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall - else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver + then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall + else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver - Nothing -> do + GHCupInternal -> do if legacy - then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall + then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall else do inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver + liftE $ runBuildAction tmpUnpack (Just inst) + $ installHLSUnpacked workdir (GHCupDir inst) ver liftE $ setHLS ver SetHLS_XYZ Nothing @@ -631,10 +640,10 @@ -- | Install an unpacked hls distribution. installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> FilePath -- ^ Path to install to + -> InstallDirResolved -- ^ Path to install to -> Version -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () -installHLSUnpacked path inst _ = do +installHLSUnpacked path (fromInstallDir -> inst) _ = do lift $ logInfo "Installing HLS" liftIO $ createDirRecursive' inst lEM $ make ["PREFIX=" <> inst, "install"] (Just path) @@ -642,13 +651,13 @@ -- | Install an unpacked hls distribution (legacy). installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Maybe Version -- ^ Nothing for isolated install + -> InstallDirResolved -- ^ Path to install to + -> Version -> Bool -- ^ is it a force install -> Excepts '[CopyError, FileAlreadyExistsError] m () -installHLSUnpackedLegacy path inst mver' forceInstall = do +installHLSUnpackedLegacy path installDir ver forceInstall = do lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' inst + liftIO $ createDirRecursive' (fromInstallDir installDir) -- install haskell-language-server- bins@(_:_) <- liftIO $ findFiles @@ -659,15 +668,18 @@ ) forM_ bins $ \f -> do let toF = dropSuffix exeExt f - <> maybe "" (("~" <>) . T.unpack . prettyVer) mver' + <> (case installDir of + IsolateDirResolved _ -> "" + GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver + ) <> exeExt let srcPath = path f - let destPath = inst toF + let destPath = fromInstallDir installDir toF unless forceInstall -- if it is a force install, overwrite it. (liftE $ throwIfFileAlreadyExists destPath) - + copyFileE srcPath destPath @@ -676,18 +688,21 @@ -- install haskell-language-server-wrapper let wrapper = "haskell-language-server-wrapper" toF = wrapper - <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' + <> (case installDir of + IsolateDirResolved _ -> "" + GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) <> exeExt srcWrapperPath = path wrapper <> exeExt - destWrapperPath = inst toF + destWrapperPath = fromInstallDir installDir toF unless forceInstall (liftE $ throwIfFileAlreadyExists destWrapperPath) - + copyFileE srcWrapperPath destWrapperPath - + lift $ chmod_755 destWrapperPath @@ -708,7 +723,7 @@ , MonadFail m ) => Version - -> Maybe FilePath -- isolated install Dir (if any) + -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled @@ -727,9 +742,9 @@ ] m () -installHLSBin ver isoFilepath forceInstall = do +installHLSBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver isoFilepath forceInstall + installHLSBindist dlinfo ver installDir forceInstall compileHLS :: ( MonadMask m @@ -749,7 +764,7 @@ -> [Version] -> Maybe Int -> Maybe Version - -> Maybe FilePath + -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Maybe (Either FilePath [URI]) -- ^ patches @@ -764,7 +779,7 @@ , BuildFailed , NotInstalled ] m Version -compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do +compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo Dirs { .. } <- lift getDirs @@ -805,7 +820,7 @@ , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1" @@ -837,8 +852,8 @@ workdir Nothing (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do - let installDir = workdir "out" - liftIO $ createDirRecursive' installDir + let tmpInstallDir = workdir "out" + liftIO $ createDirRecursive' tmpInstallDir -- apply patches liftE $ applyAnyPatch patches workdir @@ -861,8 +876,8 @@ cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False copyFileE cpl (workdir cp <.> "local") artifacts <- forM (sort ghcs) $ \ghc -> do - let ghcInstallDir = installDir T.unpack (prettyVer ghc) - liftIO $ createDirRecursive' installDir + let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) + liftIO $ createDirRecursive' tmpInstallDir lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc liftE $ lEM @_ @'[ProcessError] $ execLogged "cabal" ( [ "v2-install" @@ -885,17 +900,17 @@ forM_ artifacts $ \artifact -> do liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) - (installDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) + (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) - (installDir "haskell-language-server-wrapper" <.> exeExt) + (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) liftIO $ rmPathForcibly artifact - case isolateDir of - Just isoDir -> do + case installDir of + IsolateDir isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True - Nothing -> do - liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True + liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True + GHCupInternal -> do + liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True ) pure installVer @@ -919,7 +934,7 @@ , MonadFail m ) => Version - -> Maybe FilePath -- ^ isolate install Dir (if any) + -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled @@ -936,9 +951,9 @@ ] m () -installStackBin ver isoFilepath forceInstall = do +installStackBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver isoFilepath forceInstall + installStackBindist dlinfo ver installDir forceInstall -- | Like 'installStackBin', except takes the 'DownloadInfo' as @@ -957,7 +972,7 @@ ) => DownloadInfo -> Version - -> Maybe FilePath -- ^ isolate install Dir (if any) + -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled @@ -974,7 +989,7 @@ ] m () -installStackBindist dlinfo ver isoFilepath forceInstall = do +installStackBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install stack version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq @@ -985,12 +1000,12 @@ if | not forceInstall , regularStackInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled Stack ver | forceInstall , regularStackInstalled - , Nothing <- isoFilepath -> do + , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed version of Stack first!" liftE $ rmStackVer ver @@ -1007,33 +1022,36 @@ -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - case isoFilepath of - Just isoDir -> do -- isolated install + case installDir of + IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir - liftE $ installStackUnpacked workdir isoDir Nothing forceInstall - Nothing -> do -- regular install - liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall + liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall -- | Install an unpacked stack distribution. installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Maybe Version -- ^ Nothing for isolated installs + -> InstallDirResolved + -> Version -> Bool -- ^ Force install -> Excepts '[CopyError, FileAlreadyExistsError] m () -installStackUnpacked path inst mver' forceInstall = do +installStackUnpacked path installDir ver forceInstall = do lift $ logInfo "Installing stack" let stackFile = "stack" - liftIO $ createDirRecursive' inst + liftIO $ createDirRecursive' (fromInstallDir installDir) let destFileName = stackFile - <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' + <> (case installDir of + IsolateDirResolved _ -> "" + GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) <> exeExt - destPath = inst destFileName + destPath = fromInstallDir installDir destFileName unless forceInstall (liftE $ throwIfFileAlreadyExists destPath) - + copyFileE (path stackFile <> exeExt) destPath @@ -1099,7 +1117,7 @@ SetGHC_XY -> do handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ do + $ do (mj, mi) <- getMajorMinorV (_tvVersion ver) let major' = intToText mj <> "." <> intToText mi pure $ Just (file <> "-" <> T.unpack major') @@ -1223,7 +1241,7 @@ , MonadUnliftIO m ) => Version - -> SetHLS -- Nothing for legacy + -> SetHLS -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin -- and don't want mess with other versions -> Excepts '[NotInstalled] m () @@ -1357,7 +1375,7 @@ "Haskell IDE support may not work until this is fixed." <> "\n" <> "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> T.pack (prettyShow supportedGHC) - + _ -> return () ------------------ @@ -1962,7 +1980,7 @@ handleRm $ rmEnvFile envFilePath handleRm $ rmConfFile confFilePath - + -- for xdg dirs, the order matters here handleRm $ rmDir logsDir handleRm $ rmDir cacheDir @@ -2036,8 +2054,8 @@ cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) forM_ cs removeEmptyDirsRecursive hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp - + -- we expect only files inside cache/log dir -- we report remaining files/dirs later, -- hence the force/quiet mode in these delete functions below. @@ -2121,7 +2139,7 @@ -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool - -> Maybe FilePath -- ^ isolate dir + -> InstallDir -> Excepts '[ AlreadyInstalled , BuildFailed @@ -2146,7 +2164,7 @@ ] m GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir +compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -2187,7 +2205,7 @@ , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1" @@ -2219,18 +2237,18 @@ alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) when alreadyInstalled $ do - case isolateDir of - Just isoDir -> + case installDir of + IsolateDir isoDir -> lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir - Nothing -> + GHCupInternal -> lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." lift $ logWarn "...waiting for 10 seconds before continuing, you can still abort..." liftIO $ threadDelay 10000000 -- give the user a sec to intervene - ghcdir <- case isolateDir of - Just isoDir -> pure isoDir - Nothing -> lift $ ghcupGHCDir installVer + ghcdir <- case installDir of + IsolateDir isoDir -> pure $ IsolateDirResolved isoDir + GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) (mBindist, bmk) <- liftE $ runBuildAction tmpUnpack @@ -2243,13 +2261,13 @@ pure (b, bmk) ) - case isolateDir of - Nothing -> + case installDir of + GHCupInternal -> -- only remove old ghc in regular installs when alreadyInstalled $ do lift $ logInfo "Deleting existing installation" liftE $ rmGHCVer installVer - + _ -> pure () forM_ mBindist $ \bindist -> do @@ -2259,21 +2277,21 @@ (installVer ^. tvVersion) False -- not a force install, since we already overwrite when compiling. - liftIO $ B.writeFile (ghcdir ghcUpSrcBuiltFile) bmk - - case isolateDir of + liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk + + case installDir of -- set and make symlinks for regular (non-isolated) installs - Nothing -> do + GHCupInternal -> do reThrowAll GHCupSetError $ postGHCInstall installVer -- restore when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing - + _ -> pure () pure installVer where - defaultConf = + defaultConf = let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) in case targetGhc of @@ -2292,7 +2310,7 @@ ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound @@ -2351,7 +2369,7 @@ ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound @@ -2486,7 +2504,7 @@ ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , InvalidBuildConfig @@ -2497,7 +2515,7 @@ ] m () - configureBindist tver workdir ghcdir = do + configureBindist tver workdir (fromInstallDir -> ghcdir) = do lift $ logInfo [s|configuring build|] if | _tvVersion tver >= [vver|8.8.0|] -> do @@ -2587,6 +2605,7 @@ => 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,15 +2614,16 @@ , DownloadFailed , NoDownload , NoUpdate + , GHCupShadowed ] m Version -upgradeGHCup mtarget force' = do +upgradeGHCup mtarget force' fatal = do Dirs {..} <- lift getDirs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ logInfo "Upgrading GHCup..." - let latestVer = fromJust $ fst <$> getLatest dls GHCup + let latestVer = fst (fromJust (getLatest dls GHCup)) (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate dli <- liftE $ getDownloadInfo GHCup latestVer @@ -2625,15 +2645,18 @@ 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 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -27,6 +27,7 @@ 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 @@ 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 ]-- diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -628,3 +628,16 @@ deriving (Eq, Show) makeLenses ''CapturedProcess + + +data InstallDir = IsolateDir FilePath + | GHCupInternal + deriving (Eq, Show) + +data InstallDirResolved = IsolateDirResolved FilePath + | GHCupDir FilePath + deriving (Eq, Show) + +fromInstallDir :: InstallDirResolved -> FilePath +fromInstallDir (IsolateDirResolved fp) = fp +fromInstallDir (GHCupDir fp) = fp diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -317,10 +317,10 @@ MP.setInput rest pure x ) - <* pathSep + <* MP.some pathSep <* MP.takeRest <* MP.eof - ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep + ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. @@ -398,10 +398,10 @@ cabalParse = MP.chunk "cabal-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" - stripPathComponet = parseUntil1 pathSep *> pathSep + stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" - stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet) + stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) @@ -492,10 +492,10 @@ cabalParse = MP.chunk "stack-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" - stripPathComponet = parseUntil1 pathSep *> pathSep + stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" - stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet) + stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) @@ -543,10 +543,10 @@ cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" - stripPathComponet = parseUntil1 pathSep *> pathSep + stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" - stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet) + stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) @@ -1265,9 +1265,10 @@ installDestSanityCheck :: ( MonadIO m , MonadCatch m ) => - FilePath -> + InstallDirResolved -> Excepts '[DirNotEmpty] m () -installDestSanityCheck isoDir = do +installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do contents <- liftIO $ getDirectoryContentsRecursive isoDir unless (null contents) (throwE $ DirNotEmpty isoDir) +installDestSanityCheck _ = pure () diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -109,3 +109,10 @@ checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool checkFileAlreadyExists fp = liftIO $ doesFileExist fp + + +mergeFileTree :: [FilePath] -> FilePath -> IO () +mergeFileTree source dest = + + + diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -473,7 +473,7 @@ liftIO (moveFile fp dest) `catch` (\e -> if | isDoesNotExistError e -> pure () - | isPermissionError e {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) + | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) | otherwise -> throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) @@ -515,7 +515,7 @@ let dest = tmp takeFileName fp liftIO (moveFile fp dest) `catch` - (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) + (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) | otherwise = liftIO $ removeFile fp