From e2daf5381c15b09faf8871b66b025d5b3cf199de Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 20 Jul 2021 22:05:01 +0530 Subject: [PATCH 01/60] adds basic --isolate option structure for install commands --- app/ghcup/Main.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 30459f1..6468f59 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -137,6 +137,7 @@ data InstallOptions = InstallOptions , instPlatform :: Maybe PlatformRequest , instBindist :: Maybe URI , instSet :: Bool + , isolateDir :: Maybe FilePath } data SetCommand = SetGHC SetOptions @@ -571,7 +572,7 @@ Examples: installOpts :: Maybe Tool -> Parser InstallOptions installOpts tool = - (\p (u, v) b -> InstallOptions v p u b) + (\p (u, v) b is -> InstallOptions v p u b is) <$> optional (option (eitherReader platformParser) @@ -600,6 +601,15 @@ installOpts tool = (long "set" <> help "Set as active version after install" ) + <*> optional + (option + (eitherReader isolateParser) + ( short 'i' + <> long "isolate" + <> metavar "DIR" + <> help "install in an isolated dir instead of the default one" + ) + ) setParser :: Parser (Either SetCommand SetOptions) @@ -1201,6 +1211,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of bindistParser :: String -> Either String URI bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString +isolateParser :: FilePath -> Either String FilePath +isolateParser f = case isValid f of + True -> Right $ normalise f + False -> Left "Please enter a valid filepath for isolate dir." toSettings :: Options -> IO (Settings, KeyBindings) toSettings options = do From 9b3d55a0950a97a51588d82f98d36b930d2a63e7 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Thu, 22 Jul 2021 19:32:56 +0530 Subject: [PATCH 02/60] adds rudimentary isolate capability to ghcup install ghc command --- app/ghcup/Main.hs | 33 ++++++++++++++++++++------------- lib/GHCup.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 6468f59..f5ba12c 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1601,22 +1601,29 @@ Report bugs at |] ----------------------- let installGHC InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBin (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi - Just uri -> do - s' <- liftIO appState - runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + let ghcVersion = _tvVersion v + liftE $ installGHCBinIsolated isoDir ghcVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") - (_tvVersion v) + liftE $ installGHCBin (_tvVersion v) when instSet $ void $ liftE $ setGHC v SetGHCOnly pure vi - ) + Just uri -> do + s' <- liftIO appState + runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + ) >>= \case VRight vi -> do runLogger $ $(logInfo) "GHC installation successful" diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3628bd3..3f106f4 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -226,6 +226,49 @@ installGHCBindist dlinfo ver = do lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall." +-- | Installs GHC to a specified location, doesn't make any symlinks. +installGHCBinIsolated :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => FilePath + -> Version -- ^ the version to install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () + +installGHCBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo GHC ver + + lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + + -- | Install a packed GHC distribution. This only deals with unpacking and the GHC -- build system and nothing else. installPackedGHC :: ( MonadMask m From 8b7c22440e706de09bedf34d14a66154cf8b960f Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:51:56 +0530 Subject: [PATCH 03/60] factor out installCabal' from `installCabalBindist`, to be shared with `installCabalBinIsolated` function --- lib/GHCup.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3f106f4..750746c 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -470,22 +470,22 @@ installCabalBindist dlinfo ver = do let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver - where - -- | Install an unpacked cabal distribution. - installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installCabal' path inst = do - lift $ $(logInfo) "Installing cabal" - let cabalFile = "cabal" - liftIO $ createDirRecursive' inst - let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt - let destPath = inst destFileName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path cabalFile <> exeExt) - destPath - lift $ chmod_755 destPath +-- | Install an unpacked cabal distribution. +installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installCabal' path inst ver = do + lift $ $(logInfo) "Installing cabal" + let cabalFile = "cabal" + liftIO $ createDirRecursive' inst + let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt + let destPath = inst destFileName + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path cabalFile <> exeExt) + destPath + lift $ chmod_755 destPath -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and From 91d982c7b23ca3d0f8357e4f009c71efa2ad21f5 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:56:03 +0530 Subject: [PATCH 04/60] use the new factored out installCabal' in `installCabalBindist` function --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 750746c..fc30c5f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -463,7 +463,7 @@ installCabalBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installCabal' workdir binDir + liftE $ installCabal' workdir binDir ver -- create symlink if this is the latest version cVers <- lift $ fmap rights getInstalledCabals From 4729364e99fc9e96ce78ee0334344f5d240a8c93 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:57:42 +0530 Subject: [PATCH 05/60] Adds isolate install functionality to 'Cabal' tool installs --- app/ghcup/Main.hs | 34 +++++++++++++++++++------------ lib/GHCup.hs | 51 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f5ba12c..7b284dd 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1649,19 +1649,27 @@ Report bugs at |] let installCabal InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> + runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + let cabalVersion = (_tvVersion v) + liftE $ installCabalBinIsolated isoDir cabalVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index fc30c5f..a3c0930 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -487,6 +487,57 @@ installCabal' path inst ver = do destPath lift $ chmod_755 destPath +-- | Installs GHC to a specified location, doesn't make any symlinks. +installCabalBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installCabalBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo Cabal ver + lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabal' workdir isoDir ver + -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and -- creates a default @cabal -> cabal-x.y.z.q@ symlink for From 9686ee98268217a2692efa3f45b40fa899be9b0f Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:23:03 +0530 Subject: [PATCH 06/60] Factor out installHLS' --- lib/GHCup.hs | 55 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index a3c0930..9b08917 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -634,39 +634,38 @@ installHLSBindist dlinfo ver = do let lInstHLS = headMay . reverse . sort $ hlsVers when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver - where - -- | Install an unpacked hls distribution. - installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installHLS' path inst = do - lift $ $(logInfo) "Installing HLS" - liftIO $ createDirRecursive' inst +-- | Install an unpacked hls distribution. +installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installHLS' path inst ver = do + lift $ $(logInfo) "Installing HLS" + liftIO $ createDirRecursive' inst - -- install haskell-language-server- - bins@(_:_) <- liftIO $ findFiles - path - (makeRegexOpts compExtended - execBlank - ([s|^haskell-language-server-[0-9].*$|] :: ByteString) - ) - forM_ bins $ \f -> do - let toF = dropSuffix exeExt f - <> "~" <> T.unpack (prettyVer ver) <> exeExt - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path f) - (inst toF) - lift $ chmod_755 (inst toF) - - -- install haskell-language-server-wrapper - let wrapper = "haskell-language-server-wrapper" - toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt + -- install haskell-language-server- + bins@(_:_) <- liftIO $ findFiles + path + (makeRegexOpts compExtended + execBlank + ([s|^haskell-language-server-[0-9].*$|] :: ByteString) + ) + forM_ bins $ \f -> do + let toF = dropSuffix exeExt f + <> "~" <> T.unpack (prettyVer ver) <> exeExt handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path wrapper <> exeExt) + (path f) (inst toF) lift $ chmod_755 (inst toF) + -- install haskell-language-server-wrapper + let wrapper = "haskell-language-server-wrapper" + toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path wrapper <> exeExt) + (inst toF) + lift $ chmod_755 (inst toF) -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. From 63f10a187113ff8c266098c40ded9c271d662d62 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:23:52 +0530 Subject: [PATCH 07/60] update installHLS' usage in `installHLSBindist` --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 9b08917..4c04b41 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -627,7 +627,7 @@ installHLSBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installHLS' workdir binDir + liftE $ installHLS' workdir binDir ver -- create symlink if this is the latest version hlsVers <- lift $ fmap rights getInstalledHLSs From 9a79af6fd2015fdf62587a2fd135397ab1148a7b Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:25:01 +0530 Subject: [PATCH 08/60] Adds isolated install to HLS installs --- app/ghcup/Main.hs | 33 +++++++++++++++++----------- lib/GHCup.hs | 56 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7b284dd..0d6e6d6 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1688,19 +1688,26 @@ Report bugs at |] pure $ ExitFailure 4 let installHLS InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + let hlsVersion = (_tvVersion v) + liftE $ installHLSBinIsolated isoDir hlsVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4c04b41..50f30dd 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -667,6 +667,62 @@ installHLS' path inst ver = do (inst toF) lift $ chmod_755 (inst toF) +-- | Installs hls binaries in an isolated location provided by user, +-- doesn't make any symlinks + +installHLSBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installHLSBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo HLS ver + + lift $ $(logDebug) [i|Requested to install hls version #{ver}|] + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + + liftE $ installHLS' workdir isoDir ver + + -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m From 42d4a6649397a093bd9a7bd4d484af0e69769fc8 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:43:43 +0530 Subject: [PATCH 09/60] factor out installStack' function --- lib/GHCup.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 50f30dd..91d4cfc 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -854,23 +854,23 @@ installStackBindist dlinfo ver = do let lInstStack = headMay . reverse . sort $ sVers when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver - where - -- | Install an unpacked stack distribution. - installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installStack' path inst = do - lift $ $(logInfo) "Installing stack" - let stackFile = "stack" - liftIO $ createDirRecursive' inst - let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt - let destPath = inst destFileName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path stackFile <> exeExt) - destPath - lift $ chmod_755 destPath +-- | Install an unpacked stack distribution. +installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installStack' path inst ver = do + lift $ $(logInfo) "Installing stack" + let stackFile = "stack" + liftIO $ createDirRecursive' inst + let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt + let destPath = inst destFileName + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path stackFile <> exeExt) + destPath + lift $ chmod_755 destPath From 873f75da9f52c2b33230793aeae51db35396a4f2 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:44:40 +0530 Subject: [PATCH 10/60] updates installStack' usage in `installStackBindist` function --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 91d4cfc..d9f8509 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -847,7 +847,7 @@ installStackBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installStack' workdir binDir + liftE $ installStack' workdir binDir ver -- create symlink if this is the latest version sVers <- lift $ fmap rights getInstalledStacks From 511272e86d0725237332a9701779e0056169e460 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:46:11 +0530 Subject: [PATCH 11/60] Adds isolated installs to Stack install --- app/ghcup/Main.hs | 33 +++++++++++++++++------------ lib/GHCup.hs | 54 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 0d6e6d6..0e0f26f 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1726,19 +1726,26 @@ Report bugs at |] pure $ ExitFailure 4 let installStack InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + let stackVersion = (_tvVersion v) + liftE $ installStackBinIsolated isoDir stackVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d9f8509..559fcef 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -873,6 +873,60 @@ installStack' path inst ver = do lift $ chmod_755 destPath +-- | Installs stack into an isolated location sepcified by the user, +-- also, doesn't make any symlinks. + +installStackBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installStackBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo Stack ver + + lift $ $(logDebug) [i|Requested to install stack version #{ver}|] + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + + liftE $ installStack' workdir isoDir ver --------------------- --[ Set GHC/cabal ]-- From ba51cbad6fff049138d0cc7a24053fa348cf784d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:51:50 +0530 Subject: [PATCH 12/60] Adds a log to notify where the isolated ghc is being installed by the tool --- lib/GHCup.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 559fcef..52754e3 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -266,6 +266,8 @@ installGHCBinIsolated isoDir ver = do -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver From 338f5f309df109430ecdbc62e03db0646197f640 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:35:41 +0530 Subject: [PATCH 13/60] update `installGhcBindist` to take a "Maybe FilePath" to work with isolated installs --- lib/GHCup.hs | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 52754e3..0de2f92 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -183,6 +183,7 @@ installGHCBindist :: ( MonadFail m ) => DownloadInfo -- ^ where/how to download -> Version -- ^ the version to install + -> Maybe FilePath -- ^ isolated filepath if user passed any -> Excepts '[ AlreadyInstalled , BuildFailed @@ -198,10 +199,16 @@ installGHCBindist :: ( MonadFail m ] m () -installGHCBindist dlinfo ver = do +installGHCBindist dlinfo ver isoFilepath = do let tver = mkTVer ver + let isIsolatedInstall = isJust isoFilepath + + lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + + -- we only care for already installed errors in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -209,11 +216,21 @@ installGHCBindist dlinfo ver = do -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - toolchainSanityChecks - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver + let isoDir = if isIsolatedInstall + then fromJust isoFilepath + else mempty :: FilePath - liftE $ postGHCInstall tver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + else do + toolchainSanityChecks + liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver + + -- make symlinks & stuff when regular install, + -- don't make any for isolated installs. + whenM (pure $ not isIsolatedInstall) (liftE $ postGHCInstall tver) where toolchainSanityChecks = do From 5efe2e5f7aea38a6569ca6a6b3928540380844d8 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:38:32 +0530 Subject: [PATCH 14/60] updates usages of new installGHCBindist and related installGHCBin --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 38 ++++++++++++++++---------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 20 insertions(+), 25 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index ba6d8bc..497c2ba 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -448,7 +448,7 @@ install' _ (_, ListResult {..}) = do case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls - liftE $ installGHCBin lVer $> vi + liftE $ installGHCBin lVer Nothing $> vi Cabal -> do let vi = getVersionInfo lVer Cabal dls liftE $ installCabalBin lVer $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 0e0f26f..d5bb1c4 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1601,28 +1601,22 @@ Report bugs at |] ----------------------- let installGHC InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - let ghcVersion = _tvVersion v - liftE $ installGHCBinIsolated isoDir ghcVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBin (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi - Just uri -> do - s' <- liftIO appState - runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") - (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBin (_tvVersion v) isolateDir + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + Just uri -> do + s' <- liftIO appState + runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + isolateDir + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 0de2f92..5f86cad 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -405,6 +405,7 @@ installGHCBin :: ( MonadFail m , MonadUnliftIO m ) => Version -- ^ the version to install + -> Maybe FilePath -- ^ isolated install filepath, if user passed any -> Excepts '[ AlreadyInstalled , BuildFailed @@ -420,9 +421,9 @@ installGHCBin :: ( MonadFail m ] m () -installGHCBin ver = do +installGHCBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo GHC ver - installGHCBindist dlinfo ver + installGHCBindist dlinfo ver isoFilepath -- | Like 'installCabalBin', except takes the 'DownloadInfo' as From 4f7d41a8cc408f77393e8102ac9877e71aa80802 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:39:44 +0530 Subject: [PATCH 15/60] remove installGHCBinIsolated function. --- lib/GHCup.hs | 45 --------------------------------------------- 1 file changed, 45 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 5f86cad..75d37a6 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -243,51 +243,6 @@ installGHCBindist dlinfo ver isoFilepath = do lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall." --- | Installs GHC to a specified location, doesn't make any symlinks. -installGHCBinIsolated :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => FilePath - -> Version -- ^ the version to install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () - -installGHCBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo GHC ver - - lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver - - -- | Install a packed GHC distribution. This only deals with unpacking and the GHC -- build system and nothing else. installPackedGHC :: ( MonadMask m From b148d8e2e7649d7adcbc02c3af463f336c632a78 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:20:42 +0530 Subject: [PATCH 16/60] update `installCabalBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 75d37a6..12fa816 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -397,6 +397,7 @@ installCabalBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -- ^ isolated install filepath, if user provides any. -> Excepts '[ AlreadyInstalled , CopyError @@ -412,13 +413,17 @@ installCabalBindist :: ( MonadMask m ] m () -installCabalBindist dlinfo ver = do +installCabalBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM + let isIsolatedInstall = isJust isoFilepath + + -- check if cabal already installed in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && x) @@ -438,12 +443,21 @@ installCabalBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installCabal' workdir binDir ver + let isoDir = fromJust isoFilepath + + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabal' workdir isoDir ver + else do + liftE $ installCabal' workdir binDir ver -- create symlink if this is the latest version - cVers <- lift $ fmap rights getInstalledCabals - let lInstCabal = headMay . reverse . sort $ cVers - when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver + -- not applicable for isolated installs + whenM (pure $ not isIsolatedInstall) $ do + cVers <- lift $ fmap rights getInstalledCabals + let lInstCabal = headMay . reverse . sort $ cVers + when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) From bc6d006c578f85b8e1f6521a3c09fb5da7769874 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:24:50 +0530 Subject: [PATCH 17/60] updates usages of new `installCabalBindist` across files. --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 35 ++++++++++++++--------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 24 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 497c2ba..9fc9c7d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -451,7 +451,7 @@ install' _ (_, ListResult {..}) = do liftE $ installGHCBin lVer Nothing $> vi Cabal -> do let vi = getVersionInfo lVer Cabal dls - liftE $ installCabalBin lVer $> vi + liftE $ installCabalBin lVer Nothing $> vi GHCup -> do let vi = snd <$> getLatest dls GHCup liftE $ upgradeGHCup Nothing False $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d5bb1c4..a945b9a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1643,27 +1643,20 @@ Report bugs at |] let installCabal InstallOptions{..} = - (case isolateDir of - Just isoDir -> - runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - let cabalVersion = (_tvVersion v) - liftE $ installCabalBinIsolated isoDir cabalVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 12fa816..5e3d92f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -545,6 +545,7 @@ installCabalBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -- isolated install Path, if user provided any -> Excepts '[ AlreadyInstalled , CopyError @@ -560,9 +561,9 @@ installCabalBin :: ( MonadMask m ] m () -installCabalBin ver = do +installCabalBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver + installCabalBindist dlinfo ver isoFilepath -- | Like 'installHLSBin, except takes the 'DownloadInfo' as From 5995a8b5928a74b0566972947bbfe8e41a7fbe8c Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:25:27 +0530 Subject: [PATCH 18/60] Delete installCabalBinIsolated function. --- lib/GHCup.hs | 52 ---------------------------------------------------- 1 file changed, 52 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 5e3d92f..a0c1382 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -476,58 +476,6 @@ installCabal' path inst ver = do destPath lift $ chmod_755 destPath --- | Installs GHC to a specified location, doesn't make any symlinks. -installCabalBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installCabalBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo Cabal ver - lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabal' workdir isoDir ver - - -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and -- creates a default @cabal -> cabal-x.y.z.q@ symlink for -- the latest installed version. From e5d3080b54284d11d72184227afaa8be5cfd4d0c Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:08:32 +0530 Subject: [PATCH 19/60] update `installHLSBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index a0c1382..dd56d7b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -530,6 +530,7 @@ installHLSBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -- ^ isolated install path, if user passed any -> Excepts '[ AlreadyInstalled , CopyError @@ -545,13 +546,17 @@ installHLSBindist :: ( MonadMask m ] m () -installHLSBindist dlinfo ver = do +installHLSBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM (lift (hlsInstalled ver)) + let isIsolatedInstall = isJust isoFilepath + + -- we only check for already installed in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) -- download (or use cached version) @@ -564,13 +569,20 @@ installHLSBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + let isoDir = fromJust isoFilepath - liftE $ installHLS' workdir binDir ver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + liftE $ installHLS' workdir isoDir ver + else do + liftE $ installHLS' workdir binDir ver - -- create symlink if this is the latest version - hlsVers <- lift $ fmap rights getInstalledHLSs - let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver + -- create symlink if this is the latest version in a regular install + whenM (pure $ not isIsolatedInstall) $ do + hlsVers <- lift $ fmap rights getInstalledHLSs + let lInstHLS = headMay . reverse . sort $ hlsVers + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) From 9c22ba9d45b44e69962efef028efc56f29ea7235 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:10:10 +0530 Subject: [PATCH 20/60] updates usages of `installHLSBin` across files --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 34 ++++++++++++++-------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 23 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 9fc9c7d..93ff739 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -457,7 +457,7 @@ install' _ (_, ListResult {..}) = do liftE $ upgradeGHCup Nothing False $> vi HLS -> do let vi = getVersionInfo lVer HLS dls - liftE $ installHLSBin lVer $> vi + liftE $ installHLSBin lVer Nothing $> vi Stack -> do let vi = getVersionInfo lVer Stack dls liftE $ installStackBin lVer $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index a945b9a..3b2e7aa 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1675,26 +1675,20 @@ Report bugs at |] pure $ ExitFailure 4 let installHLS InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - let hlsVersion = (_tvVersion v) - liftE $ installHLSBinIsolated isoDir hlsVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index dd56d7b..f8b6b41 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -689,6 +689,7 @@ installHLSBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -704,9 +705,9 @@ installHLSBin :: ( MonadMask m ] m () -installHLSBin ver = do +installHLSBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver + installHLSBindist dlinfo ver isoFilepath -- | Installs stack into @~\/.ghcup\/bin/stack-\@ and From e9da8ab439f2b37938bfdf1cc592490f30009886 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:10:43 +0530 Subject: [PATCH 21/60] deletes `installHLSBinIsolated` function --- lib/GHCup.hs | 56 ---------------------------------------------------- 1 file changed, 56 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index f8b6b41..88ed583 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -617,62 +617,6 @@ installHLS' path inst ver = do (inst toF) lift $ chmod_755 (inst toF) --- | Installs hls binaries in an isolated location provided by user, --- doesn't make any symlinks - -installHLSBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installHLSBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo HLS ver - - lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - - liftE $ installHLS' workdir isoDir ver - - -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m From fd2add78bd3ab00bfc125bd122eeb5adff18611e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:23:58 +0530 Subject: [PATCH 22/60] update `installStackBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 88ed583..576084a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -707,6 +707,7 @@ installStackBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -722,13 +723,16 @@ installStackBindist :: ( MonadMask m ] m () -installStackBindist dlinfo ver = do +installStackBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM (lift (stackInstalled ver)) + let isIsolatedInstall = isJust isoFilepath + + when (not isIsolatedInstall) $ + whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) -- download (or use cached version) @@ -742,12 +746,20 @@ installStackBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installStack' workdir binDir ver + let isoDir = fromJust isoFilepath - -- create symlink if this is the latest version - sVers <- lift $ fmap rights getInstalledStacks - let lInstStack = headMay . reverse . sort $ sVers - when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + liftE $ installStack' workdir isoDir ver + else do + liftE $ installStack' workdir binDir ver + + -- create symlink if this is the latest version and a regular install + whenM (pure $ not isIsolatedInstall) $ do + sVers <- lift $ fmap rights getInstalledStacks + let lInstStack = headMay . reverse . sort $ sVers + when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver -- | Install an unpacked stack distribution. From 4e3dbea5d06a79aa4e11f40b2be5d4cf3557c89e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:24:38 +0530 Subject: [PATCH 23/60] updates usages of new `installStackBin` across files --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 34 ++++++++++++++-------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 23 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 93ff739..a320087 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -460,7 +460,7 @@ install' _ (_, ListResult {..}) = do liftE $ installHLSBin lVer Nothing $> vi Stack -> do let vi = getVersionInfo lVer Stack dls - liftE $ installStackBin lVer $> vi + liftE $ installStackBin lVer Nothing $> vi ) >>= \case VRight vi -> do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 3b2e7aa..34caac0 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1707,26 +1707,20 @@ Report bugs at |] pure $ ExitFailure 4 let installStack InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - let stackVersion = (_tvVersion v) - liftE $ installStackBinIsolated isoDir stackVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 576084a..d1e6a9e 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -671,6 +671,7 @@ installStackBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -686,9 +687,9 @@ installStackBin :: ( MonadMask m ] m () -installStackBin ver = do +installStackBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver + installStackBindist dlinfo ver isoFilepath -- | Like 'installStackBin', except takes the 'DownloadInfo' as From 692cd1616b3602fa006f5c22aee538f5c066ab63 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:25:25 +0530 Subject: [PATCH 24/60] deletes `installStackBinIsolated` function --- lib/GHCup.hs | 55 ---------------------------------------------------- 1 file changed, 55 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d1e6a9e..908e1c4 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -781,61 +781,6 @@ installStack' path inst ver = do lift $ chmod_755 destPath --- | Installs stack into an isolated location sepcified by the user, --- also, doesn't make any symlinks. - -installStackBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installStackBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo Stack ver - - lift $ $(logDebug) [i|Requested to install stack version #{ver}|] - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - - liftE $ installStack' workdir isoDir ver - --------------------- --[ Set GHC/cabal ]-- --------------------- From 71e6dbfdca6c546a8d81694ebc9a92ee28983cb5 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:34:53 +0530 Subject: [PATCH 25/60] rename some auxiliary functions to their "unpacked" versions --- lib/GHCup.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 908e1c4..772129b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -448,9 +448,9 @@ installCabalBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabal' workdir isoDir ver + liftE $ installCabalUnpacked workdir isoDir ver else do - liftE $ installCabal' workdir binDir ver + liftE $ installCabalUnpacked workdir binDir ver -- create symlink if this is the latest version -- not applicable for isolated installs @@ -460,12 +460,12 @@ installCabalBindist dlinfo ver isoFilepath = do when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. -installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) +installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installCabal' path inst ver = do +installCabalUnpacked path inst ver = do lift $ $(logInfo) "Installing cabal" let cabalFile = "cabal" liftIO $ createDirRecursive' inst @@ -574,9 +574,9 @@ installHLSBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - liftE $ installHLS' workdir isoDir ver + liftE $ installHLSUnpacked workdir isoDir ver else do - liftE $ installHLS' workdir binDir ver + liftE $ installHLSUnpacked workdir binDir ver -- create symlink if this is the latest version in a regular install whenM (pure $ not isIsolatedInstall) $ do @@ -585,12 +585,12 @@ installHLSBindist dlinfo ver isoFilepath = do when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. -installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) +installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installHLS' path inst ver = do +installHLSUnpacked path inst ver = do lift $ $(logInfo) "Installing HLS" liftIO $ createDirRecursive' inst @@ -752,9 +752,9 @@ installStackBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - liftE $ installStack' workdir isoDir ver + liftE $ installStackUnpacked workdir isoDir ver else do - liftE $ installStack' workdir binDir ver + liftE $ installStackUnpacked workdir binDir ver -- create symlink if this is the latest version and a regular install whenM (pure $ not isIsolatedInstall) $ do @@ -764,12 +764,12 @@ installStackBindist dlinfo ver isoFilepath = do -- | Install an unpacked stack distribution. -installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) +installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installStack' path inst ver = do +installStackUnpacked path inst ver = do lift $ $(logInfo) "Installing stack" let stackFile = "stack" liftIO $ createDirRecursive' inst From 03d77f50064117bc23061fa9272d0110732394ee Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Mon, 26 Jul 2021 11:49:52 +0530 Subject: [PATCH 26/60] updates Bindist functions as per https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/127#note_366702 --- lib/GHCup.hs | 144 ++++++++++++++++++++++++--------------------------- 1 file changed, 67 insertions(+), 77 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 772129b..4eba20d 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -201,14 +201,13 @@ installGHCBindist :: ( MonadFail m () installGHCBindist dlinfo ver isoFilepath = do let tver = mkTVer ver - let isIsolatedInstall = isJust isoFilepath - lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - -- we only care for already installed errors in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + case isoFilepath of + -- we only care for already installed errors in regular (non-isolated) installs + Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + _ -> pure () -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -216,21 +215,16 @@ installGHCBindist dlinfo ver isoFilepath = do -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - let isoDir = if isIsolatedInstall - then fromJust isoFilepath - else mempty :: FilePath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + Nothing -> do -- regular install + toolchainSanityChecks + liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] - liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver - else do - toolchainSanityChecks - liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver - - -- make symlinks & stuff when regular install, - -- don't make any for isolated installs. - whenM (pure $ not isIsolatedInstall) (liftE $ postGHCInstall tver) + -- make symlinks & stuff when regular install, + liftE $ postGHCInstall tver where toolchainSanityChecks = do @@ -419,18 +413,18 @@ installCabalBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> -- for regular install check if any previous versions installed + whenM + (lift (cabalInstalled ver) >>= \a -> liftIO $ + handleIO (\_ -> pure False) + $ fmap (\x -> a && x) + -- ignore when the installation is a legacy cabal (binary, not symlink) + $ pathIsLink (binDir "cabal" <> exeExt) + ) + (throwE $ AlreadyInstalled Cabal ver) - -- check if cabal already installed in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM - (lift (cabalInstalled ver) >>= \a -> liftIO $ - handleIO (\_ -> pure False) - $ fmap (\x -> a && x) - -- ignore when the installation is a legacy cabal (binary, not symlink) - $ pathIsLink (binDir "cabal" <> exeExt) - ) - (throwE $ AlreadyInstalled Cabal ver) + _ -> pure () -- check isn't required in isolated installs -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -443,21 +437,18 @@ installCabalBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabalUnpacked workdir isoDir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabalUnpacked workdir isoDir ver - else do - liftE $ installCabalUnpacked workdir binDir ver + Nothing -> do -- regular install + liftE $ installCabalUnpacked workdir binDir ver - -- create symlink if this is the latest version - -- not applicable for isolated installs - whenM (pure $ not isIsolatedInstall) $ do - cVers <- lift $ fmap rights getInstalledCabals - let lInstCabal = headMay . reverse . sort $ cVers - when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver + -- create symlink if this is the latest version for regular installs + cVers <- lift $ fmap rights getInstalledCabals + let lInstCabal = headMay . reverse . sort $ cVers + when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) @@ -552,12 +543,13 @@ installHLSBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> + -- we only check for already installed in regular (non-isolated) installs + whenM (lift (hlsInstalled ver)) + (throwE $ AlreadyInstalled HLS ver) - -- we only check for already installed in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM (lift (hlsInstalled ver)) - (throwE $ AlreadyInstalled HLS ver) + _ -> pure () -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -569,20 +561,20 @@ installHLSBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - liftE $ installHLSUnpacked workdir isoDir ver - else do - liftE $ installHLSUnpacked workdir binDir ver + case isoFilepath of + Just isoDir -> do + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + liftE $ installHLSUnpacked workdir isoDir ver + + Nothing -> do + liftE $ installHLSUnpacked workdir binDir ver + + -- create symlink if this is the latest version in a regular install + hlsVers <- lift $ fmap rights getInstalledHLSs + let lInstHLS = headMay . reverse . sort $ hlsVers + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver - -- create symlink if this is the latest version in a regular install - whenM (pure $ not isIsolatedInstall) $ do - hlsVers <- lift $ fmap rights getInstalledHLSs - let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) @@ -730,11 +722,12 @@ installStackBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> -- check previous versions in case of regular installs + whenM (lift (stackInstalled ver)) + (throwE $ AlreadyInstalled Stack ver) - when (not isIsolatedInstall) $ - whenM (lift (stackInstalled ver)) - (throwE $ AlreadyInstalled Stack ver) + _ -> pure () -- don't do shit for isolates -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -747,20 +740,17 @@ installStackBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + liftE $ installStackUnpacked workdir isoDir ver + Nothing -> do -- regular install + liftE $ installStackUnpacked workdir binDir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - liftE $ installStackUnpacked workdir isoDir ver - else do - liftE $ installStackUnpacked workdir binDir ver - - -- create symlink if this is the latest version and a regular install - whenM (pure $ not isIsolatedInstall) $ do - sVers <- lift $ fmap rights getInstalledStacks - let lInstStack = headMay . reverse . sort $ sVers - when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver + -- create symlink if this is the latest version and a regular install + sVers <- lift $ fmap rights getInstalledStacks + let lInstStack = headMay . reverse . sort $ sVers + when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver -- | Install an unpacked stack distribution. From 521ab0aedbe2a2b11a5e2766744c25a04fe7a297 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 20 Jul 2021 22:05:01 +0530 Subject: [PATCH 27/60] adds basic --isolate option structure for install commands --- app/ghcup/Main.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 4083923..23fb40b 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -138,6 +138,7 @@ data InstallOptions = InstallOptions , instPlatform :: Maybe PlatformRequest , instBindist :: Maybe URI , instSet :: Bool + , isolateDir :: Maybe FilePath } data SetCommand = SetGHC SetOptions @@ -574,7 +575,7 @@ Examples: installOpts :: Maybe Tool -> Parser InstallOptions installOpts tool = - (\p (u, v) b -> InstallOptions v p u b) + (\p (u, v) b is -> InstallOptions v p u b is) <$> optional (option (eitherReader platformParser) @@ -603,6 +604,15 @@ installOpts tool = (long "set" <> help "Set as active version after install" ) + <*> optional + (option + (eitherReader isolateParser) + ( short 'i' + <> long "isolate" + <> metavar "DIR" + <> help "install in an isolated dir instead of the default one" + ) + ) setParser :: Parser (Either SetCommand SetOptions) @@ -1215,6 +1225,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of bindistParser :: String -> Either String URI bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString +isolateParser :: FilePath -> Either String FilePath +isolateParser f = case isValid f of + True -> Right $ normalise f + False -> Left "Please enter a valid filepath for isolate dir." toSettings :: Options -> IO (Settings, KeyBindings) toSettings options = do From 8666fcd12057cc537d2f209c80b45da132b454df Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Thu, 22 Jul 2021 19:32:56 +0530 Subject: [PATCH 28/60] adds rudimentary isolate capability to ghcup install ghc command --- app/ghcup/Main.hs | 33 ++++++++++++++++++++------------- lib/GHCup.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 23fb40b..9c6f687 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1631,22 +1631,29 @@ Report bugs at |] ----------------------- let installGHC InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBin (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi - Just uri -> do - s' <- liftIO appState - runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + let ghcVersion = _tvVersion v + liftE $ installGHCBinIsolated isoDir ghcVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") - (_tvVersion v) + liftE $ installGHCBin (_tvVersion v) when instSet $ void $ liftE $ setGHC v SetGHCOnly pure vi - ) + Just uri -> do + s' <- liftIO appState + runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + ) >>= \case VRight vi -> do runLogger $ $(logInfo) "GHC installation successful" diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 5a226e8..e579ddf 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -229,6 +229,49 @@ installGHCBindist dlinfo ver = do lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall." +-- | Installs GHC to a specified location, doesn't make any symlinks. +installGHCBinIsolated :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => FilePath + -> Version -- ^ the version to install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () + +installGHCBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo GHC ver + + lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + + -- | Install a packed GHC distribution. This only deals with unpacking and the GHC -- build system and nothing else. installPackedGHC :: ( MonadMask m From a16a25a3cde03aa435ab6a4daccf07e81b51a0b7 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:51:56 +0530 Subject: [PATCH 29/60] factor out installCabal' from `installCabalBindist`, to be shared with `installCabalBinIsolated` function --- lib/GHCup.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e579ddf..ba31f4a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -470,22 +470,22 @@ installCabalBindist dlinfo ver = do let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver - where - -- | Install an unpacked cabal distribution. - installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installCabal' path inst = do - lift $ $(logInfo) "Installing cabal" - let cabalFile = "cabal" - liftIO $ createDirRecursive' inst - let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt - let destPath = inst destFileName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path cabalFile <> exeExt) - destPath - lift $ chmod_755 destPath +-- | Install an unpacked cabal distribution. +installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installCabal' path inst ver = do + lift $ $(logInfo) "Installing cabal" + let cabalFile = "cabal" + liftIO $ createDirRecursive' inst + let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt + let destPath = inst destFileName + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path cabalFile <> exeExt) + destPath + lift $ chmod_755 destPath -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and From 9a511669a85868c0508c7ae6bd07e34d5e6a69ed Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:56:03 +0530 Subject: [PATCH 30/60] use the new factored out installCabal' in `installCabalBindist` function --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index ba31f4a..1070464 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -463,7 +463,7 @@ installCabalBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installCabal' workdir binDir + liftE $ installCabal' workdir binDir ver -- create symlink if this is the latest version cVers <- lift $ fmap rights getInstalledCabals From 476513b0a7d46e01a89fd95b3a047476db4a2007 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 15:57:42 +0530 Subject: [PATCH 31/60] Adds isolate install functionality to 'Cabal' tool installs --- app/ghcup/Main.hs | 34 +++++++++++++++++++------------ lib/GHCup.hs | 51 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 9c6f687..37921fb 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1679,19 +1679,27 @@ Report bugs at |] let installCabal InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> + runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + let cabalVersion = (_tvVersion v) + liftE $ installCabalBinIsolated isoDir cabalVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 1070464..9bbe509 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -487,6 +487,57 @@ installCabal' path inst ver = do destPath lift $ chmod_755 destPath +-- | Installs GHC to a specified location, doesn't make any symlinks. +installCabalBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installCabalBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo Cabal ver + lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabal' workdir isoDir ver + -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and -- creates a default @cabal -> cabal-x.y.z.q@ symlink for From c0f46ef81f92c440b7cc2b9432cbb10ef33ad353 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:23:03 +0530 Subject: [PATCH 32/60] Factor out installHLS' --- lib/GHCup.hs | 55 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 9bbe509..b859950 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -634,39 +634,38 @@ installHLSBindist dlinfo ver = do let lInstHLS = headMay . reverse . sort $ hlsVers when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver - where - -- | Install an unpacked hls distribution. - installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installHLS' path inst = do - lift $ $(logInfo) "Installing HLS" - liftIO $ createDirRecursive' inst +-- | Install an unpacked hls distribution. +installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installHLS' path inst ver = do + lift $ $(logInfo) "Installing HLS" + liftIO $ createDirRecursive' inst - -- install haskell-language-server- - bins@(_:_) <- liftIO $ findFiles - path - (makeRegexOpts compExtended - execBlank - ([s|^haskell-language-server-[0-9].*$|] :: ByteString) - ) - forM_ bins $ \f -> do - let toF = dropSuffix exeExt f - <> "~" <> T.unpack (prettyVer ver) <> exeExt - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path f) - (inst toF) - lift $ chmod_755 (inst toF) - - -- install haskell-language-server-wrapper - let wrapper = "haskell-language-server-wrapper" - toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt + -- install haskell-language-server- + bins@(_:_) <- liftIO $ findFiles + path + (makeRegexOpts compExtended + execBlank + ([s|^haskell-language-server-[0-9].*$|] :: ByteString) + ) + forM_ bins $ \f -> do + let toF = dropSuffix exeExt f + <> "~" <> T.unpack (prettyVer ver) <> exeExt handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path wrapper <> exeExt) + (path f) (inst toF) lift $ chmod_755 (inst toF) + -- install haskell-language-server-wrapper + let wrapper = "haskell-language-server-wrapper" + toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path wrapper <> exeExt) + (inst toF) + lift $ chmod_755 (inst toF) -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. From 0d118e2fe1b0d657e124d2607e70f303debd1f01 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:23:52 +0530 Subject: [PATCH 33/60] update installHLS' usage in `installHLSBindist` --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index b859950..b34a76d 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -627,7 +627,7 @@ installHLSBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installHLS' workdir binDir + liftE $ installHLS' workdir binDir ver -- create symlink if this is the latest version hlsVers <- lift $ fmap rights getInstalledHLSs From f212eb457082eba1bb4ca7da4a708ab896812dd9 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:25:01 +0530 Subject: [PATCH 34/60] Adds isolated install to HLS installs --- app/ghcup/Main.hs | 33 +++++++++++++++++----------- lib/GHCup.hs | 56 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 37921fb..f56064a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1718,19 +1718,26 @@ Report bugs at |] pure $ ExitFailure 4 let installHLS InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + let hlsVersion = (_tvVersion v) + liftE $ installHLSBinIsolated isoDir hlsVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index b34a76d..4e3b9d9 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -667,6 +667,62 @@ installHLS' path inst ver = do (inst toF) lift $ chmod_755 (inst toF) +-- | Installs hls binaries in an isolated location provided by user, +-- doesn't make any symlinks + +installHLSBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installHLSBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo HLS ver + + lift $ $(logDebug) [i|Requested to install hls version #{ver}|] + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + + liftE $ installHLS' workdir isoDir ver + + -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m From 8f6a7ba39c98afdc7b6d008b6d528c74bb9294c8 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:43:43 +0530 Subject: [PATCH 35/60] factor out installStack' function --- lib/GHCup.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4e3b9d9..2e7dc85 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -854,23 +854,23 @@ installStackBindist dlinfo ver = do let lInstStack = headMay . reverse . sort $ sVers when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver - where - -- | Install an unpacked stack distribution. - installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> FilePath -- ^ Path to install to - -> Excepts '[CopyError] m () - installStack' path inst = do - lift $ $(logInfo) "Installing stack" - let stackFile = "stack" - liftIO $ createDirRecursive' inst - let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt - let destPath = inst destFileName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path stackFile <> exeExt) - destPath - lift $ chmod_755 destPath +-- | Install an unpacked stack distribution. +installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) + -> FilePath -- ^ Path to install to + -> Version + -> Excepts '[CopyError] m () +installStack' path inst ver = do + lift $ $(logInfo) "Installing stack" + let stackFile = "stack" + liftIO $ createDirRecursive' inst + let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt + let destPath = inst destFileName + handleIO (throwE . CopyError . show) $ liftIO $ copyFile + (path stackFile <> exeExt) + destPath + lift $ chmod_755 destPath From f3c1c925ede95491101401257077a34a52ddbe1c Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:44:40 +0530 Subject: [PATCH 36/60] updates installStack' usage in `installStackBindist` function --- lib/GHCup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 2e7dc85..93fb4a7 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -847,7 +847,7 @@ installStackBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installStack' workdir binDir + liftE $ installStack' workdir binDir ver -- create symlink if this is the latest version sVers <- lift $ fmap rights getInstalledStacks From fdbcd4fafd0ea3743f5a111f3fbf89524b71b104 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:46:11 +0530 Subject: [PATCH 37/60] Adds isolated installs to Stack install --- app/ghcup/Main.hs | 33 +++++++++++++++++------------ lib/GHCup.hs | 54 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f56064a..7e8e026 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1756,19 +1756,26 @@ Report bugs at |] pure $ ExitFailure 4 let installStack InstallOptions{..} = - (case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case isolateDir of + Just isoDir -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + let stackVersion = (_tvVersion v) + liftE $ installStackBinIsolated isoDir stackVersion + pure vi + Nothing -> + case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBin (_tvVersion v) + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 93fb4a7..22b15e6 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -873,6 +873,60 @@ installStack' path inst ver = do lift $ chmod_755 destPath +-- | Installs stack into an isolated location sepcified by the user, +-- also, doesn't make any symlinks. + +installStackBinIsolated :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => FilePath + -> Version + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist +#if !defined(TAR) + , ArchiveResult +#endif + ] + m + () +installStackBinIsolated isoDir ver = do + dlinfo <- liftE $ getDownloadInfo Stack ver + + lift $ $(logDebug) [i|Requested to install stack version #{ver}|] + + PlatformRequest {_rPlatform} <- lift getPlatformReq + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ lift $ darwinNotarization _rPlatform tmpUnpack + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + + liftE $ installStack' workdir isoDir ver --------------------- --[ Set GHC/cabal ]-- From a45d069cad634196c561c7cd065959ea6ed8e995 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Fri, 23 Jul 2021 16:51:50 +0530 Subject: [PATCH 38/60] Adds a log to notify where the isolated ghc is being installed by the tool --- lib/GHCup.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 22b15e6..d9a55b2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -269,6 +269,8 @@ installGHCBinIsolated isoDir ver = do -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver From 083dc59a8f2ee7fd96d3872594653dbd514bfb1e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:35:41 +0530 Subject: [PATCH 39/60] update `installGhcBindist` to take a "Maybe FilePath" to work with isolated installs --- lib/GHCup.hs | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d9a55b2..021e9a7 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -186,6 +186,7 @@ installGHCBindist :: ( MonadFail m ) => DownloadInfo -- ^ where/how to download -> Version -- ^ the version to install + -> Maybe FilePath -- ^ isolated filepath if user passed any -> Excepts '[ AlreadyInstalled , BuildFailed @@ -201,10 +202,16 @@ installGHCBindist :: ( MonadFail m ] m () -installGHCBindist dlinfo ver = do +installGHCBindist dlinfo ver isoFilepath = do let tver = mkTVer ver + let isIsolatedInstall = isJust isoFilepath + + lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + + -- we only care for already installed errors in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -212,11 +219,21 @@ installGHCBindist dlinfo ver = do -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - toolchainSanityChecks - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver + let isoDir = if isIsolatedInstall + then fromJust isoFilepath + else mempty :: FilePath - liftE $ postGHCInstall tver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + else do + toolchainSanityChecks + liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver + + -- make symlinks & stuff when regular install, + -- don't make any for isolated installs. + whenM (pure $ not isIsolatedInstall) (liftE $ postGHCInstall tver) where toolchainSanityChecks = do From 37ea18a0d8a1f344a842e71424301ad8ca7a4b24 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:38:32 +0530 Subject: [PATCH 40/60] updates usages of new installGHCBindist and related installGHCBin --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 38 ++++++++++++++++---------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 20 insertions(+), 25 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index c6a2e66..17acc9e 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -448,7 +448,7 @@ install' _ (_, ListResult {..}) = do case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls - liftE $ installGHCBin lVer $> vi + liftE $ installGHCBin lVer Nothing $> vi Cabal -> do let vi = getVersionInfo lVer Cabal dls liftE $ installCabalBin lVer $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7e8e026..f43de0e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1631,28 +1631,22 @@ Report bugs at |] ----------------------- let installGHC InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - let ghcVersion = _tvVersion v - liftE $ installGHCBinIsolated isoDir ghcVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBin (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi - Just uri -> do - s' <- liftIO appState - runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") - (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBin (_tvVersion v) isolateDir + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi + Just uri -> do + s' <- liftIO appState + runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + isolateDir + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 021e9a7..1344849 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -405,6 +405,7 @@ installGHCBin :: ( MonadFail m , MonadUnliftIO m ) => Version -- ^ the version to install + -> Maybe FilePath -- ^ isolated install filepath, if user passed any -> Excepts '[ AlreadyInstalled , BuildFailed @@ -420,9 +421,9 @@ installGHCBin :: ( MonadFail m ] m () -installGHCBin ver = do +installGHCBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo GHC ver - installGHCBindist dlinfo ver + installGHCBindist dlinfo ver isoFilepath -- | Like 'installCabalBin', except takes the 'DownloadInfo' as From 62d03b776b7efafa84fdff5f6dca1d1044088f28 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 13:39:44 +0530 Subject: [PATCH 41/60] remove installGHCBinIsolated function. --- lib/GHCup.hs | 45 --------------------------------------------- 1 file changed, 45 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 1344849..31acf7b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -246,51 +246,6 @@ installGHCBindist dlinfo ver isoFilepath = do lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall." --- | Installs GHC to a specified location, doesn't make any symlinks. -installGHCBinIsolated :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => FilePath - -> Version -- ^ the version to install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () - -installGHCBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo GHC ver - - lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver - - -- | Install a packed GHC distribution. This only deals with unpacking and the GHC -- build system and nothing else. installPackedGHC :: ( MonadMask m From 1f760af880e4d7e3c961dec477b7fa24b0335d1d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:20:42 +0530 Subject: [PATCH 42/60] update `installCabalBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 31acf7b..c5e381a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -397,6 +397,7 @@ installCabalBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -- ^ isolated install filepath, if user provides any. -> Excepts '[ AlreadyInstalled , CopyError @@ -412,13 +413,17 @@ installCabalBindist :: ( MonadMask m ] m () -installCabalBindist dlinfo ver = do +installCabalBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM + let isIsolatedInstall = isJust isoFilepath + + -- check if cabal already installed in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && x) @@ -438,12 +443,21 @@ installCabalBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installCabal' workdir binDir ver + let isoDir = fromJust isoFilepath + + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabal' workdir isoDir ver + else do + liftE $ installCabal' workdir binDir ver -- create symlink if this is the latest version - cVers <- lift $ fmap rights getInstalledCabals - let lInstCabal = headMay . reverse . sort $ cVers - when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver + -- not applicable for isolated installs + whenM (pure $ not isIsolatedInstall) $ do + cVers <- lift $ fmap rights getInstalledCabals + let lInstCabal = headMay . reverse . sort $ cVers + when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) From 236da31af6f92eb0703cbab8f19da3e38afc3c58 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:24:50 +0530 Subject: [PATCH 43/60] updates usages of new `installCabalBindist` across files. --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 35 ++++++++++++++--------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 24 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 17acc9e..129a5cb 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -451,7 +451,7 @@ install' _ (_, ListResult {..}) = do liftE $ installGHCBin lVer Nothing $> vi Cabal -> do let vi = getVersionInfo lVer Cabal dls - liftE $ installCabalBin lVer $> vi + liftE $ installCabalBin lVer Nothing $> vi GHCup -> do let vi = snd <$> getLatest dls GHCup liftE $ upgradeGHCup Nothing False $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f43de0e..c1246ae 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1673,27 +1673,20 @@ Report bugs at |] let installCabal InstallOptions{..} = - (case isolateDir of - Just isoDir -> - runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - let cabalVersion = (_tvVersion v) - liftE $ installCabalBinIsolated isoDir cabalVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index c5e381a..3820eaf 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -545,6 +545,7 @@ installCabalBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -- isolated install Path, if user provided any -> Excepts '[ AlreadyInstalled , CopyError @@ -560,9 +561,9 @@ installCabalBin :: ( MonadMask m ] m () -installCabalBin ver = do +installCabalBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver + installCabalBindist dlinfo ver isoFilepath -- | Like 'installHLSBin, except takes the 'DownloadInfo' as From 781cf8eed543a66aea271b39bbe112bd436ede2d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 21:25:27 +0530 Subject: [PATCH 44/60] Delete installCabalBinIsolated function. --- lib/GHCup.hs | 52 ---------------------------------------------------- 1 file changed, 52 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3820eaf..479f395 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -476,58 +476,6 @@ installCabal' path inst ver = do destPath lift $ chmod_755 destPath --- | Installs GHC to a specified location, doesn't make any symlinks. -installCabalBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installCabalBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo Cabal ver - lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabal' workdir isoDir ver - - -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and -- creates a default @cabal -> cabal-x.y.z.q@ symlink for -- the latest installed version. From 7471f4f4dc78d7a965d7609bbfaf55c2f234595e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:08:32 +0530 Subject: [PATCH 45/60] update `installHLSBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 479f395..caa4d86 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -530,6 +530,7 @@ installHLSBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -- ^ isolated install path, if user passed any -> Excepts '[ AlreadyInstalled , CopyError @@ -545,13 +546,17 @@ installHLSBindist :: ( MonadMask m ] m () -installHLSBindist dlinfo ver = do +installHLSBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM (lift (hlsInstalled ver)) + let isIsolatedInstall = isJust isoFilepath + + -- we only check for already installed in regular (non-isolated) installs + when (not isIsolatedInstall) $ + whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) -- download (or use cached version) @@ -564,13 +569,20 @@ installHLSBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + let isoDir = fromJust isoFilepath - liftE $ installHLS' workdir binDir ver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + liftE $ installHLS' workdir isoDir ver + else do + liftE $ installHLS' workdir binDir ver - -- create symlink if this is the latest version - hlsVers <- lift $ fmap rights getInstalledHLSs - let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver + -- create symlink if this is the latest version in a regular install + whenM (pure $ not isIsolatedInstall) $ do + hlsVers <- lift $ fmap rights getInstalledHLSs + let lInstHLS = headMay . reverse . sort $ hlsVers + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) From 90ed0895d6e894a3be0aaa2615f7af4ade2ba590 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:10:10 +0530 Subject: [PATCH 46/60] updates usages of `installHLSBin` across files --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 34 ++++++++++++++-------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 23 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 129a5cb..09ba831 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -457,7 +457,7 @@ install' _ (_, ListResult {..}) = do liftE $ upgradeGHCup Nothing False $> vi HLS -> do let vi = getVersionInfo lVer HLS dls - liftE $ installHLSBin lVer $> vi + liftE $ installHLSBin lVer Nothing $> vi Stack -> do let vi = getVersionInfo lVer Stack dls liftE $ installStackBin lVer $> vi diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c1246ae..cc429e8 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1705,26 +1705,20 @@ Report bugs at |] pure $ ExitFailure 4 let installHLS InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - let hlsVersion = (_tvVersion v) - liftE $ installHLSBinIsolated isoDir hlsVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index caa4d86..6d72328 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -689,6 +689,7 @@ installHLSBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -704,9 +705,9 @@ installHLSBin :: ( MonadMask m ] m () -installHLSBin ver = do +installHLSBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver + installHLSBindist dlinfo ver isoFilepath -- | Installs stack into @~\/.ghcup\/bin/stack-\@ and From 960d5ce79fd6fcee22c682c924f717298ccce7c3 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:10:43 +0530 Subject: [PATCH 47/60] deletes `installHLSBinIsolated` function --- lib/GHCup.hs | 56 ---------------------------------------------------- 1 file changed, 56 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 6d72328..031df9f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -617,62 +617,6 @@ installHLS' path inst ver = do (inst toF) lift $ chmod_755 (inst toF) --- | Installs hls binaries in an isolated location provided by user, --- doesn't make any symlinks - -installHLSBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installHLSBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo HLS ver - - lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - - liftE $ installHLS' workdir isoDir ver - - -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m From 6b89646c1e34927cb03e723ff22cb42dbc880097 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:23:58 +0530 Subject: [PATCH 48/60] update `installStackBindist` to take a "Maybe FilePath" argument for isolated installs --- lib/GHCup.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 031df9f..9e081e5 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -707,6 +707,7 @@ installStackBindist :: ( MonadMask m ) => DownloadInfo -> Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -722,13 +723,16 @@ installStackBindist :: ( MonadMask m ] m () -installStackBindist dlinfo ver = do +installStackBindist dlinfo ver isoFilepath = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - whenM (lift (stackInstalled ver)) + let isIsolatedInstall = isJust isoFilepath + + when (not isIsolatedInstall) $ + whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) -- download (or use cached version) @@ -742,12 +746,20 @@ installStackBindist dlinfo ver = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - liftE $ installStack' workdir binDir ver + let isoDir = fromJust isoFilepath - -- create symlink if this is the latest version - sVers <- lift $ fmap rights getInstalledStacks - let lInstStack = headMay . reverse . sort $ sVers - when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver + if isIsolatedInstall + then do + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + liftE $ installStack' workdir isoDir ver + else do + liftE $ installStack' workdir binDir ver + + -- create symlink if this is the latest version and a regular install + whenM (pure $ not isIsolatedInstall) $ do + sVers <- lift $ fmap rights getInstalledStacks + let lInstStack = headMay . reverse . sort $ sVers + when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver -- | Install an unpacked stack distribution. From 911089f334c473e10adfc747867bf569d3e16c51 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:24:38 +0530 Subject: [PATCH 49/60] updates usages of new `installStackBin` across files --- app/ghcup/BrickMain.hs | 2 +- app/ghcup/Main.hs | 34 ++++++++++++++-------------------- lib/GHCup.hs | 5 +++-- 3 files changed, 18 insertions(+), 23 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 09ba831..e23724f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -460,7 +460,7 @@ install' _ (_, ListResult {..}) = do liftE $ installHLSBin lVer Nothing $> vi Stack -> do let vi = getVersionInfo lVer Stack dls - liftE $ installStackBin lVer $> vi + liftE $ installStackBin lVer Nothing $> vi ) >>= \case VRight vi -> do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index cc429e8..3ed8a08 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1737,26 +1737,20 @@ Report bugs at |] pure $ ExitFailure 4 let installStack InstallOptions{..} = - (case isolateDir of - Just isoDir -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - let stackVersion = (_tvVersion v) - liftE $ installStackBinIsolated isoDir stackVersion - pure vi - Nothing -> - case instBindist of - Nothing -> runInstTool instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBin (_tvVersion v) - pure vi - Just uri -> do - s' <- appState - runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + (case instBindist of + Nothing -> runInstTool instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBin (_tvVersion v) isolateDir + pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + isolateDir + pure vi ) >>= \case VRight vi -> do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 9e081e5..a04cc9a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -671,6 +671,7 @@ installStackBin :: ( MonadMask m , MonadFail m ) => Version + -> Maybe FilePath -> Excepts '[ AlreadyInstalled , CopyError @@ -686,9 +687,9 @@ installStackBin :: ( MonadMask m ] m () -installStackBin ver = do +installStackBin ver isoFilepath = do dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver + installStackBindist dlinfo ver isoFilepath -- | Like 'installStackBin', except takes the 'DownloadInfo' as From ae5e213b5956cce23cbbc46b78506d1f8d8c47c0 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:25:25 +0530 Subject: [PATCH 50/60] deletes `installStackBinIsolated` function --- lib/GHCup.hs | 55 ---------------------------------------------------- 1 file changed, 55 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index a04cc9a..f09d923 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -781,61 +781,6 @@ installStack' path inst ver = do lift $ chmod_755 destPath --- | Installs stack into an isolated location sepcified by the user, --- also, doesn't make any symlinks. - -installStackBinIsolated :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , MonadLogger m - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath - -> Version - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist -#if !defined(TAR) - , ArchiveResult -#endif - ] - m - () -installStackBinIsolated isoDir ver = do - dlinfo <- liftE $ getDownloadInfo Stack ver - - lift $ $(logDebug) [i|Requested to install stack version #{ver}|] - - PlatformRequest {_rPlatform} <- lift getPlatformReq - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ lift $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - - liftE $ installStack' workdir isoDir ver - --------------------- --[ Set GHC/cabal ]-- --------------------- From 5683493caeb67b55008f0c013568c2b8287bd357 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 25 Jul 2021 22:34:53 +0530 Subject: [PATCH 51/60] rename some auxiliary functions to their "unpacked" versions --- lib/GHCup.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index f09d923..f788345 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -448,9 +448,9 @@ installCabalBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabal' workdir isoDir ver + liftE $ installCabalUnpacked workdir isoDir ver else do - liftE $ installCabal' workdir binDir ver + liftE $ installCabalUnpacked workdir binDir ver -- create symlink if this is the latest version -- not applicable for isolated installs @@ -460,12 +460,12 @@ installCabalBindist dlinfo ver isoFilepath = do when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. -installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) +installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installCabal' path inst ver = do +installCabalUnpacked path inst ver = do lift $ $(logInfo) "Installing cabal" let cabalFile = "cabal" liftIO $ createDirRecursive' inst @@ -574,9 +574,9 @@ installHLSBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - liftE $ installHLS' workdir isoDir ver + liftE $ installHLSUnpacked workdir isoDir ver else do - liftE $ installHLS' workdir binDir ver + liftE $ installHLSUnpacked workdir binDir ver -- create symlink if this is the latest version in a regular install whenM (pure $ not isIsolatedInstall) $ do @@ -585,12 +585,12 @@ installHLSBindist dlinfo ver isoFilepath = do when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. -installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) +installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installHLS' path inst ver = do +installHLSUnpacked path inst ver = do lift $ $(logInfo) "Installing HLS" liftIO $ createDirRecursive' inst @@ -752,9 +752,9 @@ installStackBindist dlinfo ver isoFilepath = do if isIsolatedInstall then do lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - liftE $ installStack' workdir isoDir ver + liftE $ installStackUnpacked workdir isoDir ver else do - liftE $ installStack' workdir binDir ver + liftE $ installStackUnpacked workdir binDir ver -- create symlink if this is the latest version and a regular install whenM (pure $ not isIsolatedInstall) $ do @@ -764,12 +764,12 @@ installStackBindist dlinfo ver isoFilepath = do -- | Install an unpacked stack distribution. -installStack' :: (MonadLogger m, MonadCatch m, MonadIO m) +installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version -> Excepts '[CopyError] m () -installStack' path inst ver = do +installStackUnpacked path inst ver = do lift $ $(logInfo) "Installing stack" let stackFile = "stack" liftIO $ createDirRecursive' inst From e1bec789b0fe70696b148c8f9745e557a364378d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Mon, 26 Jul 2021 11:49:52 +0530 Subject: [PATCH 52/60] updates Bindist functions as per https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/127#note_366702 --- lib/GHCup.hs | 144 ++++++++++++++++++++++++--------------------------- 1 file changed, 67 insertions(+), 77 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index f788345..cd4b358 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -204,14 +204,13 @@ installGHCBindist :: ( MonadFail m () installGHCBindist dlinfo ver isoFilepath = do let tver = mkTVer ver - let isIsolatedInstall = isJust isoFilepath - lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - -- we only care for already installed errors in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + case isoFilepath of + -- we only care for already installed errors in regular (non-isolated) installs + Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) + _ -> pure () -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -219,21 +218,16 @@ installGHCBindist dlinfo ver isoFilepath = do -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - let isoDir = if isIsolatedInstall - then fromJust isoFilepath - else mempty :: FilePath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] + liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver + Nothing -> do -- regular install + toolchainSanityChecks + liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] - liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver - else do - toolchainSanityChecks - liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver - - -- make symlinks & stuff when regular install, - -- don't make any for isolated installs. - whenM (pure $ not isIsolatedInstall) (liftE $ postGHCInstall tver) + -- make symlinks & stuff when regular install, + liftE $ postGHCInstall tver where toolchainSanityChecks = do @@ -419,18 +413,18 @@ installCabalBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> -- for regular install check if any previous versions installed + whenM + (lift (cabalInstalled ver) >>= \a -> liftIO $ + handleIO (\_ -> pure False) + $ fmap (\x -> a && x) + -- ignore when the installation is a legacy cabal (binary, not symlink) + $ pathIsLink (binDir "cabal" <> exeExt) + ) + (throwE $ AlreadyInstalled Cabal ver) - -- check if cabal already installed in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM - (lift (cabalInstalled ver) >>= \a -> liftIO $ - handleIO (\_ -> pure False) - $ fmap (\x -> a && x) - -- ignore when the installation is a legacy cabal (binary, not symlink) - $ pathIsLink (binDir "cabal" <> exeExt) - ) - (throwE $ AlreadyInstalled Cabal ver) + _ -> pure () -- check isn't required in isolated installs -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -443,21 +437,18 @@ installCabalBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] + liftE $ installCabalUnpacked workdir isoDir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|] - liftE $ installCabalUnpacked workdir isoDir ver - else do - liftE $ installCabalUnpacked workdir binDir ver + Nothing -> do -- regular install + liftE $ installCabalUnpacked workdir binDir ver - -- create symlink if this is the latest version - -- not applicable for isolated installs - whenM (pure $ not isIsolatedInstall) $ do - cVers <- lift $ fmap rights getInstalledCabals - let lInstCabal = headMay . reverse . sort $ cVers - when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver + -- create symlink if this is the latest version for regular installs + cVers <- lift $ fmap rights getInstalledCabals + let lInstCabal = headMay . reverse . sort $ cVers + when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver -- | Install an unpacked cabal distribution. installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) @@ -552,12 +543,13 @@ installHLSBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> + -- we only check for already installed in regular (non-isolated) installs + whenM (lift (hlsInstalled ver)) + (throwE $ AlreadyInstalled HLS ver) - -- we only check for already installed in regular (non-isolated) installs - when (not isIsolatedInstall) $ - whenM (lift (hlsInstalled ver)) - (throwE $ AlreadyInstalled HLS ver) + _ -> pure () -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -569,20 +561,20 @@ installHLSBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] - liftE $ installHLSUnpacked workdir isoDir ver - else do - liftE $ installHLSUnpacked workdir binDir ver + case isoFilepath of + Just isoDir -> do + lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|] + liftE $ installHLSUnpacked workdir isoDir ver + + Nothing -> do + liftE $ installHLSUnpacked workdir binDir ver + + -- create symlink if this is the latest version in a regular install + hlsVers <- lift $ fmap rights getInstalledHLSs + let lInstHLS = headMay . reverse . sort $ hlsVers + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver - -- create symlink if this is the latest version in a regular install - whenM (pure $ not isIsolatedInstall) $ do - hlsVers <- lift $ fmap rights getInstalledHLSs - let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver -- | Install an unpacked hls distribution. installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) @@ -730,11 +722,12 @@ installStackBindist dlinfo ver isoFilepath = do PlatformRequest {..} <- lift getPlatformReq Dirs {..} <- lift getDirs - let isIsolatedInstall = isJust isoFilepath + case isoFilepath of + Nothing -> -- check previous versions in case of regular installs + whenM (lift (stackInstalled ver)) + (throwE $ AlreadyInstalled Stack ver) - when (not isIsolatedInstall) $ - whenM (lift (stackInstalled ver)) - (throwE $ AlreadyInstalled Stack ver) + _ -> pure () -- don't do shit for isolates -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -747,20 +740,17 @@ installStackBindist dlinfo ver isoFilepath = do -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - let isoDir = fromJust isoFilepath + case isoFilepath of + Just isoDir -> do -- isolated install + lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] + liftE $ installStackUnpacked workdir isoDir ver + Nothing -> do -- regular install + liftE $ installStackUnpacked workdir binDir ver - if isIsolatedInstall - then do - lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|] - liftE $ installStackUnpacked workdir isoDir ver - else do - liftE $ installStackUnpacked workdir binDir ver - - -- create symlink if this is the latest version and a regular install - whenM (pure $ not isIsolatedInstall) $ do - sVers <- lift $ fmap rights getInstalledStacks - let lInstStack = headMay . reverse . sort $ sVers - when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver + -- create symlink if this is the latest version and a regular install + sVers <- lift $ fmap rights getInstalledStacks + let lInstStack = headMay . reverse . sort $ sVers + when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver -- | Install an unpacked stack distribution. From 2c6d0382cf9a83869ba0bcc7ea73f2162e3236b0 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Wed, 4 Aug 2021 16:08:12 +0530 Subject: [PATCH 53/60] adds isolate install feature to compiled ghc command --- app/ghcup/Main.hs | 11 +++++++++++ lib/GHCup.hs | 38 +++++++++++++++++++++++++++----------- 2 files changed, 38 insertions(+), 11 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 3ed8a08..aef3ed7 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -186,6 +186,7 @@ data GHCCompileOptions = GHCCompileOptions , ovewrwiteVer :: Maybe Version , buildFlavour :: Maybe String , hadrian :: Bool + , isolateDir :: Maybe FilePath } data UpgradeOpts = UpgradeInplace @@ -1010,6 +1011,15 @@ ghcCompileOpts = <*> switch (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)" ) + <*> optional + (option + (eitherReader isolateParser) + ( short 'i' + <> long "isolate" + <> metavar "DIR" + <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made" + ) + ) toolVersionParser :: Parser ToolVersion @@ -1979,6 +1989,7 @@ Report bugs at |] addConfArgs buildFlavour hadrian + isolateDir GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $ diff --git a/lib/GHCup.hs b/lib/GHCup.hs index cd4b358..fb77559 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1750,6 +1750,7 @@ compileGHC :: ( MonadMask m -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool + -> Maybe FilePath -- ^ isolate dir -> Excepts '[ AlreadyInstalled , BuildFailed @@ -1768,7 +1769,7 @@ compileGHC :: ( MonadMask m ] m GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian +compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -1838,12 +1839,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had alreadyInstalled <- lift $ ghcInstalled installVer alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver) when alreadyInstalled $ do - lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|] + case isolateDir of + Just isoDir -> + lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |] + Nothing -> + lift $ $(logWarn) [i|GHC #{prettyShow tver} 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 <- lift $ ghcupGHCDir installVer + ghcdir <- case isolateDir of + Just isoDir -> pure isoDir + Nothing -> lift $ ghcupGHCDir installVer bghc <- case bstrap of Right g -> pure $ Right g @@ -1860,9 +1867,14 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had pure (b, bmk) ) - when alreadyInstalled $ do - lift $ $(logInfo) [i|Deleting existing installation|] - liftE $ rmGHCVer tver + case isolateDir of + Nothing -> + -- only remove old ghc in regular installs + when alreadyInstalled $ do + lift $ $(logInfo) [i|Deleting existing installation|] + liftE $ rmGHCVer tver + + _ -> pure () forM_ mBindist $ \bindist -> do liftE $ installPackedGHC bindist @@ -1871,11 +1883,15 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had (tver ^. tvVersion) liftIO $ B.writeFile (ghcdir ghcUpSrcBuiltFile) bmk - - reThrowAll GHCupSetError $ postGHCInstall tver - - -- restore - when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly + + case isolateDir of + -- set and make symlinks for regular (non-isolated) installs + Nothing -> do + reThrowAll GHCupSetError $ postGHCInstall tver + -- restore + when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly + + _ -> pure () pure tver From d1735bc446cb431f1db3ed8da38f760b756d739e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 10 Aug 2021 19:53:41 +0530 Subject: [PATCH 54/60] adds toolchainSanityChecks for isolated installs too in `installGHCBindist` function. --- lib/GHCup.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index fb77559..4cd1ea1 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -218,12 +218,13 @@ installGHCBindist dlinfo ver isoFilepath = do -- prepare paths ghcdir <- lift $ ghcupGHCDir tver + toolchainSanityChecks + case isoFilepath of Just isoDir -> do -- isolated install lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|] liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver Nothing -> do -- regular install - toolchainSanityChecks liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver -- make symlinks & stuff when regular install, From 80fa7965a42d2c892ddf2b9900be97ce7826efcf Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 10 Aug 2021 20:11:32 +0530 Subject: [PATCH 55/60] Adds new Error type `IsolatedDirNotEmpty` --- lib/GHCup/Errors.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index fa039d7..30d59e0 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -134,6 +134,14 @@ instance Pretty AlreadyInstalled where pPrint (AlreadyInstalled tool ver') = text [i|#{tool}-#{prettyShow ver'} is already installed|] +-- | The Directory for isolated install already exists and is not empty +-- | This is done to prevent any overwriting +data IsolatedDirNotEmpty = IsolatedDirNotEmpty {path :: FilePath} + +instance Pretty IsolatedDirNotEmpty where + pPrint (IsolatedDirNotEmpty path) = do + text [i| The directory for isolated install already exists and is NOT EMPTY : #{path}|] + -- | The tool is not installed. Some operations rely on a tool -- to be installed (such as setting the current GHC version). data NotInstalled = NotInstalled Tool GHCTargetVersion From bb430fa0b7bc4fac254cdfd659f037af88c066df Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 10 Aug 2021 20:12:14 +0530 Subject: [PATCH 56/60] Adds the sanity check function for isolated installs --- lib/GHCup.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4cd1ea1..da07ff2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -2251,6 +2251,28 @@ upgradeGHCup mtarget force' = do --[ Other ]-- ------------- +-- | Does basic checks for isolated installs +-- Isolated Directory: +-- 1. if it doesn't exist -> proceed +-- 2. if it exists and is empty -> proceed +-- 3. if it exists and is non-empty -> panic and leave the house + +isolatedInstallSanityCheck :: ( MonadIO m + , MonadThrow m + ) => + FilePath -> + Excepts '[IsolatedDirNotEmpty] m () +isolatedInstallSanityCheck isoDir = do + dirExists <- liftIO $ doesDirectoryExist isoDir + if not dirExists + then pure () + else do + len <- liftIO $ length <$> listDirectory isoDir + let isDirEmpty = len == 0 + if isDirEmpty + then pure () + else (throwE $ IsolatedDirNotEmpty isoDir) + -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. From 300cfd3ba6234c8e05c3344788c734befc4e7e9e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 10 Aug 2021 20:14:46 +0530 Subject: [PATCH 57/60] implements isolated install sanity-checking for Cabal installs --- app/ghcup/BrickMain.hs | 1 + app/ghcup/Main.hs | 1 + lib/GHCup.hs | 5 ++++- 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e23724f..4e21adf 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -442,6 +442,7 @@ install' _ (_, ListResult {..}) = do , DownloadFailed , NoUpdate , TarDirDoesNotExist + , IsolatedDirNotEmpty ] run (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index aef3ed7..382ddc8 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1478,6 +1478,7 @@ Report bugs at |] , TarDirDoesNotExist , NextVerNotFound , NoToolVersionSet + , IsolatedDirNotEmpty ] let runInstTool mInstPlatform action' = do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index da07ff2..6874737 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -405,6 +405,7 @@ installCabalBindist :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , IsolatedDirNotEmpty ] m () @@ -425,7 +426,8 @@ installCabalBindist dlinfo ver isoFilepath = do ) (throwE $ AlreadyInstalled Cabal ver) - _ -> pure () -- check isn't required in isolated installs + Just isoDir -> + liftE $ isolatedInstallSanityCheck isoDir -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -498,6 +500,7 @@ installCabalBin :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , IsolatedDirNotEmpty ] m () From dcfb3afdad31dfa050f13ab15354b7c770ef7295 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Wed, 11 Aug 2021 09:46:42 +0530 Subject: [PATCH 58/60] Revert "implements isolated install sanity-checking for Cabal installs" This reverts commit 300cfd3ba6234c8e05c3344788c734befc4e7e9e. --- app/ghcup/BrickMain.hs | 1 - app/ghcup/Main.hs | 1 - lib/GHCup.hs | 5 +---- 3 files changed, 1 insertion(+), 6 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 4e21adf..e23724f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -442,7 +442,6 @@ install' _ (_, ListResult {..}) = do , DownloadFailed , NoUpdate , TarDirDoesNotExist - , IsolatedDirNotEmpty ] run (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 382ddc8..aef3ed7 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1478,7 +1478,6 @@ Report bugs at |] , TarDirDoesNotExist , NextVerNotFound , NoToolVersionSet - , IsolatedDirNotEmpty ] let runInstTool mInstPlatform action' = do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 6874737..da07ff2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -405,7 +405,6 @@ installCabalBindist :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif - , IsolatedDirNotEmpty ] m () @@ -426,8 +425,7 @@ installCabalBindist dlinfo ver isoFilepath = do ) (throwE $ AlreadyInstalled Cabal ver) - Just isoDir -> - liftE $ isolatedInstallSanityCheck isoDir + _ -> pure () -- check isn't required in isolated installs -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -500,7 +498,6 @@ installCabalBin :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif - , IsolatedDirNotEmpty ] m () From ce6fb0bb1ef4fee7396a76eaa0a05695504ce6e3 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Wed, 11 Aug 2021 10:28:30 +0530 Subject: [PATCH 59/60] Adds new Error type `FileAlreadyExistsError` --- lib/GHCup/Errors.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 30d59e0..491a6d4 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -176,6 +176,16 @@ instance Pretty FileDoesNotExistError where pPrint (FileDoesNotExistError file) = text [i|File "#{file}" does not exist.|] +-- | The file already exists +-- (e.g. when we use isolated installs with the same path). +-- (e.g. This is done to prevent any overwriting) +data FileAlreadyExistsError = FileAlreadyExistsError FilePath + deriving Show + +instance Pretty FileAlreadyExistsError where + pPrint (FileAlreadyExistsError file) = + text [i|File "#{file}" Already exists.|] + data TarDirDoesNotExist = TarDirDoesNotExist TarDir deriving Show From c2c562568592f165c179e53d6f15b361429eedcc Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Wed, 11 Aug 2021 10:33:08 +0530 Subject: [PATCH 60/60] implements checking if file already exists for Cabal installs --- app/ghcup/BrickMain.hs | 1 + app/ghcup/Main.hs | 1 + lib/GHCup.hs | 7 ++++++- 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e23724f..e79a9ea 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -442,6 +442,7 @@ install' _ (_, ListResult {..}) = do , DownloadFailed , NoUpdate , TarDirDoesNotExist + , FileAlreadyExistsError ] run (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index aef3ed7..183e257 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1478,6 +1478,7 @@ Report bugs at |] , TarDirDoesNotExist , NextVerNotFound , NoToolVersionSet + , FileAlreadyExistsError ] let runInstTool mInstPlatform action' = do diff --git a/lib/GHCup.hs b/lib/GHCup.hs index da07ff2..8872e29 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -405,6 +405,7 @@ installCabalBindist :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m () @@ -456,13 +457,16 @@ installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Version - -> Excepts '[CopyError] m () + -> Excepts '[CopyError, FileAlreadyExistsError] m () installCabalUnpacked path inst ver = do lift $ $(logInfo) "Installing cabal" let cabalFile = "cabal" liftIO $ createDirRecursive' inst let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt let destPath = inst destFileName + whenM + (liftIO $ doesFileExist destPath) + (throwE $ FileAlreadyExistsError destPath) handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile <> exeExt) destPath @@ -498,6 +502,7 @@ installCabalBin :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m ()