From 7e14fd4a0894adced41ec217f4c75b8a29e5eff8 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 20:30:14 +0200 Subject: [PATCH 01/10] Only run unsafeInterleaveIO when necessary --- app/ghcup/Main.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index cfb4c15..339d3c0 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1244,8 +1244,12 @@ Report bugs at |] -- Getting download and platform info -- ---------------------------------------- + -- for some commands we want lazy loading + let wrapIO = case optCommand of + Whereis _ _ -> unsafeInterleaveIO + _ -> id - pfreq <- unsafeInterleaveIO $ ( + pfreq <- wrapIO $ ( runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest ) >>= \case VRight r -> pure r @@ -1254,7 +1258,7 @@ Report bugs at |] ($(logError) $ T.pack $ prettyShow e) exitWith (ExitFailure 2) - ghcupInfo <- unsafeInterleaveIO $ + ghcupInfo <- wrapIO $ ( runLogger . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE From bc85a7d9c384179edca784f7a1fde438f8db1523 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 20:30:33 +0200 Subject: [PATCH 02/10] Fix cross installation See https://gitlab.haskell.org/ghc/ghc/-/issues/14297 --- lib/GHCup.hs | 79 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 33 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 5fc8bdc..d12cde8 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1618,11 +1618,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs Right g -> pure $ Right g Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) - (bindist, bmk) <- liftE $ runBuildAction + (mBindist, bmk) <- liftE $ runBuildAction tmpUnpack Nothing (do - b <- compileBindist bghc tver workdir + b <- compileBindist bghc tver workdir ghcdir bmk <- liftIO $ B.readFile (build_mk workdir) pure (b, bmk) ) @@ -1630,10 +1630,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs when alreadyInstalled $ do lift $ $(logInfo) [i|Deleting existing installation|] liftE $ rmGHCVer tver - liftE $ installPackedGHC bindist - (Just $ RegexDir "ghc-.*") - ghcdir - (tver ^. tvVersion) + + forM_ mBindist $ \bindist -> do + liftE $ installPackedGHC bindist + (Just $ RegexDir "ghc-.*") + ghcdir + (tver ^. tvVersion) liftIO $ B.writeFile (ghcdir ghcUpSrcBuiltFile) bmk @@ -1670,11 +1672,12 @@ HADDOCK_DOCS = YES|] => Either FilePath FilePath -> GHCTargetVersion -> FilePath + -> FilePath -> Excepts '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError] m - FilePath -- ^ output path of bindist - compileBindist bghc tver workdir = do + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileBindist bghc tver workdir ghcdir = do lift $ $(logInfo) [i|configuring build|] liftE checkBuildConfig @@ -1695,6 +1698,7 @@ HADDOCK_DOCS = YES|] ("./configure" : maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] #if defined(IS_WINDOWS) ++ ["--enable-tarballs-autodownload"] #endif @@ -1711,8 +1715,9 @@ HADDOCK_DOCS = YES|] ++ maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] #if defined(IS_WINDOWS) - ++ ["--enable-tarballs-autodownload"] + ++ ["--enable-tarballs-autodownload"] #endif ++ fmap T.unpack aargs ) @@ -1731,30 +1736,35 @@ HADDOCK_DOCS = YES|] lift $ $(logInfo) [i|Building (this may take a while)...|] lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) - lift $ $(logInfo) [i|Creating bindist...|] - lEM $ make ["binary-dist"] (Just workdir) - [tar] <- liftIO $ findFiles - workdir - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - c <- liftIO $ BL.readFile (workdir tar) - cDigest <- - fmap (T.take 8) - . lift - . throwEither - . E.decodeUtf8' - . B16.encode - . SHA256.hashlazy - $ c - cTime <- liftIO getCurrentTime - let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|] - let tarPath = cacheDir tarName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir tar) - tarPath - lift $ $(logInfo) [i|Copied bindist to #{tarPath}|] - pure tarPath + if | isCross tver -> do + lift $ $(logInfo) [i|Installing cross toolchain...|] + lEM $ make ["install"] (Just workdir) + pure Nothing + | otherwise -> do + lift $ $(logInfo) [i|Creating bindist...|] + lEM $ make ["binary-dist"] (Just workdir) + [tar] <- liftIO $ findFiles + workdir + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + c <- liftIO $ BL.readFile (workdir tar) + cDigest <- + fmap (T.take 8) + . lift + . throwEither + . E.decodeUtf8' + . B16.encode + . SHA256.hashlazy + $ c + cTime <- liftIO getCurrentTime + let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|] + let tarPath = cacheDir tarName + handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir tar) + tarPath + lift $ $(logInfo) [i|Copied bindist to #{tarPath}|] + pure $ Just tarPath build_mk workdir = workdir "mk" "build.mk" @@ -1781,6 +1791,9 @@ HADDOCK_DOCS = YES|] ) _ -> pure () + isCross :: GHCTargetVersion -> Bool + isCross = isJust . _tvTarget + From 42134fd2a5e7f4a5220a78e3f3164a0e3ab84261 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 22:38:42 +0200 Subject: [PATCH 03/10] Fix whereIsTool for cross --- lib/GHCup.hs | 2 +- lib/GHCup/Utils.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index d12cde8..943370b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1929,7 +1929,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do whenM (lift $ fmap not $ ghcInstalled ver) $ throwE (NotInstalled GHC ver) bdir <- lift $ ghcupGHCDir ver - pure (bdir "bin" "ghc" <> exeExt) + pure (bdir "bin" ghcBinaryName ver) Cabal -> do whenM (lift $ fmap not $ cabalInstalled _tvVersion) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion)) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c95818a..c4fa5a5 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1093,3 +1093,16 @@ ensureDirectories dirs = do createDirRecursive' logsDir createDirRecursive' confDir pure () + + +-- | For ghc without arch triple, this is: +-- +-- - ghc- (e.g. ghc-8.10.4) +-- +-- For ghc with arch triple: +-- +-- - -ghc- (e.g. arm-linux-gnueabihf-ghc-8.10.4) +ghcBinaryName :: GHCTargetVersion -> String +ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt) +ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt) + From 005c9fbb831041af60b617ffba7a2a0f0e5797dd Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 22:40:45 +0200 Subject: [PATCH 04/10] Modernize CI scripts --- .gitlab/script/ghcup_release.sh | 4 ---- .gitlab/script/ghcup_version.sh | 11 +++-------- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/.gitlab/script/ghcup_release.sh b/.gitlab/script/ghcup_release.sh index 5939d91..df90266 100755 --- a/.gitlab/script/ghcup_release.sh +++ b/.gitlab/script/ghcup_release.sh @@ -15,10 +15,6 @@ git describe # build ecabal update -( - cd /tmp - ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover -) if [ "${OS}" = "LINUX" ] ; then if [ "${ARCH}" = "32" ] ; then diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 6959f60..3da1a0f 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -26,11 +26,6 @@ git describe --always ecabal update -( - cd /tmp - ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover -) - if [ "${OS}" = "DARWIN" ] ; then ecabal build -w ghc-${GHC_VERSION} -ftui ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test @@ -83,10 +78,10 @@ ghcup-gen check -f ghcup-${JSON_VERSION}.yaml eghcup --numeric-version -eghcup install ${GHC_VERSION} +eghcup install ghc ${GHC_VERSION} [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] -eghcup set ${GHC_VERSION} -eghcup install-cabal ${CABAL_VERSION} +eghcup set ghc ${GHC_VERSION} +eghcup install cabal ${CABAL_VERSION} [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] cabal --version From 327b80cf5677d84097177300aaa847c455157326 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 22:39:37 +0200 Subject: [PATCH 05/10] Add cross compilation to CI test --- .gitlab-ci.yml | 23 +++++++++ .gitlab/before_script/linux/install_deps.sh | 13 ++++-- .gitlab/script/ghcup_cross.sh | 52 +++++++++++++++++++++ 3 files changed, 85 insertions(+), 3 deletions(-) create mode 100755 .gitlab/script/ghcup_cross.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fc59375..dd9f92f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -21,6 +21,7 @@ variables: OS: "LINUX" ARCH: "64" CABAL_DIR: "$CI_PROJECT_DIR/cabal" + CROSS: "" .alpine:64bit: image: "alpine:3.12" @@ -268,6 +269,24 @@ test:linux:latest: CABAL_VERSION: "3.4.0.0" needs: [] +test:linux:cross-armv7: + stage: test + extends: + - .test_ghcup_version + - .debian + variables: + GHC_VERSION: "8.10.4" + GHC_TARGET_VERSION: "8.10.5" + CABAL_VERSION: "3.4.0.0" + CROSS: "arm-linux-gnueabihf" + needs: [] + when: manual + before_script: + - ./.gitlab/before_script/linux/install_deps.sh + script: + - ./.gitlab/script/ghcup_cross.sh + + ######## linux 32bit test ######## test:linux:recommended:32bit: @@ -286,6 +305,7 @@ test:linux:recommended:armv7: variables: GHC_VERSION: "8.10.4" CABAL_VERSION: "3.4.0.0" + CROSS: "" when: manual needs: [] @@ -295,6 +315,7 @@ test:linux:recommended:aarch64: variables: GHC_VERSION: "8.10.4" CABAL_VERSION: "3.4.0.0" + CROSS: "" when: manual needs: [] @@ -394,6 +415,7 @@ release:linux:armv7: ARTIFACT: "armv7-linux-ghcup" GHC_VERSION: "8.10.4" CABAL_VERSION: "3.4.0.0" + CROSS: "" release:linux:aarch64: stage: release @@ -407,6 +429,7 @@ release:linux:aarch64: ARTIFACT: "aarch64-linux-ghcup" GHC_VERSION: "8.10.4" CABAL_VERSION: "3.4.0.0" + CROSS: "" ######## darwin release ######## diff --git a/.gitlab/before_script/linux/install_deps.sh b/.gitlab/before_script/linux/install_deps.sh index 062b1a5..31fe99c 100755 --- a/.gitlab/before_script/linux/install_deps.sh +++ b/.gitlab/before_script/linux/install_deps.sh @@ -9,6 +9,13 @@ mkdir -p "${TMPDIR}" sudo apt-get update -y sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https +if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then + sudo apt-get install -y autoconf build-essential gcc-arm-linux-gnueabihf + sudo dpkg --add-architecture armhf + sudo apt-get update -y + sudo apt-get install -y libncurses-dev:armhf +fi + case "${ARCH}" in ARM*) case "${ARCH}" in @@ -57,9 +64,9 @@ case "${ARCH}" in chmod +x ghcup-bin ./ghcup-bin upgrade -i -f - ./ghcup-bin install ${GHC_VERSION} - ./ghcup-bin set ${GHC_VERSION} - ./ghcup-bin install-cabal ${CABAL_VERSION} + ./ghcup-bin install ghc ${GHC_VERSION} + ./ghcup-bin set ghc ${GHC_VERSION} + ./ghcup-bin install cabal ${CABAL_VERSION} ;; esac diff --git a/.gitlab/script/ghcup_cross.sh b/.gitlab/script/ghcup_cross.sh new file mode 100755 index 0000000..e76caac --- /dev/null +++ b/.gitlab/script/ghcup_cross.sh @@ -0,0 +1,52 @@ +#!/bin/sh + +set -eux + +. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env" + +mkdir -p "$CI_PROJECT_DIR"/.local/bin + +CI_PROJECT_DIR=$(pwd) + +ecabal() { + cabal "$@" +} + +eghcup() { + ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@" +} + +git describe --always + +### build + +ecabal update + +ecabal build -w ghc-${GHC_VERSION} +cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup + +### cleanup + +rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup + +### manual cli based testing + +eghcup --numeric-version + +eghcup install ghc ${GHC_VERSION} +eghcup set ghc ${GHC_VERSION} +eghcup install cabal ${CABAL_VERSION} + +cabal --version + +eghcup debug-info + +eghcup compile ghc -j $(nproc) -v ${GHC_TARGET_VERSION} -b ${GHC_VERSION} -x ${CROSS} -- --enable-unregisterised +eghcup set ghc ${CROSS}-${GHC_TARGET_VERSION} + +[ `$(eghcup whereis ghc ${CROSS}-${GHC_TARGET_VERSION}) --numeric-version` = "${GHC_TARGET_VERSION}" ] + +# nuke +eghcup nuke +[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ] + From 2c7176d998c11ee2e74c68128eb28b9aed18f58e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 18 Jul 2021 14:39:49 +0200 Subject: [PATCH 06/10] Use LabelOptic and add LeanAppState Wrt #186 --- app/ghcup/Main.hs | 417 ++++++++++++++++++++------------ lib/GHCup.hs | 285 +++++++++++++++------- lib/GHCup/Types.hs | 14 +- lib/GHCup/Types/Optics.hs | 87 ++++++- lib/GHCup/Utils.hs | 135 ++++++----- lib/GHCup/Utils/Dirs.hs | 13 +- lib/GHCup/Utils/File/Posix.hs | 10 +- lib/GHCup/Utils/File/Windows.hs | 8 +- 8 files changed, 644 insertions(+), 325 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 339d3c0..e43e41e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -21,6 +21,7 @@ import GHCup.Errors import GHCup.Platform import GHCup.Requirements import GHCup.Types +import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Logger @@ -66,7 +67,6 @@ import System.Environment import System.Exit import System.FilePath import System.IO hiding ( appendFile ) -import System.IO.Unsafe ( unsafeInterleaveIO ) import Text.Read hiding ( lift ) import Text.PrettyPrint.HughesPJClass ( prettyShow ) import URI.ByteString @@ -942,7 +942,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar tagCompleter :: Tool -> [String] -> Completer tagCompleter tool add = listIOCompleter $ do - dirs' <- liftIO getDirs + dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty @@ -962,7 +962,7 @@ tagCompleter tool add = listIOCompleter $ do versionCompleter :: Maybe ListCriteria -> Tool -> Completer versionCompleter criteria tool = listIOCompleter $ do - dirs' <- liftIO getDirs + dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty @@ -1167,7 +1167,7 @@ describe_result :: String describe_result = $( LitE . StringL <$> runIO (do CapturedProcess{..} <- do - dirs <- liftIO getDirs + dirs <- liftIO getAllDirs let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings flip runReaderT settings $ executeOut "git" ["describe"] Nothing case _exitCode of @@ -1220,7 +1220,7 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - dirs <- getDirs + dirs@Dirs{..} <- getAllDirs -- create ~/.ghcup dir ensureDirectories dirs @@ -1228,7 +1228,7 @@ Report bugs at |] (settings, keybindings) <- toSettings opt -- logger interpreter - logfile <- initGHCupFileLogging (logsDir dirs) + logfile <- initGHCupFileLogging logsDir let loggerConfig = LoggerConfig { lcPrintDebug = verbose settings , colorOutter = B.hPut stderr @@ -1240,72 +1240,57 @@ Report bugs at |] let runLogger = myLoggerT loggerConfig let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () } - ---------------------------------------- - -- Getting download and platform info -- - ---------------------------------------- - - -- for some commands we want lazy loading - let wrapIO = case optCommand of - Whereis _ _ -> unsafeInterleaveIO - _ -> id - - pfreq <- wrapIO $ ( - runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest - ) >>= \case - VRight r -> pure r - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 2) - - ghcupInfo <- wrapIO $ - ( runLogger - . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] - $ liftE - $ getDownloadsF settings dirs - ) - >>= \case - VRight r -> pure r - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 2) - - ------------------------- -- Setting up appstate -- ------------------------- - let appstate@AppState{dirs = Dirs{..} - , ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. } - } = AppState settings dirs keybindings ghcupInfo pfreq + let leanAppstate = LeanAppState settings dirs keybindings + appState = do + pfreq <- ( + runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest + ) >>= \case + VRight r -> pure r + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 2) + + ghcupInfo <- + ( runLogger + . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] + $ liftE + $ getDownloadsF settings dirs + ) + >>= \case + VRight r -> pure r + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 2) + let s' = AppState settings dirs keybindings ghcupInfo pfreq + + lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case + Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates + Just _ -> pure () + + -- TODO: always run for windows + (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case + VRight _ -> pure () + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 30) + pure s' - --------------------------- - -- Running startup tasks -- - --------------------------- + runLeanAppState = flip runReaderT leanAppstate + runAppState action' = do + s' <- liftIO appState + flip runReaderT s' action' + - case optCommand of - Upgrade _ _ -> pure () - Whereis _ _ -> pure () - _ -> do - lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case - Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates - Just _ -> pure () - - - -- ensure global tools - case optCommand of - Whereis _ _ -> pure () - _ -> do - (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case - VRight _ -> pure () - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 30) ------------------------- @@ -1335,12 +1320,25 @@ Report bugs at |] , NoToolVersionSet ] - let runInstTool = runInstTool' appstate + let runInstTool mInstPlatform action' = do + s' <- liftIO appState + runInstTool' s' mInstPlatform action' let + runLeanSetGHC = + runLogger + . runLeanAppState + . runE + @'[ FileDoesNotExistError + , NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + runSetGHC = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ FileDoesNotExistError , NotInstalled @@ -1350,9 +1348,19 @@ Report bugs at |] ] let + runLeanSetCabal = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + runSetCabal = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , TagNotFound @@ -1363,7 +1371,7 @@ Report bugs at |] let runSetHLS = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , TagNotFound @@ -1371,20 +1379,30 @@ Report bugs at |] , NoToolVersionSet ] - let runListGHC = runLogger . flip runReaderT appstate + runLeanSetHLS = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + + let runListGHC = runLogger . runAppState let runRm = - runLogger . flip runReaderT appstate . runE @'[NotInstalled] + runLogger . runAppState . runE @'[NotInstalled] let runDebugInfo = runLogger - . flip runReaderT appstate + . runAppState . runE @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] let runCompileGHC = runLogger - . flip runReaderT appstate + . runAppState . runResourceT . runE @'[ AlreadyInstalled @@ -1404,9 +1422,19 @@ Report bugs at |] ] let + runLeanWhereIs = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , NoToolVersionSet + , NextVerNotFound + , TagNotFound + ] + runWhereIs = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , NoToolVersionSet @@ -1416,7 +1444,7 @@ Report bugs at |] let runUpgrade = runLogger - . flip runReaderT appstate + . runAppState . runResourceT . runE @'[ DigestError @@ -1439,13 +1467,15 @@ Report bugs at |] liftE $ installGHCBin (_tvVersion v) when instSet $ void $ liftE $ setGHC v SetGHCOnly pure vi - Just uri -> runInstTool' appstate{ 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 + 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 @@ -1477,12 +1507,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer Cabal liftE $ installCabalBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_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 @@ -1506,12 +1538,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer HLS liftE $ installHLSBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_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 @@ -1535,12 +1569,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer Stack liftE $ installStackBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_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 @@ -1559,11 +1595,13 @@ Report bugs at |] pure $ ExitFailure 4 - let setGHC' SetOptions{..} = - runSetGHC (do - v <- liftE $ fst <$> fromVersion' sToolVer GHC - liftE $ setGHC v SetGHCOnly - ) + let setGHC' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v) + _ -> runSetGHC (do + v <- liftE $ fst <$> fromVersion' sToolVer GHC + liftE $ setGHC v SetGHCOnly + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1574,12 +1612,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 5 - let setCabal' SetOptions{..} = - runSetCabal (do - v <- liftE $ fst <$> fromVersion' sToolVer Cabal - liftE $ setCabal (_tvVersion v) - pure v - ) + let setCabal' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v) + _ -> runSetCabal (do + v <- liftE $ fst <$> fromVersion' sToolVer Cabal + liftE $ setCabal (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1590,12 +1630,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 14 - let setHLS' SetOptions{..} = - runSetHLS (do - v <- liftE $ fst <$> fromVersion' sToolVer HLS - liftE $ setHLS (_tvVersion v) - pure v - ) + let setHLS' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v) + _ -> runSetHLS (do + v <- liftE $ fst <$> fromVersion' sToolVer HLS + liftE $ setHLS (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1606,12 +1648,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 14 - let setStack' SetOptions{..} = - runSetCabal (do - v <- liftE $ fst <$> fromVersion' sToolVer Stack - liftE $ setStack (_tvVersion v) - pure v - ) + let setStack' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v) + _ -> runSetCabal (do + v <- liftE $ fst <$> fromVersion' sToolVer Stack + liftE $ setStack (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1626,6 +1670,7 @@ Report bugs at |] runRm (do liftE $ rmGHCVer ghcVer + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo (_tvVersion ghcVer) GHC dls) ) >>= \case @@ -1641,6 +1686,7 @@ Report bugs at |] runRm (do liftE $ rmCabalVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv Cabal dls) ) >>= \case @@ -1656,6 +1702,7 @@ Report bugs at |] runRm (do liftE $ rmHLSVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv HLS dls) ) >>= \case @@ -1671,6 +1718,7 @@ Report bugs at |] runRm (do liftE $ rmStackVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv Stack dls) ) >>= \case @@ -1735,6 +1783,7 @@ Report bugs at |] runCompileGHC (do case targetGhc of Left targetVer -> do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ $(logInfo) msg @@ -1750,6 +1799,7 @@ Report bugs at |] buildConfig patchDir addConfArgs + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $ setGHC targetVer SetGHCOnly @@ -1777,6 +1827,21 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 9 + Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) -> + runLeanWhereIs (do + loc <- liftE $ whereIsTool tool v + if directory + then pure $ takeDirectory loc + else pure loc + ) + >>= \case + VRight r -> do + putStr r + pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 30 + Whereis WhereisOptions{..} (WhereisTool tool whereVer) -> runWhereIs (do (v, _) <- liftE $ fromVersion whereVer tool @@ -1801,6 +1866,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) runUpgrade (liftE $ upgradeGHCup target force') >>= \case VRight v' -> do + GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo let pretty_v = prettyVer v' let vi = fromJust $ snd <$> getLatest dls GHCup runLogger $ $(logInfo) @@ -1815,23 +1881,26 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 11 - ToolRequirements -> - flip runReaderT appstate - $ runLogger - (runE - @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] - $ do - platform <- liftE getPlatform - req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements - liftIO $ T.hPutStr stdout (prettyRequirements req) - ) - >>= \case - VRight _ -> pure ExitSuccess - VLeft e -> do - runLogger $ $(logError) $ T.pack $ prettyShow e - pure $ ExitFailure 12 + ToolRequirements -> do + s' <- appState + flip runReaderT s' + $ runLogger + (runE + @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] + $ do + GHCupInfo { .. } <- lift getGHCupInfo + platform' <- liftE getPlatform + req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements + liftIO $ T.hPutStr stdout (prettyRequirements req) + ) + >>= \case + VRight _ -> pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 12 ChangeLog ChangeLogOptions{..} -> do + GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo let tool = fromMaybe GHC clTool ver' = maybe (Right Latest) @@ -1849,6 +1918,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) ) pure ExitSuccess Just uri -> do + pfreq <- runAppState getPlatformReq let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri cmd = case _rPlatform pfreq of Darwin -> "open" @@ -1857,21 +1927,23 @@ Make sure to clean up #{tmpdir} afterwards.|]) Windows -> "start" if clOpen - then - flip runReaderT appstate $ - exec cmd - [T.unpack $ decUTF8Safe $ serializeURIRef' uri] - Nothing - Nothing - >>= \case - Right _ -> pure ExitSuccess - Left e -> runLogger ($(logError) [i|#{e}|]) - >> pure (ExitFailure 13) + then do + s' <- appState + flip runReaderT s' $ + exec cmd + [T.unpack $ decUTF8Safe $ serializeURIRef' uri] + Nothing + Nothing + >>= \case + Right _ -> pure ExitSuccess + Left e -> runLogger ($(logError) [i|#{e}|]) + >> pure (ExitFailure 13) else putStrLn uri' >> pure ExitSuccess Nuke -> runRm (do - void $ liftIO $ evaluate $ force appstate + s' <- liftIO appState + void $ liftIO $ evaluate $ force s' lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time." liftIO $ threadDelay 10000000 -- wait 10s @@ -1907,22 +1979,46 @@ Make sure to clean up #{tmpdir} afterwards.|]) pure () -fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) +fromVersion :: ( MonadLogger m + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) => Maybe ToolVersion -> Tool - -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion tv = fromVersion' (toSetToolVer tv) -fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) +fromVersion' :: ( MonadLogger m + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) => SetToolVersion -> Tool - -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion' SetRecommended tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolVersion v) tool = do - ~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion v) tool dls case pvp $ prettyVer (_tvVersion v) of Left _ -> pure (v, vi) @@ -1932,16 +2028,16 @@ fromVersion' (SetToolVersion v) tool = do Nothing -> pure (v, vi) Right _ -> pure (v, vi) fromVersion' (SetToolTag Latest) tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool fromVersion' (SetToolTag Recommended) tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolTag (Base pvp'')) GHC = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC fromVersion' SetNext tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of GHC -> do set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool @@ -2142,7 +2238,10 @@ printListResult raw lr = do | otherwise -> 1 -checkForUpdates :: ( MonadReader AppState m +checkForUpdates :: ( MonadReader env m + , HasGHCupInfo env + , HasDirs env + , HasPlatformReq env , MonadCatch m , MonadLogger m , MonadThrow m @@ -2152,7 +2251,7 @@ checkForUpdates :: ( MonadReader AppState m ) => m () checkForUpdates = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo lInstalled <- listVersions Nothing (Just ListInstalled) let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 943370b..4a8b248 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -106,7 +106,10 @@ import Control.Concurrent (threadDelay) installGHCBindist :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env , MonadLogger m , MonadResource m , MonadIO m @@ -130,7 +133,8 @@ installGHCBindist :: ( MonadFail m m () installGHCBindist dlinfo ver = do - AppState { dirs , settings } <- lift ask + dirs <- lift getDirs + settings <- lift getSettings let tver = mkTVer ver lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] @@ -163,7 +167,10 @@ installGHCBindist dlinfo ver = do -- build system and nothing else. installPackedGHC :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasSettings env , MonadThrow m , MonadLogger m , MonadIO m @@ -182,7 +189,7 @@ installPackedGHC :: ( MonadMask m #endif ] m () installPackedGHC dl msubdir inst ver = do - AppState { pfreq = PlatformRequest {..} } <- lift ask + PlatformRequest {..} <- lift getPlatformReq -- unpack tmpUnpack <- lift mkGhcupTmpDir @@ -201,7 +208,10 @@ installPackedGHC dl msubdir inst ver = do -- | Install an unpacked GHC distribution. This only deals with the GHC -- build system and nothing else. -installUnpackedGHC :: ( MonadReader AppState m +installUnpackedGHC :: ( MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadThrow m , MonadLogger m , MonadIO m @@ -218,7 +228,7 @@ installUnpackedGHC path inst _ = do liftIO $ copyDirectoryRecursive path inst #else installUnpackedGHC path inst ver = do - AppState { pfreq = PlatformRequest {..} } <- lift ask + PlatformRequest {..} <- lift getPlatformReq let alpineArgs | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform @@ -250,7 +260,11 @@ installUnpackedGHC path inst ver = do installGHCBin :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -273,8 +287,8 @@ installGHCBin :: ( MonadFail m m () installGHCBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls installGHCBindist dlinfo ver @@ -283,7 +297,10 @@ installGHCBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installCabalBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -310,9 +327,9 @@ installCabalBindist :: ( MonadMask m installCabalBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -364,7 +381,11 @@ installCabalBindist dlinfo ver = do -- the latest installed version. installCabalBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -388,8 +409,9 @@ installCabalBin :: ( MonadMask m m () installCabalBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls installCabalBindist dlinfo ver @@ -398,7 +420,10 @@ installCabalBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installHLSBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -425,9 +450,9 @@ installHLSBindist :: ( MonadMask m installHLSBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) @@ -488,7 +513,11 @@ installHLSBindist dlinfo ver = do -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -512,8 +541,9 @@ installHLSBin :: ( MonadMask m m () installHLSBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls installHLSBindist dlinfo ver @@ -523,7 +553,11 @@ installHLSBin ver = do -- the latest installed version. installStackBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env , MonadLogger m , MonadResource m , MonadIO m @@ -547,7 +581,9 @@ installStackBin :: ( MonadMask m m () installStackBin ver = do - AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls installStackBindist dlinfo ver @@ -556,7 +592,10 @@ installStackBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installStackBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -583,10 +622,9 @@ installStackBindist :: ( MonadMask m installStackBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings - } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) @@ -644,7 +682,8 @@ installStackBindist dlinfo ver = do -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader AppState m +setGHC :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -663,7 +702,7 @@ setGHC ver sghc = do whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) -- symlink destination - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) @@ -701,12 +740,15 @@ setGHC ver sghc = do where - symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) + symlinkShareDir :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadLogger m) => FilePath -> String -> m () symlinkShareDir ghcdir ver' = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs let destdir = baseDir case sghc of SetGHCOnly -> do @@ -733,7 +775,8 @@ setGHC ver sghc = do -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. setCabal :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -745,7 +788,7 @@ setCabal ver = do let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt -- symlink destination - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) $ throwE @@ -764,7 +807,8 @@ setCabal ver = do -- | Set the haskell-language-server symlinks. setHLS :: ( MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -775,7 +819,7 @@ setHLS :: ( MonadCatch m => Version -> Excepts '[NotInstalled] m () setHLS ver = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs -- Delete old symlinks, since these might have different ghc versions than the -- selected version, so we could end up with stray or incorrect symlinks. @@ -804,7 +848,8 @@ setHLS ver = do -- | Set the @~\/.ghcup\/bin\/stack@ symlink. setStack :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -817,7 +862,7 @@ setStack ver = do let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt -- symlink destination - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) $ throwE @@ -872,7 +917,10 @@ listVersions :: ( MonadCatch m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env ) => Maybe Tool -> Maybe ListCriteria @@ -891,7 +939,7 @@ listVersions lt' criteria = do go lt cSet cabals hlsSet' hlses sSet stacks = do case lt of Just t -> do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo -- get versions from GHCupDownloads let avTools = availableToolVersions dls t lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) @@ -917,7 +965,13 @@ listVersions lt' criteria = do ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) - strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) + strayGHCs :: ( MonadCatch m + , MonadReader env m + , HasDirs env + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do @@ -959,7 +1013,13 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayCabals :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> Maybe Version -> [Either FilePath Version] @@ -988,7 +1048,12 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayHLS :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayHLS avTools = do @@ -1016,7 +1081,13 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayStacks :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> m [ListResult] strayStacks avTools = do @@ -1045,7 +1116,14 @@ listVersions lt' criteria = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) + toListResult :: ( MonadLogger m + , MonadReader env m + , HasDirs env + , HasGHCupInfo env + , HasPlatformReq env + , MonadIO m + , MonadCatch m + ) => Tool -> Maybe Version -> [Either FilePath Version] @@ -1056,8 +1134,8 @@ listVersions lt' criteria = do -> (Version, [Tag]) -> m ListResult toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + pfreq <- getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo case t of GHC -> do @@ -1140,7 +1218,8 @@ listVersions lt' criteria = do -- This may leave GHCup without a "set" version. -- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- older version). -rmGHCVer :: ( MonadReader AppState m +rmGHCVer :: ( MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1181,7 +1260,7 @@ rmGHCVer ver = do forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs liftIO $ hideError doesNotExistErrorType @@ -1191,7 +1270,8 @@ rmGHCVer ver = do -- | Delete a cabal version. Will try to fix the @cabal@ symlink -- after removal (e.g. setting it to an older version). rmCabalVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1206,7 +1286,7 @@ rmCabalVer ver = do cSet <- lift cabalSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt liftIO $ hideError doesNotExistErrorType $ rmFile (binDir cabalFile) @@ -1221,7 +1301,8 @@ rmCabalVer ver = do -- | Delete a hls version. Will try to fix the hls symlinks -- after removal (e.g. setting it to an older version). rmHLSVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1236,7 +1317,7 @@ rmHLSVer ver = do isHlsSet <- lift hlsSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs bins <- lift $ hlsAllBinaries ver forM_ bins $ \f -> liftIO $ rmFile (binDir f) @@ -1258,7 +1339,8 @@ rmHLSVer ver = do -- | Delete a stack version. Will try to fix the @stack@ symlink -- after removal (e.g. setting it to an older version). rmStackVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1273,7 +1355,7 @@ rmStackVer ver = do sSet <- lift stackSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt liftIO $ hideError doesNotExistErrorType $ rmFile (binDir stackFile) @@ -1286,15 +1368,15 @@ rmStackVer ver = do -- assuming the current scheme of having just 1 ghcup bin, no version info is required. -rmGhcup :: ( MonadReader AppState m +rmGhcup :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadCatch m , MonadLogger m ) => m () - rmGhcup = do - AppState {dirs = Dirs {binDir}} <- ask + Dirs {binDir} <- getDirs let ghcupFilename = "ghcup" <> exeExt let ghcupFilepath = binDir ghcupFilename @@ -1338,14 +1420,14 @@ rmGhcup = do <> path <> "\n you may have to uninstall it manually." -rmTool :: ( MonadReader AppState m - , MonadLogger m - , MonadFail m - , MonadMask m - , MonadUnliftIO m) - => ListResult - -> Excepts '[NotInstalled ] m () - +rmTool :: ( MonadReader env m + , HasDirs env + , MonadLogger m + , MonadFail m + , MonadMask m + , MonadUnliftIO m) + => ListResult + -> Excepts '[NotInstalled ] m () rmTool ListResult {lVer, lTool, lCross} = do case lTool of GHC -> @@ -1357,7 +1439,8 @@ rmTool ListResult {lVer, lTool, lCross} = do GHCup -> lift rmGhcup -rmGhcupDirs :: ( MonadReader AppState m +rmGhcupDirs :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadCatch m @@ -1369,7 +1452,7 @@ rmGhcupDirs = do , binDir , logsDir , cacheDir - } <- asks dirs + } <- getDirs let envFilePath = baseDir "env" @@ -1477,13 +1560,20 @@ rmGhcupDirs = do ------------------ -getDebugInfo :: (Alternative m, MonadFail m, MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m) +getDebugInfo :: ( Alternative m + , MonadFail m + , MonadReader env m + , HasDirs env + , MonadLogger m + , MonadCatch m + , MonadIO m + ) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let diBaseDir = baseDir let diBinDir = binDir diGHCDir <- lift ghcupGHCBaseDir @@ -1503,7 +1593,11 @@ getDebugInfo = do -- | Compile a GHC from source. This behaves wrt symlinks and installation -- the same as 'installGHCBin'. compileGHC :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env , MonadThrow m , MonadResource m , MonadLogger m @@ -1538,10 +1632,11 @@ compileGHC :: ( MonadMask m GHCTargetVersion compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs = do - AppState { pfreq = PlatformRequest {..} - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls } - , settings - , dirs } <- lift ask + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + settings <- lift getSettings + dirs <- lift getDirs + (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball Left tver -> do @@ -1662,7 +1757,10 @@ BUILD_SPHINX_HTML = NO BUILD_SPHINX_PDF = NO HADDOCK_DOCS = YES|] - compileBindist :: ( MonadReader AppState m + compileBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env , MonadThrow m , MonadCatch m , MonadLogger m @@ -1680,8 +1778,9 @@ HADDOCK_DOCS = YES|] compileBindist bghc tver workdir ghcdir = do lift $ $(logInfo) [i|configuring build|] liftE checkBuildConfig - - AppState { dirs = Dirs {..}, pfreq } <- lift ask + + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir @@ -1805,7 +1904,11 @@ HADDOCK_DOCS = YES|] -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- if no path is provided. upgradeGHCup :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env , MonadCatch m , MonadLogger m , MonadThrow m @@ -1826,10 +1929,11 @@ upgradeGHCup :: ( MonadMask m m Version upgradeGHCup mtarget force' = do - AppState { dirs = Dirs {..} - , pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls } - , settings } <- lift ask + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq + settings <- lift getSettings + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ fst <$> getLatest dls GHCup when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate @@ -1878,7 +1982,8 @@ upgradeGHCup mtarget force' = do -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. -postGHCInstall :: ( MonadReader AppState m +postGHCInstall :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -1909,7 +2014,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do -- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\@ -- * for stack, this reports @~\/.ghcup\/bin\/stack-\@ -- * for ghcup, this reports the location of the currently running executable -whereIsTool :: ( MonadReader AppState m +whereIsTool :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -1922,7 +2028,7 @@ whereIsTool :: ( MonadReader AppState m -> GHCTargetVersion -> Excepts '[NotInstalled] m FilePath whereIsTool tool ver@GHCTargetVersion {..} = do - AppState { dirs } <- lift ask + dirs <- lift getDirs case tool of GHC -> do @@ -1946,3 +2052,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do GHCup -> do currentRunningExecPath <- liftIO getExecutablePath liftIO $ canonicalizePath currentRunningExecPath + + + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 65c7ed0..98ab2af 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -1,9 +1,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} {-| Module : GHCup.Types @@ -346,8 +349,14 @@ data AppState = AppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings - , ghcupInfo :: ~GHCupInfo - , pfreq :: ~PlatformRequest + , ghcupInfo :: GHCupInfo + , pfreq :: PlatformRequest + } deriving (Show, GHC.Generic) + +data LeanAppState = LeanAppState + { settings :: Settings + , dirs :: Dirs + , keyBindings :: KeyBindings } deriving (Show, GHC.Generic) instance NFData AppState @@ -507,4 +516,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where instance MonadLogger m => MonadLogger (Excepts e m) where monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d - diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index d971ccd..320e54b 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-| Module : GHCup.Types.Optics @@ -13,6 +18,7 @@ module GHCup.Types.Optics where import GHCup.Types +import Control.Monad.Reader import Data.ByteString ( ByteString ) import Optics import URI.ByteString @@ -58,3 +64,82 @@ pathL' = lensVL pathL queryL' :: Lens' (URIRef a) Query queryL' = lensVL queryL + + + + ---------------------- + --[ Lens utilities ]-- + ---------------------- + + +gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a) + => m a +gets = asks (^. labelOptic @f) + + +getAppState :: MonadReader AppState m => m AppState +getAppState = ask + + +getLeanAppState :: ( MonadReader env m + , LabelOptic' "settings" A_Lens env Settings + , LabelOptic' "dirs" A_Lens env Dirs + , LabelOptic' "keyBindings" A_Lens env KeyBindings + ) + => m LeanAppState +getLeanAppState = do + s <- gets @"settings" + d <- gets @"dirs" + k <- gets @"keyBindings" + pure (LeanAppState s d k) + + +getSettings :: ( MonadReader env m + , LabelOptic' "settings" A_Lens env Settings + ) + => m Settings +getSettings = gets @"settings" + + +getDirs :: ( MonadReader env m + , LabelOptic' "dirs" A_Lens env Dirs + ) + => m Dirs +getDirs = gets @"dirs" + + +getKeyBindings :: ( MonadReader env m + , LabelOptic' "keyBindings" A_Lens env KeyBindings + ) + => m KeyBindings +getKeyBindings = gets @"keyBindings" + + +getGHCupInfo :: ( MonadReader env m + , LabelOptic' "ghcupInfo" A_Lens env GHCupInfo + ) + => m GHCupInfo +getGHCupInfo = gets @"ghcupInfo" + + +getPlatformReq :: ( MonadReader env m + , LabelOptic' "pfreq" A_Lens env PlatformRequest + ) + => m PlatformRequest +getPlatformReq = gets @"pfreq" + + +type HasSettings env = (LabelOptic' "settings" A_Lens env Settings) +type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs) +type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings) +type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) +type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest) + + +getCache :: (MonadReader env m, HasSettings env) => m Bool +getCache = getSettings <&> cache + + +getDownloader :: (MonadReader env m, HasSettings env) => m Downloader +getDownloader = getSettings <&> downloader + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c4fa5a5..c8885c3 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP -- | The symlink destination of a ghc tool. -ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m) +ghcLinkDestination :: ( MonadReader env m + , HasDirs env + , MonadThrow m, MonadIO m) => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc. -> GHCTargetVersion -> m FilePath ghcLinkDestination tool ver = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs ghcd <- ghcupGHCDir ver pure (relativeSymlink binDir (ghcd "bin" tool)) -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -rmMinorSymlinks :: ( MonadReader AppState m +rmMinorSymlinks :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader AppState m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMinorSymlinks tv@GHCTargetVersion{..} = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs files <- liftE $ ghcToolFiles tv forM_ files $ \f -> do @@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do -- | Removes the set ghc version for the given target, if any. -rmPlain :: ( MonadReader AppState m +rmPlain :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlain target = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv @@ -159,17 +162,17 @@ rmPlain target = do -- | Remove the major GHC symlink, e.g. ghc-8.6. -rmMajorSymlinks :: ( MonadReader AppState m +rmMajorSymlinks :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader AppState m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMajorSymlinks tv@GHCTargetVersion{..} = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi @@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do -- | Whether the given GHC versin is installed. -ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesDirectoryExist ghcdir -- | Whether the given GHC version is installed from source. -ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. -ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m) +ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Maybe Text -- ^ the target of the GHC version, if any -- (e.g. armv7-unknown-linux-gnueabihf) -> m (Maybe GHCTargetVersion) ghcSet mtarget = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghcBin = binDir ghc <> exeExt @@ -239,7 +242,7 @@ ghcSet mtarget = do -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. -getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion] +getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir @@ -249,10 +252,15 @@ getInstalledGHCs = do -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledCabals :: ( MonadLogger m + , MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m + ) => m [Either FilePath Version] getInstalledCabals = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) @@ -264,16 +272,16 @@ getInstalledCabals = do -- | Whether the given cabal version is installed. -cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled ver = do vers <- fmap rights getInstalledCabals pure $ elem ver vers -- Return the currently set cabal version, if any. -cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let cabalbin = binDir "cabal" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -317,10 +325,10 @@ cabalSet = do -- | Get all installed hls, by matching on -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledHLSs = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -337,10 +345,10 @@ getInstalledHLSs = do -- | Get all installed stacks, by matching on -- @~\/.ghcup\/bin/stack-<\stackver\>@. -getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledStacks = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -355,9 +363,9 @@ getInstalledStacks = do -- Return the currently set stack version, if any. -- TODO: there's a lot of code duplication here :> -stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version) +stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version) stackSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let stackBin = binDir "stack" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -395,13 +403,13 @@ stackSet = do stripRelativePath = MP.many (MP.try stripPathComponet) -- | Whether the given Stack version is installed. -stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool stackInstalled ver = do vers <- fmap rights getInstalledStacks pure $ elem ver vers -- | Whether the given HLS version is installed. -hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool hlsInstalled ver = do vers <- fmap rights getInstalledHLSs pure $ elem ver vers @@ -409,9 +417,9 @@ hlsInstalled ver = do -- Return the currently set hls version, if any. -hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let hlsBin = binDir "haskell-language-server-wrapper" <> exeExt liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -443,7 +451,8 @@ hlsSet = do -- | Return the GHC versions the currently selected HLS supports. -hlsGHCVersions :: ( MonadReader AppState m +hlsGHCVersions :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadThrow m , MonadCatch m @@ -466,11 +475,11 @@ hlsGHCVersions = do -- | Get all server binaries for an hls version, if any. -hlsServerBinaries :: (MonadReader AppState m, MonadIO m) +hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) => Version -> m [FilePath] hlsServerBinaries ver = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -482,12 +491,12 @@ hlsServerBinaries ver = do -- | Get the wrapper binary for an hls version, if any. -hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m) +hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Version -> m (Maybe FilePath) hlsWrapperBinary ver = do - AppState { dirs = Dirs {..} } <- ask - wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles + Dirs {..} <- getDirs + wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -503,7 +512,7 @@ hlsWrapperBinary ver = do -- | Get all binaries for an hls version, if any. -hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath] +hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries ver = do hls <- hlsServerBinaries ver wrapper <- hlsWrapperBinary ver @@ -511,9 +520,9 @@ hlsAllBinaries ver = do -- | Get the active symlinks for hls. -hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath] +hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath] hlsSymlinks = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -549,7 +558,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of -- | Get the latest installed full GHC version that satisfies X.Y. -- This reads `ghcupGHCBaseDir`. -getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m) +getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> Maybe Text -- ^ the target triple @@ -729,19 +738,6 @@ getLatestBaseVersion av pvpVer = - ----------------------- - --[ AppState Getter ]-- - ----------------------- - - -getCache :: MonadReader AppState m => m Bool -getCache = ask <&> cache . settings - - -getDownloader :: MonadReader AppState m => m Downloader -getDownloader = ask <&> downloader . settings - - ------------- --[ Other ]-- @@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings -- Returns unversioned relative files without extension, e.g.: -- -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) +ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath] ghcToolFiles ver = do @@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built" -- | Calls gmake if it exists in PATH, otherwise make. -make :: (MonadThrow m, MonadIO m, MonadReader AppState m) +make :: ( MonadThrow m + , MonadIO m + , MonadReader env m + , HasDirs env + , HasSettings env + ) => [String] -> Maybe FilePath -> m (Either ProcessError ()) @@ -827,7 +828,7 @@ make args workdir = do let mymake = if has_gmake then "gmake" else "make" execLogged mymake args workdir "ghc-make" Nothing -makeOut :: (MonadReader AppState m, MonadIO m) +makeOut :: (MonadReader env m, HasDirs env, MonadIO m) => [String] -> Maybe FilePath -> m CapturedProcess @@ -840,7 +841,7 @@ makeOut args workdir = do -- | Try to apply patches in order. Fails with 'PatchFailed' -- on first failure. -applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m) +applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m) => FilePath -- ^ dir containing patches -> FilePath -- ^ dir to apply patches in -> Excepts '[PatchFailed] m () @@ -858,7 +859,7 @@ applyPatches pdir ddir = do -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -darwinNotarization :: (MonadReader AppState m, MonadIO m) +darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform -> FilePath -> m (Either ProcessError ()) @@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) = -- -- 1. the build directory, depending on the KeepDirs setting -- 2. the install destination, depending on whether the build failed -runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m) +runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m) => FilePath -- ^ build directory (cleaned up depending on Settings) -> Maybe FilePath -- ^ dir to *always* clean up on exception -> Excepts e m a -> Excepts '[BuildFailed] m a runBuildAction bdir instdir action = do - AppState { settings = Settings {..} } <- lift ask + Settings {..} <- lift getSettings let exAction = do forM_ instdir $ \dir -> liftIO $ hideError doesNotExistErrorType $ rmPath dir @@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadUnliftIO m , MonadFail m ) @@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m -> m () createLink link exe = do #if defined(IS_WINDOWS) - AppState { dirs } <- ask + dirs <- getDirs let shimGen = cacheDir dirs "gs.exe" let shim = dropExtension exe <.> "shim" @@ -1054,14 +1056,19 @@ ensureGlobalTools :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasGHCupInfo env , MonadUnliftIO m , MonadFail m ) => Excepts '[DigestError , DownloadFailed, NoDownload] m () ensureGlobalTools = do #if defined(IS_WINDOWS) - AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask + (GHCupInfo _ _ gTools) <- lift getGHCupInfo + settings <- lift getSettings + dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index ec680e7..807bcc4 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -16,7 +16,7 @@ Stability : experimental Portability : portable -} module GHCup.Utils.Dirs - ( getDirs + ( getAllDirs , ghcupBaseDir , ghcupConfigFile , ghcupCacheDir @@ -37,6 +37,7 @@ where import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) +import GHCup.Types.Optics import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude @@ -190,8 +191,8 @@ ghcupLogsDir = do #endif -getDirs :: IO Dirs -getDirs = do +getAllDirs :: IO Dirs +getAllDirs = do baseDir <- ghcupBaseDir binDir <- ghcupBinDir cacheDir <- ghcupCacheDir @@ -226,9 +227,9 @@ ghcupConfigFile = do -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath +ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath ghcupGHCBaseDir = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs pure (baseDir "ghc") @@ -236,7 +237,7 @@ ghcupGHCBaseDir = do -- The dir may be of the form -- * armv7-unknown-linux-gnueabihf-8.8.3 -- * 8.8.4 -ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) +ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m FilePath ghcupGHCDir ver = do diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 4885c8c..93fb1a8 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where import GHCup.Utils.File.Common import GHCup.Utils.Prelude import GHCup.Types +import GHCup.Types.Optics import Control.Concurrent import Control.Concurrent.Async @@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do SPP.executeFile path True args Nothing -execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) +execLogged :: ( MonadReader env m + , HasSettings env + , HasDirs env + , MonadIO m + , MonadThrow m) => FilePath -- ^ thing to execute -> [String] -- ^ args for the thing -> Maybe FilePath -- ^ optionally chdir into this @@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe args chdir lfile env = do - AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask + Settings {..} <- getSettings + Dirs {..} <- getDirs let logfile = logsDir lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index ba2710a..b8af657 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -146,7 +146,11 @@ executeOut path args chdir = do pure $ CapturedProcess exit out err -execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) +execLogged :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadIO m + , MonadThrow m) => FilePath -- ^ thing to execute -> [String] -- ^ args for the thing -> Maybe FilePath -- ^ optionally chdir into this @@ -154,7 +158,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe args chdir lfile env = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs let stdoutLogfile = logsDir lfile <> ".stdout.log" stderrLogfile = logsDir lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args) From 6143cdf2e0fd2737afa3d0c43c330252318c262b Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 18 Jul 2021 23:29:09 +0200 Subject: [PATCH 07/10] Add --offline switch wrt #186 --- app/ghcup-gen/Validate.hs | 12 +-- app/ghcup/BrickMain.hs | 16 ++- app/ghcup/Main.hs | 42 ++++++-- ghcup.cabal | 4 +- lib/GHCup.hs | 33 +++--- lib/GHCup/Download.hs | 183 ++++++++++++++++++++------------ lib/GHCup/Errors.hs | 7 ++ lib/GHCup/Types.hs | 9 +- lib/GHCup/Utils.hs | 2 +- lib/GHCup/Utils/File/Windows.hs | 1 + stack.yaml | 4 + 11 files changed, 193 insertions(+), 120 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 3c468e1..a8f414d 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -12,7 +12,7 @@ import GHCup import GHCup.Download import GHCup.Errors import GHCup.Platform -import GHCup.Types +import GHCup.Types hiding ( LeanAppState (..) ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.Logger @@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do , rawOutter = \_ -> pure () } downloadAll dli = do - dirs <- liftIO getDirs + dirs <- liftIO getAllDirs pfreq <- ( runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest @@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do ($(logError) $ T.pack $ prettyShow e) liftIO $ exitWith (ExitFailure 2) - let appstate = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq + let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq r <- runLogger @@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do case etool of Right (Just GHCup) -> do tmpUnpack <- lift mkGhcupTmpDir - _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing + _ <- liftE $ download dli tmpUnpack Nothing pure Nothing Right _ -> do - p <- liftE $ downloadCached (settings appstate) dirs dli Nothing + p <- liftE $ downloadCached dli Nothing fmap (Just . head . splitDirectories . head) . liftE . getArchiveFiles $ p Left ShimGen -> do tmpUnpack <- lift mkGhcupTmpDir - _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing + _ <- liftE $ download dli tmpUnpack Nothing pure Nothing case r of VRight (Just basePath) -> do diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 0ae2389..ba6d8bc 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,7 +13,7 @@ module BrickMain where import GHCup import GHCup.Download import GHCup.Errors -import GHCup.Types +import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.File @@ -53,8 +53,6 @@ import System.IO.Unsafe import Text.PrettyPrint.HughesPJClass ( prettyShow ) import URI.ByteString -import qualified GHCup.Types as GT - import qualified Data.Text as T import qualified Graphics.Vty as Vty import qualified Data.Vector as V @@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do settings' :: IORef AppState {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do - dirs <- getDirs + dirs <- getAllDirs newIORef $ AppState (Settings { cache = True , noVerify = False , keepDirs = Never , downloader = Curl , verbose = False , urlSource = GHCupURL + , noNetwork = False , .. }) dirs @@ -578,9 +577,8 @@ logger' = unsafePerformIO brickMain :: AppState -> LoggerConfig - -> GHCupInfo -> IO () -brickMain s l gi = do +brickMain s l = do writeIORef settings' s -- logger interpreter writeIORef logger' l @@ -588,7 +586,7 @@ brickMain s l gi = do no_color <- isJust <$> lookupEnv "NO_COLOR" - eAppData <- getAppData (Just gi) + eAppData <- getAppData (Just $ ghcupInfo s) case eAppData of Right ad -> defaultMain @@ -596,7 +594,7 @@ brickMain s l gi = do (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) - (keyBindings s) + (keyBindings (s :: AppState)) ) $> () @@ -620,7 +618,7 @@ getGHCupInfo = do . flip runReaderT settings . runE @'[JSONError , DownloadFailed , FileDoesNotExistError] $ liftE - $ getDownloadsF (GT.settings settings) (GT.dirs settings) + $ getDownloadsF case r of VRight a -> pure $ Right a diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e43e41e..a7224d4 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -91,6 +91,7 @@ data Options = Options , optNoVerify :: Maybe Bool , optKeepDirs :: Maybe KeepDirs , optsDownloader :: Maybe Downloader + , optNoNetwork :: Maybe Bool -- commands , optCommand :: Command } @@ -277,6 +278,7 @@ opts = #endif <> hidden )) + <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.") <*> com where parseUri s' = @@ -943,13 +945,19 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar tagCompleter :: Tool -> [String] -> Completer tagCompleter tool add = listIOCompleter $ do dirs' <- liftIO getAllDirs + let appState = LeanAppState + (Settings True False Never Curl False GHCupURL True) + dirs' + defaultKeyBindings + let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty , rawOutter = mempty } let runLogger = myLoggerT loggerConfig - mGhcUpInfo <- runLogger . runE $ readFromCache dirs' + + mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF case mGhcUpInfo of VRight ghcupInfo -> do let allTags = filter (\t -> t /= Old) @@ -969,12 +977,17 @@ versionCompleter criteria tool = listIOCompleter $ do , rawOutter = mempty } let runLogger = myLoggerT loggerConfig - mGhcUpInfo <- runLogger . runE $ readFromCache dirs' - mpFreq <- runLogger . runE $ platformRequest - forFold mpFreq $ \pfreq -> + settings = Settings True False Never Curl False GHCupURL True + let leanAppState = LeanAppState + settings + dirs' + defaultKeyBindings + mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest + mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF + forFold mpFreq $ \pfreq -> do forFold mGhcUpInfo $ \ghcupInfo -> do let appState = AppState - (Settings True False Never Curl False GHCupURL) + settings dirs' defaultKeyBindings ghcupInfo @@ -1123,6 +1136,7 @@ toSettings options = do downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource + noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal @@ -1168,7 +1182,9 @@ describe_result = $( LitE . StringL <$> runIO (do CapturedProcess{..} <- do dirs <- liftIO getAllDirs - let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings + let settings = AppState (Settings True False Never Curl False GHCupURL False) + dirs + defaultKeyBindings flip runReaderT settings $ executeOut "git" ["describe"] Nothing case _exitCode of ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut @@ -1259,9 +1275,10 @@ Report bugs at |] ghcupInfo <- ( runLogger + . flip runReaderT leanAppstate . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE - $ getDownloadsF settings dirs + $ getDownloadsF ) >>= \case VRight r -> pure r @@ -1285,7 +1302,13 @@ Report bugs at |] pure s' +#if defined(IS_WINDOWS) + -- FIXME: windows needs 'ensureGlobalTools', which requires + -- full appstate + runLeanAppState = runAppState +#else runLeanAppState = flip runReaderT leanAppstate +#endif runAppState action' = do s' <- liftIO appState flip runReaderT s' action' @@ -1299,7 +1322,7 @@ Report bugs at |] let runInstTool' appstate' mInstPlatform = runLogger - . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform) + . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) . runResourceT . runE @'[ AlreadyInstalled @@ -1733,7 +1756,8 @@ Report bugs at |] res <- case optCommand of #if defined(BRICK) Interactive -> do - liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess + s' <- appState + liftIO $ brickMain s' loggerConfig >> pure ExitSuccess #endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) diff --git a/ghcup.cabal b/ghcup.cabal index 86b166a..1237bf6 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -116,7 +116,7 @@ library , megaparsec >=8.0.0 && <9.1 , monad-logger ^>=0.3.31 , mtl ^>=2.2 - , optics >=0.2 && <0.5 + , optics ^>=0.4 , optics-vl ^>=0.2 , os-release ^>=1.0.0 , parsec ^>=3.1 @@ -279,7 +279,7 @@ executable ghcup-gen , haskus-utils-variant >=3.0 && <3.2 , monad-logger ^>=0.3.31 , mtl ^>=2.2 - , optics >=0.2 && <0.5 + , optics ^>=0.4 , optparse-applicative >=0.15.1.0 && <0.17 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4a8b248..8a8e3e0 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -133,15 +133,12 @@ installGHCBindist :: ( MonadFail m m () installGHCBindist dlinfo ver = do - dirs <- lift getDirs - settings <- lift getSettings - let tver = mkTVer ver lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- prepare paths ghcdir <- lift $ ghcupGHCDir tver @@ -328,8 +325,7 @@ installCabalBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -341,10 +337,10 @@ installCabalBindist dlinfo ver = do (throwE $ AlreadyInstalled Cabal ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -451,17 +447,16 @@ installHLSBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -623,17 +618,16 @@ installStackBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -1634,8 +1628,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - settings <- lift getSettings - dirs <- lift getDirs (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball @@ -1646,7 +1638,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs dlInfo <- preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls ?? NoDownload - dl <- liftE $ downloadCached settings dirs dlInfo Nothing + dl <- liftE $ downloadCached dlInfo Nothing -- unpack tmpUnpack <- lift mkGhcupTmpDir @@ -1931,7 +1923,6 @@ upgradeGHCup :: ( MonadMask m upgradeGHCup mtarget force' = do Dirs {..} <- lift getDirs pfreq <- lift getPlatformReq - settings <- lift getSettings GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ $(logInfo) [i|Upgrading GHCup...|] @@ -1940,7 +1931,7 @@ upgradeGHCup mtarget force' = do dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls tmp <- lift withGHCupTmpDir let fn = "ghcup" <> exeExt - p <- liftE $ download settings dli tmp (Just fn) + p <- liftE $ download dli tmp (Just fn) let destDir = takeDirectory destFile destFile = fromMaybe (binDir fn <> exeExt) mtarget lift $ $(logDebug) [i|mkdir -p #{destDir}|] diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 76a5d30..54a60e4 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -107,32 +107,31 @@ import qualified Data.Yaml as Y getDownloadsF :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo + , MonadReader env m + , HasSettings env + , HasDirs env , MonadIO m , MonadCatch m , MonadLogger m , MonadThrow m , MonadFail m ) - => Settings - -> Dirs - -> Excepts + => Excepts '[JSONError , DownloadFailed , FileDoesNotExistError] m GHCupInfo -getDownloadsF settings@Settings{ urlSource } dirs = do +getDownloadsF = do + Settings { urlSource } <- lift getSettings case urlSource of - GHCupURL -> liftE $ getBase dirs settings - (OwnSource url) -> do - bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url - lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs) + GHCupURL -> liftE $ getBase ghcupURL + (OwnSource url) -> liftE $ getBase url (OwnSpec av) -> pure av (AddSource (Left ext)) -> do - base <- liftE $ getBase dirs settings + base <- liftE $ getBase ghcupURL pure (mergeGhcupInfo base ext) (AddSource (Right uri)) -> do - base <- liftE $ getBase dirs settings - bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri - ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt) + base <- liftE $ getBase ghcupURL + ext <- liftE $ getBase uri pure (mergeGhcupInfo base ext) where @@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do in GHCupInfo tr newDownloads newGlobalTools -readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m) - => Dirs - -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo -readFromCache Dirs {..} = do - lift $ $(logWarn) - [i|Could not get download info, trying cached version (this may not be recent!)|] - let path = view pathL' ghcupURL - let yaml_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName $ path) - bs <- - handleIO' NoSuchThing - (\_ -> throwE $ FileDoesNotExistError yaml_file) - $ liftIO - $ L.readFile yaml_file - lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs) +readFromCache :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m) + => URI + -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString +readFromCache uri = do + Dirs{..} <- lift getDirs + let yaml_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri) + handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file) + . liftIO + . L.readFile + $ yaml_file -getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m) - => Dirs - -> Settings +getBase :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadLogger m + ) + => URI -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo -getBase dirs@Dirs{..} Settings{ downloader } = - handleIO (\_ -> readFromCache dirs) - $ catchE @_ @'[JSONError, FileDoesNotExistError] - (\(DownloadFailed _) -> readFromCache dirs) - (reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL) - >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict)) - where +getBase uri = do + Settings { noNetwork } <- lift getSettings + bs <- if noNetwork + then readFromCache uri + else handleIO (\_ -> warnCache >> readFromCache uri) + . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri) + . reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed + $ smartDl uri + liftE + . lE' @_ @_ @'[JSONError] JSONDecodeError + . first show + . Y.decodeEither' + . L.toStrict + $ bs + where + warnCache = lift $ $(logWarn) + [i|Could not get download info, trying cached version (this may not be recent!)|] + -- First check if the json file is in the ~/.ghcup/cache dir -- and check it's access time. If it has been accessed within the -- last 5 minutes, just reuse it. @@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } = -- than the local file. -- -- Always save the local file with the mod time of the remote file. - smartDl :: forall m1 - . ( MonadCatch m1 + smartDl :: forall m1 env1 + . ( MonadReader env1 m1 + , HasDirs env1 + , HasSettings env1 + , MonadCatch m1 , MonadIO m1 , MonadFail m1 , MonadLogger m1 @@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } = , NoLocationHeader , TooManyRedirs , ProcessError + , NoNetwork ] m1 L.ByteString smartDl uri' = do + Dirs{..} <- lift getDirs let path = view pathL' uri' let json_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName $ path) - e <- liftIO $ doesFileExist json_file + e <- liftIO $ doesFileExist json_file if e then do accessTime <- liftIO $ getAccessTime json_file @@ -237,11 +257,11 @@ getBase dirs@Dirs{..} Settings{ downloader } = where dlWithMod modTime json_file = do - bs <- liftE $ downloadBS downloader uri' + bs <- liftE $ downloadBS uri' liftIO $ writeFileWithModTime modTime json_file bs pure bs dlWithoutMod json_file = do - bs <- liftE $ downloadBS downloader uri' + bs <- liftE $ downloadBS uri' liftIO $ hideError doesNotExistErrorType $ rmFile json_file liftIO $ L.writeFile json_file bs liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0)) @@ -321,17 +341,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe -- 2. otherwise create a random file -- -- The file must not exist. -download :: ( MonadMask m +download :: ( MonadReader env m + , HasSettings env + , HasDirs env + , MonadMask m , MonadThrow m , MonadLogger m , MonadIO m ) - => Settings - -> DownloadInfo + => DownloadInfo -> FilePath -- ^ destination dir -> Maybe FilePath -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m FilePath -download settings@Settings{ downloader } dli dest mfn +download dli dest mfn | scheme == "https" = dl | scheme == "http" = dl | scheme == "file" = cp @@ -362,6 +384,8 @@ download settings@Settings{ downloader } dli dest mfn liftIO (hideError doesNotExistErrorType $ rmFile destFile) >> (throwE . DownloadFailed $ e) ) $ do + Settings{ downloader, noNetwork } <- lift getSettings + when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork])) case downloader of Curl -> do o' <- liftIO getCurlOpts @@ -377,58 +401,64 @@ download settings@Settings{ downloader } dli dest mfn liftE $ downloadToFile https host fullPath port destFile #endif - liftE $ checkDigest settings dli destFile + liftE $ checkDigest dli destFile pure destFile -- Manage to find a file we can write the body into. getDestFile :: FilePath - getDestFile = maybe (dest T.unpack (decUTF8Safe (urlBaseName path))) (dest ) mfn + getDestFile = maybe (dest T.unpack (decUTF8Safe (urlBaseName path))) + (dest ) + mfn - path = view (dlUri % pathL') dli + path = view (dlUri % pathL') dli -- | Download into tmpdir or use cached version, if it exists. If filename -- is omitted, infers the filename from the url. -downloadCached :: ( MonadMask m +downloadCached :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadMask m , MonadResource m , MonadThrow m , MonadLogger m , MonadIO m , MonadUnliftIO m ) - => Settings - -> Dirs - -> DownloadInfo + => DownloadInfo -> Maybe FilePath -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m FilePath -downloadCached settings@Settings{ cache } dirs dli mfn = do +downloadCached dli mfn = do + Settings{ cache } <- lift getSettings case cache of - True -> downloadCached' settings dirs dli mfn + True -> downloadCached' dli mfn False -> do tmp <- lift withGHCupTmpDir - liftE $ download settings dli tmp mfn + liftE $ download dli tmp mfn -downloadCached' :: ( MonadMask m +downloadCached' :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadMask m , MonadThrow m , MonadLogger m , MonadIO m , MonadUnliftIO m ) - => Settings - -> Dirs - -> DownloadInfo + => DownloadInfo -> Maybe FilePath -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m FilePath -downloadCached' settings Dirs{..} dli mfn = do +downloadCached' dli mfn = do + Dirs { cacheDir } <- lift getDirs let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do - liftE $ checkDigest settings dli cachfile + liftE $ checkDigest dli cachfile pure cachfile - | otherwise -> liftE $ download settings dli cacheDir mfn + | otherwise -> liftE $ download dli cacheDir mfn @@ -441,9 +471,13 @@ downloadCached' settings Dirs{..} dli mfn = do -- | This is used for downloading the JSON. -downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) - => Downloader - -> URI +downloadBS :: ( MonadReader env m + , HasSettings env + , MonadCatch m + , MonadIO m + , MonadLogger m + ) + => URI -> Excepts '[ FileDoesNotExistError , HTTPStatusError @@ -452,10 +486,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) , NoLocationHeader , TooManyRedirs , ProcessError + , NoNetwork ] m L.ByteString -downloadBS downloader uri' +downloadBS uri' | scheme == "https" = dl True | scheme == "http" @@ -475,6 +510,8 @@ downloadBS downloader uri' dl _ = do #endif lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] + Settings{ downloader, noNetwork } <- lift getSettings + when noNetwork $ throwE NoNetwork case downloader of Curl -> do o' <- liftIO getCurlOpts @@ -499,12 +536,18 @@ downloadBS downloader uri' #endif -checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m) - => Settings - -> DownloadInfo +checkDigest :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadIO m + , MonadThrow m + , MonadLogger m + ) + => DownloadInfo -> FilePath -> Excepts '[DigestError] m () -checkDigest Settings{ noVerify } dli file = do +checkDigest dli file = do + Settings{ noVerify } <- lift getSettings let verify = not noVerify when verify $ do let p' = takeFileName file diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index de9576c..a1366d7 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where pPrint (NoToolVersionSet tool) = text [i|No version is set for tool "#{tool}".|] +data NoNetwork = NoNetwork + deriving Show + +instance Pretty NoNetwork where + pPrint NoNetwork = + text [i|A download was required or requested, but '--offline' was specified.|] + ------------------------- --[ High-level errors ]-- diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 98ab2af..79ea220 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -297,11 +297,12 @@ data UserSettings = UserSettings , uDownloader :: Maybe Downloader , uKeyBindings :: Maybe UserKeyBindings , uUrlSource :: Maybe URLSource + , uNoNetwork :: Maybe Bool } deriving (Show, GHC.Generic) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data UserKeyBindings = UserKeyBindings { kUp :: Maybe Key @@ -353,13 +354,16 @@ data AppState = AppState , pfreq :: PlatformRequest } deriving (Show, GHC.Generic) +instance NFData AppState + data LeanAppState = LeanAppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings } deriving (Show, GHC.Generic) -instance NFData AppState +instance NFData LeanAppState + data Settings = Settings { cache :: Bool @@ -368,6 +372,7 @@ data Settings = Settings , downloader :: Downloader , verbose :: Bool , urlSource :: URLSource + , noNetwork :: Bool } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c8885c3..9f7165a 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1071,7 +1071,7 @@ ensureGlobalTools = do dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools - let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") + let dl = downloadCached' shimDownload (Just "gs.exe") void $ (\(DigestError _ _) -> do lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logDebug) [i|rm -f #{shimDownload}|] diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index b8af657..dd4db4b 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs import GHCup.Utils.File.Common import GHCup.Types +import GHCup.Types.Optics import Control.Concurrent import Control.DeepSeq diff --git a/stack.yaml b/stack.yaml index 38685ba..a4a83c6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,10 @@ extra-deps: - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 + - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 + - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 + - optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432 + - optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - regex-posix-clib-2.7 - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421 From eaad2caf2520115d274c599dfa63ca3446e50202 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 19 Jul 2021 16:49:18 +0200 Subject: [PATCH 08/10] Add prefetch command --- .gitlab/script/ghcup_version.sh | 10 ++- app/ghcup/Main.hs | 132 ++++++++++++++++++++++++++++++++ lib/GHCup.hs | 96 +++++++++++++++++------ lib/GHCup/Download.hs | 75 ++++++++++-------- 4 files changed, 252 insertions(+), 61 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 3da1a0f..cd14874 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -107,17 +107,19 @@ else # test installing new ghc doesn't mess with currently set GHC # https://gitlab.haskell.org/haskell/ghcup-hs/issues/7 if [ "${OS}" = "LINUX" ] ; then - eghcup --downloader=wget install 8.10.3 + eghcup --downloader=wget prefetch ghc 8.10.3 + eghcup --offline install ghc 8.10.3 else # test wget a bit - eghcup install 8.10.3 + eghcup prefetch ghc 8.10.3 + eghcup --offline install ghc 8.10.3 fi [ "$(ghc --numeric-version)" = "${ghc_ver}" ] - eghcup set 8.10.3 + eghcup --offline set 8.10.3 eghcup set 8.10.3 [ "$(ghc --numeric-version)" = "8.10.3" ] eghcup set ${GHC_VERSION} [ "$(ghc --numeric-version)" = "${ghc_ver}" ] - eghcup rm 8.10.3 + eghcup --offline rm 8.10.3 [ "$(ghc --numeric-version)" = "${ghc_ver}" ] if [ "${OS}" = "DARWIN" ] ; then diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index a7224d4..389dc8a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -112,6 +112,7 @@ data Command #if defined(BRICK) | Interactive #endif + | Prefetch PrefetchCommand data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal | ToolTag Tag @@ -201,6 +202,21 @@ data WhereisOptions = WhereisOptions { directory :: Bool } +data PrefetchOptions = PrefetchOptions { + pfCacheDir :: Maybe FilePath +} + +data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion) + | PrefetchCabal PrefetchOptions (Maybe ToolVersion) + | PrefetchHLS PrefetchOptions (Maybe ToolVersion) + | PrefetchStack PrefetchOptions (Maybe ToolVersion) + | PrefetchMetadata + +data PrefetchGHCOptions = PrefetchGHCOptions { + pfGHCSrc :: Bool + , pfGHCCacheDir :: Maybe FilePath +} + -- https://github.com/pcapriotti/optparse-applicative/issues/148 @@ -359,6 +375,16 @@ com = (progDesc "Find a tools location" <> footerDoc ( Just $ text whereisFooter )) ) + <> command + "prefetch" + (info + ( (Prefetch + <$> prefetchP + ) <**> helper + ) + (progDesc "Prefetch assets" + <> footerDoc ( Just $ text prefetchFooter )) + ) <> commandGroup "Main commands:" ) <|> subparser @@ -442,6 +468,17 @@ Examples: # outputs ~/.ghcup/bin/ ghcup whereis --directory cabal 3.4.0.0|] + prefetchFooter :: String + prefetchFooter = [s|Discussion: + Prefetches tools or assets into "~/.ghcup/cache" directory. This can + be then combined later with '--offline' flag, ensuring all assets that + are required for offline use have been prefetched. + +Examples: + ghcup prefetch metadata + ghcup prefetch ghc 8.10.5 + ghcup --offline install ghc 8.10.5|] + installCabalFooter :: String installCabalFooter = [s|Discussion: @@ -827,6 +864,55 @@ Examples: ghcup whereis --directory stack 2.7.1|] +prefetchP :: Parser PrefetchCommand +prefetchP = subparser + ( command + "ghc" + (info + (PrefetchGHC + <$> (PrefetchGHCOptions + <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) + <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just GHC)) )) + ( progDesc "Download GHC assets for installation") + ) + <> + command + "cabal" + (info + (PrefetchCabal + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )) + ( progDesc "Download cabal assets for installation") + ) + <> + command + "hls" + (info + (PrefetchHLS + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )) + ( progDesc "Download HLS assets for installation") + ) + <> + command + "stack" + (info + (PrefetchStack + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )) + ( progDesc "Download stack assets for installation") + ) + <> + command + "metadata" + (const PrefetchMetadata <$> info + helper + ( progDesc "Download ghcup's metadata, needed for various operations") + ) + ) + + ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = GHCCompileOptions @@ -1478,6 +1564,21 @@ Report bugs at |] , DownloadFailed ] + let runPrefetch = + runLogger + . runAppState + . runResourceT + . runE + @'[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + , NoDownload + , DigestError + , DownloadFailed + , JSONError + , FileDoesNotExistError + ] + ----------------------- -- Command functions -- @@ -1994,6 +2095,37 @@ Make sure to clean up #{tmpdir} afterwards.|]) VLeft e -> do runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 15 + Prefetch pfCom -> + runPrefetch (do + case pfCom of + PrefetchGHC + (PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt GHC + if pfGHCSrc + then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir + else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir + PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt Cabal + liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir + PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt HLS + liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir + PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt Stack + liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir + PrefetchMetadata -> do + _ <- liftE $ getDownloadsF + pure "" + ) >>= \case + VRight _ -> do + pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 15 case res of diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8a8e3e0..9d0cbff 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -95,6 +95,69 @@ import GHCup.Utils.MegaParsec import Control.Concurrent (threadDelay) + --------------------- + --[ Tool fetching ]-- + --------------------- + + +fetchToolBindist :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Tool + -> Maybe FilePath + -> Excepts + '[ DigestError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchToolBindist v t mfp = do + dlinfo <- liftE $ getDownloadInfo t v + liftE $ downloadCached' dlinfo Nothing mfp + + +fetchGHCSrc :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Maybe FilePath + -> Excepts + '[ DigestError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchGHCSrc v mfp = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlInfo <- + preview (ix GHC % ix v % viSourceDL % _Just) dls + ?? NoDownload + liftE $ downloadCached' dlInfo Nothing mfp + + ------------------------- --[ Tool installation ]-- @@ -284,9 +347,7 @@ installGHCBin :: ( MonadFail m m () installGHCBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls + dlinfo <- liftE $ getDownloadInfo GHC ver installGHCBindist dlinfo ver @@ -405,10 +466,7 @@ installCabalBin :: ( MonadMask m m () installCabalBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls + dlinfo <- liftE $ getDownloadInfo Cabal ver installCabalBindist dlinfo ver @@ -536,10 +594,7 @@ installHLSBin :: ( MonadMask m m () installHLSBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls + dlinfo <- liftE $ getDownloadInfo HLS ver installHLSBindist dlinfo ver @@ -576,10 +631,7 @@ installStackBin :: ( MonadMask m m () installStackBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls + dlinfo <- liftE $ getDownloadInfo Stack ver installStackBindist dlinfo ver @@ -1128,12 +1180,9 @@ listVersions lt' criteria = do -> (Version, [Tag]) -> m ListResult toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do - pfreq <- getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - case t of GHC -> do - let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v let tver = mkTVer v lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lInstalled <- ghcInstalled tver @@ -1141,7 +1190,7 @@ listVersions lt' criteria = do hlsPowered <- fmap (elem v) hlsGHCVersions pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } Cabal -> do - let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v let lSet = cSet == Just v let lInstalled = elem v $ rights cabals pure ListResult { lVer = v @@ -1167,7 +1216,7 @@ listVersions lt' criteria = do , .. } HLS -> do - let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v let lSet = hlsSet' == Just v let lInstalled = elem v $ rights hlses pure ListResult { lVer = v @@ -1180,7 +1229,7 @@ listVersions lt' criteria = do , .. } Stack -> do - let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v let lSet = stackSet' == Just v let lInstalled = elem v $ rights stacks pure ListResult { lVer = v @@ -1922,13 +1971,12 @@ upgradeGHCup :: ( MonadMask m Version upgradeGHCup mtarget force' = do Dirs {..} <- lift getDirs - pfreq <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ fst <$> getLatest dls GHCup when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate - dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls + dli <- liftE $ getDownloadInfo GHCup latestVer tmp <- lift withGHCupTmpDir let fn = "ghcup" <> exeExt p <- liftE $ download dli tmp (Just fn) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 54a60e4..b9f0125 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -299,39 +299,46 @@ getBase uri = do setModificationTime path utctime -getDownloadInfo :: Tool +getDownloadInfo :: ( MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + ) + => Tool -> Version -- ^ tool version - -> PlatformRequest - -> GHCupDownloads - -> Either NoDownload DownloadInfo -getDownloadInfo t v (PlatformRequest a p mv) dls = maybe - (Left NoDownload) - Right - (case p of - -- non-musl won't work on alpine - Linux Alpine -> with_distro <|> without_distro_ver - _ -> with_distro <|> without_distro_ver <|> without_distro - ) + -> Excepts + '[NoDownload] + m + DownloadInfo +getDownloadInfo t v = do + (PlatformRequest a p mv) <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - where - with_distro = distro_preview id id - without_distro_ver = distro_preview id (const Nothing) - without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) + let distro_preview f g = + let platformVersionSpec = + preview (ix t % ix v % viArch % ix a % ix (f p)) dls + mv' = g mv + in fmap snd + . find + (\(mverRange, _) -> maybe + (isNothing mv') + (\range -> maybe False (`versionRange` range) mv') + mverRange + ) + . M.toList + =<< platformVersionSpec + with_distro = distro_preview id id + without_distro_ver = distro_preview id (const Nothing) + without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) - distro_preview f g = - let platformVersionSpec = - preview (ix t % ix v % viArch % ix a % ix (f p)) dls - mv' = g mv - in fmap snd - . find - (\(mverRange, _) -> maybe - (isNothing mv') - (\range -> maybe False (`versionRange` range) mv') - mverRange - ) - . M.toList - =<< platformVersionSpec + maybe + (throwE NoDownload) + pure + (case p of + -- non-musl won't work on alpine + Linux Alpine -> with_distro <|> without_distro_ver + _ -> with_distro <|> without_distro_ver <|> without_distro + ) -- | Tries to download from the given http or https url @@ -431,7 +438,7 @@ downloadCached :: ( MonadReader env m downloadCached dli mfn = do Settings{ cache } <- lift getSettings case cache of - True -> downloadCached' dli mfn + True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir liftE $ download dli tmp mfn @@ -448,17 +455,19 @@ downloadCached' :: ( MonadReader env m ) => DownloadInfo -> Maybe FilePath -- ^ optional filename + -> Maybe FilePath -- ^ optional destination dir (default: cacheDir) -> Excepts '[DigestError , DownloadFailed] m FilePath -downloadCached' dli mfn = do +downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs + let destDir = fromMaybe cacheDir mDestDir let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn - let cachfile = cacheDir fn + let cachfile = destDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do liftE $ checkDigest dli cachfile pure cachfile - | otherwise -> liftE $ download dli cacheDir mfn + | otherwise -> liftE $ download dli destDir mfn From bc13a4555d55934d8a7beaaba132b0c37fd19e05 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 19 Jul 2021 16:56:28 +0200 Subject: [PATCH 09/10] Fix runLeanWhereIs on windows --- app/ghcup/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 389dc8a..3c37ec1 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1533,7 +1533,9 @@ Report bugs at |] let runLeanWhereIs = runLogger - . runLeanAppState + -- Don't use runLeanAppState here, which is disabled on windows. + -- This is the only command on all platforms that doesn't need full appstate. + . flip runReaderT leanAppstate . runE @'[ NotInstalled , NoToolVersionSet From 3caf91c640fdb0aade7714345eeea0c97174b34a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 19 Jul 2021 19:08:43 +0200 Subject: [PATCH 10/10] Fix ensureGlobalTools --- lib/GHCup/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 9f7165a..fe2e4a0 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1071,7 +1071,7 @@ ensureGlobalTools = do dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools - let dl = downloadCached' shimDownload (Just "gs.exe") + let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\(DigestError _ _) -> do lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logDebug) [i|rm -f #{shimDownload}|]