From 991e540c11fd25758529ea277d3d61918162b0b1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 11 May 2022 15:47:08 +0200 Subject: [PATCH 1/4] Refactor code around isolateDirs, so we have proper knowledge --- app/ghcup/BrickMain.hs | 8 +- app/ghcup/GHCup/OptParse/Compile.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 18 +- app/ghcup/GHCup/OptParse/Run.hs | 8 +- lib/GHCup.hs | 289 +++++++++++++++------------- lib/GHCup/Types.hs | 13 ++ lib/GHCup/Utils.hs | 5 +- 7 files changed, 188 insertions(+), 157 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index fe2bf2a..d77b136 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -446,19 +446,19 @@ install' _ (_, ListResult {..}) = do 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) 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/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index a086b04..4d72224 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -469,7 +469,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do ghcs jobs ovewrwiteVer - isolateDir + (maybe GHCupInternal IsolateDir isolateDir) cabalProject cabalProjectLocal patches @@ -524,7 +524,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do 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 index 5f479fb..13b8257 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -216,7 +216,7 @@ installOpts tool = Nothing -> False Just GHC -> False Just _ -> True - + @@ -395,7 +395,7 @@ install installCommand settings getAppState' runLogger = case installCommand of (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 @@ install installCommand settings getAppState' runLogger = case installCommand of 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 @@ install installCommand settings getAppState' runLogger = case installCommand of (_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 @@ install installCommand settings getAppState' runLogger = case installCommand of 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 @@ install installCommand settings getAppState' runLogger = case installCommand of (_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 @@ install installCommand settings getAppState' runLogger = case installCommand of 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 @@ install installCommand settings getAppState' runLogger = case installCommand of (_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 @@ install installCommand settings getAppState' runLogger = case installCommand of 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 index 5e4532f..4d02620 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -351,25 +351,25 @@ run RunOptions{..} runAppState leanAppstate runLogger = do 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/lib/GHCup.hs b/lib/GHCup.hs index 39f079a..2b28d5e 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -187,7 +187,7 @@ installGHCBindist :: ( MonadFail m ) => 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 @@ installGHCBindist :: ( MonadFail m ] 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,17 +229,18 @@ installGHCBindist dlinfo ver isoFilepath forceInstall = do -- 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 @@ installPackedGHC :: ( MonadMask m ) => 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 @@ installPackedGHC dl msubdir inst ver forceInstall = do 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 @@ installUnpackedGHC :: ( MonadReader env m , 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 @@ installUnpackedGHC path inst ver 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 @@ installGHCBin :: ( MonadFail m , 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 @@ installGHCBin :: ( MonadFail m ] 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 @@ installCabalBindist :: ( MonadMask m ) => 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 @@ installCabalBindist :: ( MonadMask m ] 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 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do 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 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do -- 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 + + GHCupInternal -> do -- regular install + liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall - Nothing -> do -- regular install - liftE $ installCabalUnpacked workdir binDir (Just 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 @@ installCabalBin :: ( MonadMask m , MonadFail m ) => Version - -> Maybe FilePath -- isolated install Path, if user provided any + -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled @@ -527,9 +535,9 @@ installCabalBin :: ( MonadMask m ] 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 @@ installHLSBindist :: ( MonadMask m ) => 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 @@ installHLSBindist :: ( MonadMask m ] 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 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do 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,22 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do 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 Nothing $ installHLSUnpacked workdir (GHCupDir inst) ver liftE $ setHLS ver SetHLS_XYZ Nothing @@ -631,10 +639,10 @@ isLegacyHLSBindist path = do -- | 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 +650,13 @@ installHLSUnpacked path inst _ = do -- | 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 +667,18 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do ) 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 +687,21 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do -- 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 +722,7 @@ installHLSBin :: ( MonadMask m , MonadFail m ) => Version - -> Maybe FilePath -- isolated install Dir (if any) + -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled @@ -727,9 +741,9 @@ installHLSBin :: ( MonadMask m ] 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 +763,7 @@ compileHLS :: ( MonadMask m -> [Version] -> Maybe Int -> Maybe Version - -> Maybe FilePath + -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Maybe (Either FilePath [URI]) -- ^ patches @@ -764,7 +778,7 @@ compileHLS :: ( MonadMask m , 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 +819,7 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1" @@ -837,8 +851,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc 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 +875,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc 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 +899,17 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc 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 +933,7 @@ installStackBin :: ( MonadMask m , MonadFail m ) => Version - -> Maybe FilePath -- ^ isolate install Dir (if any) + -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled @@ -936,9 +950,9 @@ installStackBin :: ( MonadMask m ] 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 +971,7 @@ installStackBindist :: ( MonadMask m ) => DownloadInfo -> Version - -> Maybe FilePath -- ^ isolate install Dir (if any) + -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled @@ -974,7 +988,7 @@ installStackBindist :: ( MonadMask m ] 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 +999,12 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do 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 +1021,36 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do -- 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 +1116,7 @@ setGHC ver sghc mBinDir = do 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 +1240,7 @@ setHLS :: ( MonadReader env m , 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 +1374,7 @@ warnAboutHlsCompatibility = do "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 +1979,7 @@ rmGhcupDirs = do handleRm $ rmEnvFile envFilePath handleRm $ rmConfFile confFilePath - + -- for xdg dirs, the order matters here handleRm $ rmDir logsDir handleRm $ rmDir cacheDir @@ -2036,7 +2053,7 @@ rmGhcupDirs = do 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, @@ -2121,7 +2138,7 @@ compileGHC :: ( MonadMask m -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool - -> Maybe FilePath -- ^ isolate dir + -> InstallDir -> Excepts '[ AlreadyInstalled , BuildFailed @@ -2146,7 +2163,7 @@ compileGHC :: ( MonadMask m ] 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 +2204,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1" @@ -2219,18 +2236,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr 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 +2260,13 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr 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 +2276,21 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr (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 +2309,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound @@ -2351,7 +2368,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound @@ -2486,7 +2503,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr ) => GHCTargetVersion -> FilePath - -> FilePath + -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , InvalidBuildConfig @@ -2497,7 +2514,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr ] 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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index cab0858..93b985e 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -628,3 +628,16 @@ data CapturedProcess = CapturedProcess 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 index 5945f0b..e142cc9 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1265,9 +1265,10 @@ ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt) 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 () From 5130cb013b5fffc3e8f46bbb5dbdfc27b35d529d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 11 May 2022 15:57:14 +0200 Subject: [PATCH 2/4] Fix HLS not cleaning up after failed install, fix #361 --- lib/GHCup.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 2b28d5e..80e8e98 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -627,7 +627,8 @@ installHLSBindist dlinfo ver installDir forceInstall = do then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall else do inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (GHCupDir inst) ver + liftE $ runBuildAction tmpUnpack (Just inst) + $ installHLSUnpacked workdir (GHCupDir inst) ver liftE $ setHLS ver SetHLS_XYZ Nothing From c733810fdcdf31aa9c86640102c9d1d62d8359e9 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 11 May 2022 16:02:59 +0200 Subject: [PATCH 3/4] Bump version to 0.1.17.8 --- CHANGELOG.md | 6 ++++++ ghcup.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8065df8..8443f90 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # 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) + ## 0.1.17.7 -- 2022-04-21 * Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345) diff --git a/ghcup.cabal b/ghcup.cabal index a0247f5..196977a 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup -version: 0.1.17.7 +version: 0.1.17.8 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 From ee778e11779389801096e1c1d6501feb4b210803 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 11 May 2022 18:35:17 +0200 Subject: [PATCH 4/4] Print bindir --- .gitlab/script/ghcup_version.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index f462656..5ea008f 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -176,6 +176,8 @@ else [ "$(ghc --numeric-version)" = "${ghc_ver}" ] + ls -lah "$GHCUP_BIN" + if [ "${OS}" = "DARWIN" ] ; then eghcup install hls $(eghcup whereis hls) --version