hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'issue-180'

Browse Source
This commit is contained in:
Julian Ospald 2021-07-19 20:55:17 +02:00
commit 5217aa0a1d
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
19 changed files with 1209 additions and 521 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
.gitlab-ci.yml
View File

@ -21,6 +21,7 @@ variables:
OS: "LINUX" OS: "LINUX"
ARCH: "64" ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal" CABAL_DIR: "$CI_PROJECT_DIR/cabal"
CROSS: ""
.alpine:64bit: .alpine:64bit:
image: "alpine:3.12" image: "alpine:3.12"
@ -268,6 +269,24 @@ test:linux:latest:
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
needs: [] 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 ######## ######## linux 32bit test ########
test:linux:recommended:32bit: test:linux:recommended:32bit:
@ -286,6 +305,7 @@ test:linux:recommended:armv7:
variables: variables:
GHC_VERSION: "8.10.4" GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
CROSS: ""
when: manual when: manual
needs: [] needs: []
@ -295,6 +315,7 @@ test:linux:recommended:aarch64:
variables: variables:
GHC_VERSION: "8.10.4" GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
CROSS: ""
when: manual when: manual
needs: [] needs: []
@ -394,6 +415,7 @@ release:linux:armv7:
ARTIFACT: "armv7-linux-ghcup" ARTIFACT: "armv7-linux-ghcup"
GHC_VERSION: "8.10.4" GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
CROSS: ""
release:linux:aarch64: release:linux:aarch64:
stage: release stage: release
@ -407,6 +429,7 @@ release:linux:aarch64:
ARTIFACT: "aarch64-linux-ghcup" ARTIFACT: "aarch64-linux-ghcup"
GHC_VERSION: "8.10.4" GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
CROSS: ""
######## darwin release ######## ######## darwin release ########

13
.gitlab/before_script/linux/install_deps.sh
View File

@ -9,6 +9,13 @@ mkdir -p "${TMPDIR}"
sudo apt-get update -y 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 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 case "${ARCH}" in
ARM*) ARM*)
case "${ARCH}" in case "${ARCH}" in
@ -57,9 +64,9 @@ case "${ARCH}" in
chmod +x ghcup-bin chmod +x ghcup-bin
./ghcup-bin upgrade -i -f ./ghcup-bin upgrade -i -f
./ghcup-bin install ${GHC_VERSION} ./ghcup-bin install ghc ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION} ./ghcup-bin set ghc ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION} ./ghcup-bin install cabal ${CABAL_VERSION}
;; ;;
esac esac

52
.gitlab/script/ghcup_cross.sh Executable file
View File

@ -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" ]

4
.gitlab/script/ghcup_release.sh
View File

@ -15,10 +15,6 @@ git describe
# build # build
ecabal update ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "LINUX" ] ; then if [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then if [ "${ARCH}" = "32" ] ; then

21
.gitlab/script/ghcup_version.sh
View File

@ -26,11 +26,6 @@ git describe --always
ecabal update ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test 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 --numeric-version
eghcup install ${GHC_VERSION} eghcup install ghc ${GHC_VERSION}
[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
eghcup set ${GHC_VERSION} eghcup set ghc ${GHC_VERSION}
eghcup install-cabal ${CABAL_VERSION} eghcup install cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
cabal --version cabal --version
@ -112,17 +107,19 @@ else
# test installing new ghc doesn't mess with currently set GHC # test installing new ghc doesn't mess with currently set GHC
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7 # https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
if [ "${OS}" = "LINUX" ] ; then 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 else # test wget a bit
eghcup install 8.10.3 eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
fi fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ] [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup set 8.10.3 eghcup --offline set 8.10.3
eghcup set 8.10.3 eghcup set 8.10.3
[ "$(ghc --numeric-version)" = "8.10.3" ] [ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VERSION} eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ] [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup rm 8.10.3 eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ] [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then

12
app/ghcup-gen/Validate.hs
View File

@ -12,7 +12,7 @@ import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Platform import GHCup.Platform
import GHCup.Types import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Logger import GHCup.Utils.Logger
@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
, rawOutter = \_ -> pure () , rawOutter = \_ -> pure ()
} }
downloadAll dli = do downloadAll dli = do
dirs <- liftIO getDirs dirs <- liftIO getAllDirs
pfreq <- ( pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
($(logError) $ T.pack $ prettyShow e) ($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2) 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 <- r <-
runLogger runLogger
@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
case etool of case etool of
Right (Just GHCup) -> do Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing _ <- liftE $ download dli tmpUnpack Nothing
pure Nothing pure Nothing
Right _ -> do Right _ -> do
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head) fmap (Just . head . splitDirectories . head)
. liftE . liftE
. getArchiveFiles . getArchiveFiles
$ p $ p
Left ShimGen -> do Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing _ <- liftE $ download dli tmpUnpack Nothing
pure Nothing pure Nothing
case r of case r of
VRight (Just basePath) -> do VRight (Just basePath) -> do

16
app/ghcup/BrickMain.hs
View File

@ -13,7 +13,7 @@ module BrickMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File import GHCup.Utils.File
@ -53,8 +53,6 @@ import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import qualified GHCup.Types as GT
import qualified Data.Text as T import qualified Data.Text as T
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
import qualified Data.Vector as V import qualified Data.Vector as V
@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do
settings' :: IORef AppState settings' :: IORef AppState
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do settings' = unsafePerformIO $ do
dirs <- getDirs dirs <- getAllDirs
newIORef $ AppState (Settings { cache = True newIORef $ AppState (Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, urlSource = GHCupURL , urlSource = GHCupURL
, noNetwork = False
, .. , ..
}) })
dirs dirs
@ -578,9 +577,8 @@ logger' = unsafePerformIO
brickMain :: AppState brickMain :: AppState
-> LoggerConfig -> LoggerConfig
-> GHCupInfo
-> IO () -> IO ()
brickMain s l gi = do brickMain s l = do
writeIORef settings' s writeIORef settings' s
-- logger interpreter -- logger interpreter
writeIORef logger' l writeIORef logger' l
@ -588,7 +586,7 @@ brickMain s l gi = do
no_color <- isJust <$> lookupEnv "NO_COLOR" no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just gi) eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of case eAppData of
Right ad -> Right ad ->
defaultMain defaultMain
@ -596,7 +594,7 @@ brickMain s l gi = do
(BrickState ad (BrickState ad
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)
(keyBindings s) (keyBindings (s :: AppState))
) )
$> () $> ()
@ -620,7 +618,7 @@ getGHCupInfo = do
. flip runReaderT settings . flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError] . runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF (GT.settings settings) (GT.dirs settings) $ getDownloadsF
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a

587
app/ghcup/Main.hs
View File

@ -21,6 +21,7 @@ import GHCup.Errors
import GHCup.Platform import GHCup.Platform
import GHCup.Requirements import GHCup.Requirements
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
@ -66,7 +67,6 @@ import System.Environment
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.IO hiding ( appendFile ) import System.IO hiding ( appendFile )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Text.Read hiding ( lift ) import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
@ -91,6 +91,7 @@ data Options = Options
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader , optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
-- commands -- commands
, optCommand :: Command , optCommand :: Command
} }
@ -111,6 +112,7 @@ data Command
#if defined(BRICK) #if defined(BRICK)
| Interactive | Interactive
#endif #endif
| Prefetch PrefetchCommand
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag | ToolTag Tag
@ -200,6 +202,21 @@ data WhereisOptions = WhereisOptions {
directory :: Bool 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 -- https://github.com/pcapriotti/optparse-applicative/issues/148
@ -277,6 +294,7 @@ opts =
#endif #endif
<> hidden <> hidden
)) ))
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> com <*> com
where where
parseUri s' = parseUri s' =
@ -357,6 +375,16 @@ com =
(progDesc "Find a tools location" (progDesc "Find a tools location"
<> footerDoc ( Just $ text whereisFooter )) <> footerDoc ( Just $ text whereisFooter ))
) )
<> command
"prefetch"
(info
( (Prefetch
<$> prefetchP
) <**> helper
)
(progDesc "Prefetch assets"
<> footerDoc ( Just $ text prefetchFooter ))
)
<> commandGroup "Main commands:" <> commandGroup "Main commands:"
) )
<|> subparser <|> subparser
@ -440,6 +468,17 @@ Examples:
# outputs ~/.ghcup/bin/ # outputs ~/.ghcup/bin/
ghcup whereis --directory cabal 3.4.0.0|] 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 :: String
installCabalFooter = [s|Discussion: installCabalFooter = [s|Discussion:
@ -825,6 +864,55 @@ Examples:
ghcup whereis --directory stack 2.7.1|] 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 :: Parser GHCCompileOptions
ghcCompileOpts = ghcCompileOpts =
GHCCompileOptions GHCCompileOptions
@ -942,14 +1030,20 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getDirs dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
, rawOutter = mempty , rawOutter = mempty
} }
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of case mGhcUpInfo of
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old) let allTags = filter (\t -> t /= Old)
@ -962,19 +1056,24 @@ tagCompleter tool add = listIOCompleter $ do
versionCompleter :: Maybe ListCriteria -> Tool -> Completer versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
, rawOutter = mempty , rawOutter = mempty
} }
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs' settings = Settings True False Never Curl False GHCupURL True
mpFreq <- runLogger . runE $ platformRequest let leanAppState = LeanAppState
forFold mpFreq $ \pfreq -> 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 forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState let appState = AppState
(Settings True False Never Curl False GHCupURL) settings
dirs' dirs'
defaultKeyBindings defaultKeyBindings
ghcupInfo ghcupInfo
@ -1123,6 +1222,7 @@ toSettings options = do
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@ -1167,8 +1267,10 @@ describe_result :: String
describe_result = $( LitE . StringL <$> describe_result = $( LitE . StringL <$>
runIO (do runIO (do
CapturedProcess{..} <- do CapturedProcess{..} <- do
dirs <- liftIO getDirs 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 flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
@ -1220,7 +1322,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer)) (footerDoc (Just $ text main_footer))
) )
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
dirs <- getDirs dirs@Dirs{..} <- getAllDirs
-- create ~/.ghcup dir -- create ~/.ghcup dir
ensureDirectories dirs ensureDirectories dirs
@ -1228,7 +1330,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt (settings, keybindings) <- toSettings opt
-- logger interpreter -- logger interpreter
logfile <- initGHCupFileLogging (logsDir dirs) logfile <- initGHCupFileLogging logsDir
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings { lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
@ -1240,68 +1342,64 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () } let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- unsafeInterleaveIO $ (
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 <- unsafeInterleaveIO $
( 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 -- -- Setting up appstate --
------------------------- -------------------------
let appstate@AppState{dirs = Dirs{..} let leanAppstate = LeanAppState settings dirs keybindings
, ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. } appState = do
} = AppState settings dirs keybindings ghcupInfo pfreq 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
. flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
)
>>= \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'
--------------------------- #if defined(IS_WINDOWS)
-- Running startup tasks -- -- 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'
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)
------------------------- -------------------------
@ -1310,7 +1408,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform = let runInstTool' appstate' mInstPlatform =
runLogger runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform) . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1331,12 +1429,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet , NoToolVersionSet
] ]
let runInstTool = runInstTool' appstate let runInstTool mInstPlatform action' = do
s' <- liftIO appState
runInstTool' s' mInstPlatform action'
let let
runLeanSetGHC =
runLogger
. runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetGHC = runSetGHC =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -1346,9 +1457,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let let
runLeanSetCabal =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetCabal = runSetCabal =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1359,7 +1480,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetHLS = runSetHLS =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1367,20 +1488,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet , NoToolVersionSet
] ]
let runListGHC = runLogger . flip runReaderT appstate runLeanSetHLS =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runRm = let runRm =
runLogger . flip runReaderT appstate . runE @'[NotInstalled] runLogger . runAppState . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1400,9 +1531,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let let
runLeanWhereIs =
runLogger
-- 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
, NextVerNotFound
, TagNotFound
]
runWhereIs = runWhereIs =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, NoToolVersionSet , NoToolVersionSet
@ -1412,7 +1555,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runUpgrade = let runUpgrade =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
@ -1423,6 +1566,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, DownloadFailed , DownloadFailed
] ]
let runPrefetch =
runLogger
. runAppState
. runResourceT
. runE
@'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, DownloadFailed
, JSONError
, FileDoesNotExistError
]
----------------------- -----------------------
-- Command functions -- -- Command functions --
@ -1435,13 +1593,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installGHCBin (_tvVersion v) liftE $ installGHCBin (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer GHC s' <- liftIO appState
liftE $ installGHCBindist runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (v, vi) <- liftE $ fromVersion instVer GHC
(_tvVersion v) liftE $ installGHCBindist
when instSet $ void $ liftE $ setGHC v SetGHCOnly (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
pure vi (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1473,12 +1633,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) liftE $ installCabalBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer Cabal s' <- appState
liftE $ installCabalBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer Cabal
(_tvVersion v) liftE $ installCabalBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1502,12 +1664,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) liftE $ installHLSBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer HLS s' <- appState
liftE $ installHLSBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer HLS
(_tvVersion v) liftE $ installHLSBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1531,12 +1695,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) liftE $ installStackBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer Stack s' <- appState
liftE $ installStackBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer Stack
(_tvVersion v) liftE $ installStackBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1555,11 +1721,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4 pure $ ExitFailure 4
let setGHC' SetOptions{..} = let setGHC' SetOptions{ sToolVer } =
runSetGHC (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer GHC (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
liftE $ setGHC v SetGHCOnly _ -> runSetGHC (do
) v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1570,12 +1738,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 5 pure $ ExitFailure 5
let setCabal' SetOptions{..} = let setCabal' SetOptions{ sToolVer } =
runSetCabal (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer Cabal (SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
liftE $ setCabal (_tvVersion v) _ -> runSetCabal (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer Cabal
) liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1586,12 +1756,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setHLS' SetOptions{..} = let setHLS' SetOptions{ sToolVer } =
runSetHLS (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer HLS (SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
liftE $ setHLS (_tvVersion v) _ -> runSetHLS (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer HLS
) liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1602,12 +1774,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setStack' SetOptions{..} = let setStack' SetOptions{ sToolVer } =
runSetCabal (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer Stack (SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
liftE $ setStack (_tvVersion v) _ -> runSetCabal (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer Stack
) liftE $ setStack (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1622,6 +1796,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls) pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
) )
>>= \case >>= \case
@ -1637,6 +1812,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls) pure (getVersionInfo tv Cabal dls)
) )
>>= \case >>= \case
@ -1652,6 +1828,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls) pure (getVersionInfo tv HLS dls)
) )
>>= \case >>= \case
@ -1667,6 +1844,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmStackVer tv rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls) pure (getVersionInfo tv Stack dls)
) )
>>= \case >>= \case
@ -1681,7 +1859,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> do Interactive -> do
liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@ -1731,6 +1910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runCompileGHC (do runCompileGHC (do
case targetGhc of case targetGhc of
Left targetVer -> do Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg lift $ $(logInfo) msg
@ -1746,6 +1926,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig buildConfig
patchDir patchDir
addConfArgs addConfArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly setGHC targetVer SetGHCOnly
@ -1773,6 +1954,21 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9 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) -> Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
runWhereIs (do runWhereIs (do
(v, _) <- liftE $ fromVersion whereVer tool (v, _) <- liftE $ fromVersion whereVer tool
@ -1797,6 +1993,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
runUpgrade (liftE $ upgradeGHCup target force') >>= \case runUpgrade (liftE $ upgradeGHCup target force') >>= \case
VRight v' -> do VRight v' -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) runLogger $ $(logInfo)
@ -1811,23 +2008,26 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11 pure $ ExitFailure 11
ToolRequirements -> ToolRequirements -> do
flip runReaderT appstate s' <- appState
$ runLogger flip runReaderT s'
(runE $ runLogger
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] (runE
$ do @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
platform <- liftE getPlatform $ do
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements GHCupInfo { .. } <- lift getGHCupInfo
liftIO $ T.hPutStr stdout (prettyRequirements req) platform' <- liftE getPlatform
) req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
>>= \case liftIO $ T.hPutStr stdout (prettyRequirements req)
VRight _ -> pure ExitSuccess )
VLeft e -> do >>= \case
runLogger $ $(logError) $ T.pack $ prettyShow e VRight _ -> pure ExitSuccess
pure $ ExitFailure 12 VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do ChangeLog ChangeLogOptions{..} -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool let tool = fromMaybe GHC clTool
ver' = maybe ver' = maybe
(Right Latest) (Right Latest)
@ -1845,6 +2045,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
) )
pure ExitSuccess pure ExitSuccess
Just uri -> do Just uri -> do
pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of cmd = case _rPlatform pfreq of
Darwin -> "open" Darwin -> "open"
@ -1853,21 +2054,23 @@ Make sure to clean up #{tmpdir} afterwards.|])
Windows -> "start" Windows -> "start"
if clOpen if clOpen
then then do
flip runReaderT appstate $ s' <- appState
exec cmd flip runReaderT s' $
[T.unpack $ decUTF8Safe $ serializeURIRef' uri] exec cmd
Nothing [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing Nothing
>>= \case Nothing
Right _ -> pure ExitSuccess >>= \case
Left e -> runLogger ($(logError) [i|#{e}|]) Right _ -> pure ExitSuccess
>> pure (ExitFailure 13) Left e -> runLogger ($(logError) [i|#{e}|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess else putStrLn uri' >> pure ExitSuccess
Nuke -> Nuke ->
runRm (do 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 "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." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s liftIO $ threadDelay 10000000 -- wait 10s
@ -1894,6 +2097,37 @@ Make sure to clean up #{tmpdir} afterwards.|])
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15 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 case res of
@ -1903,22 +2137,46 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure () 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 => Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) -> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv) 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 => SetToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) -> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do fromVersion' (SetToolVersion v) tool = do
~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
@ -1928,16 +2186,16 @@ fromVersion' (SetToolVersion v) tool = do
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
Right _ -> pure (v, vi) Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do fromVersion' SetNext tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of next <- case tool of
GHC -> do GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
@ -2138,7 +2396,10 @@ printListResult raw lr = do
| otherwise -> 1 | otherwise -> 1
checkForUpdates :: ( MonadReader AppState m checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -2148,7 +2409,7 @@ checkForUpdates :: ( MonadReader AppState m
) )
=> m () => m ()
checkForUpdates = do checkForUpdates = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled) lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled

4
ghcup.cabal
View File

@ -116,7 +116,7 @@ library
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31 , monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics >=0.2 && <0.5 , optics ^>=0.4
, optics-vl ^>=0.2 , optics-vl ^>=0.2
, os-release ^>=1.0.0 , os-release ^>=1.0.0
, parsec ^>=3.1 , parsec ^>=3.1
@ -279,7 +279,7 @@ executable ghcup-gen
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
, monad-logger ^>=0.3.31 , monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics >=0.2 && <0.5 , optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17 , optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1 , pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0 , pretty-terminal ^>=0.1.0.0

445
lib/GHCup.hs
View File

@ -95,6 +95,69 @@ import GHCup.Utils.MegaParsec
import Control.Concurrent (threadDelay) 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 ]-- --[ Tool installation ]--
@ -106,7 +169,10 @@ import Control.Concurrent (threadDelay)
installGHCBindist :: ( MonadFail m installGHCBindist :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -130,14 +196,12 @@ installGHCBindist :: ( MonadFail m
m m
() ()
installGHCBindist dlinfo ver = do installGHCBindist dlinfo ver = do
AppState { dirs , settings } <- lift ask
let tver = mkTVer ver let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
@ -163,7 +227,10 @@ installGHCBindist dlinfo ver = do
-- build system and nothing else. -- build system and nothing else.
installPackedGHC :: ( MonadMask m installPackedGHC :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -182,7 +249,7 @@ installPackedGHC :: ( MonadMask m
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver = do installPackedGHC dl msubdir inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask PlatformRequest {..} <- lift getPlatformReq
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@ -201,7 +268,10 @@ installPackedGHC dl msubdir inst ver = do
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else. -- build system and nothing else.
installUnpackedGHC :: ( MonadReader AppState m installUnpackedGHC :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -218,7 +288,7 @@ installUnpackedGHC path inst _ = do
liftIO $ copyDirectoryRecursive path inst liftIO $ copyDirectoryRecursive path inst
#else #else
installUnpackedGHC path inst ver = do installUnpackedGHC path inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask PlatformRequest {..} <- lift getPlatformReq
let alpineArgs let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@ -250,7 +320,11 @@ installUnpackedGHC path inst ver = do
installGHCBin :: ( MonadFail m installGHCBin :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -273,9 +347,7 @@ installGHCBin :: ( MonadFail m
m m
() ()
installGHCBin ver = do installGHCBin ver = do
AppState { pfreq dlinfo <- liftE $ getDownloadInfo GHC ver
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls
installGHCBindist dlinfo ver installGHCBindist dlinfo ver
@ -283,7 +355,10 @@ installGHCBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m installCabalBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -310,9 +385,8 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver = do installCabalBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} Dirs {..} <- lift getDirs
, settings } <- lift ask
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
@ -324,10 +398,10 @@ installCabalBindist dlinfo ver = do
(throwE $ AlreadyInstalled Cabal ver) (throwE $ AlreadyInstalled Cabal ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -364,7 +438,11 @@ installCabalBindist dlinfo ver = do
-- the latest installed version. -- the latest installed version.
installCabalBin :: ( MonadMask m installCabalBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -388,9 +466,7 @@ installCabalBin :: ( MonadMask m
m m
() ()
installCabalBin ver = do installCabalBin ver = do
AppState { pfreq dlinfo <- liftE $ getDownloadInfo Cabal ver
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls
installCabalBindist dlinfo ver installCabalBindist dlinfo ver
@ -398,7 +474,10 @@ installCabalBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m installHLSBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -425,18 +504,17 @@ installHLSBindist :: ( MonadMask m
installHLSBindist dlinfo ver = do installHLSBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} Dirs {..} <- lift getDirs
, settings } <- lift ask
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver) (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -488,7 +566,11 @@ installHLSBindist dlinfo ver = do
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m installHLSBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -512,9 +594,7 @@ installHLSBin :: ( MonadMask m
m m
() ()
installHLSBin ver = do installHLSBin ver = do
AppState { pfreq dlinfo <- liftE $ getDownloadInfo HLS ver
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls
installHLSBindist dlinfo ver installHLSBindist dlinfo ver
@ -523,7 +603,11 @@ installHLSBin ver = do
-- the latest installed version. -- the latest installed version.
installStackBin :: ( MonadMask m installStackBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -547,8 +631,7 @@ installStackBin :: ( MonadMask m
m m
() ()
installStackBin ver = do installStackBin ver = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask dlinfo <- liftE $ getDownloadInfo Stack ver
dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls
installStackBindist dlinfo ver installStackBindist dlinfo ver
@ -556,7 +639,10 @@ installStackBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m installStackBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -583,19 +669,17 @@ installStackBindist :: ( MonadMask m
installStackBindist dlinfo ver = do installStackBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|] lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} Dirs {..} <- lift getDirs
, settings
} <- lift ask
whenM (lift (stackInstalled ver)) whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver) (throwE $ AlreadyInstalled Stack ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -644,7 +728,8 @@ installStackBindist dlinfo ver = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader AppState m setGHC :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -663,7 +748,7 @@ setGHC ver sghc = do
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination -- symlink destination
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup) -- with old ghcup)
@ -701,12 +786,15 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m)
=> FilePath => FilePath
-> String -> String
-> m () -> m ()
symlinkShareDir ghcdir ver' = do symlinkShareDir ghcdir ver' = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
let destdir = baseDir let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
@ -733,7 +821,8 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: ( MonadMask m setCabal :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -745,7 +834,7 @@ setCabal ver = do
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination -- symlink destination
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile)) whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE $ throwE
@ -764,7 +853,8 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks. -- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m setHLS :: ( MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -775,7 +865,7 @@ setHLS :: ( MonadCatch m
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setHLS ver = do setHLS ver = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
-- Delete old symlinks, since these might have different ghc versions than the -- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks. -- selected version, so we could end up with stray or incorrect symlinks.
@ -804,7 +894,8 @@ setHLS ver = do
-- | Set the @~\/.ghcup\/bin\/stack@ symlink. -- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m setStack :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -817,7 +908,7 @@ setStack ver = do
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination -- symlink destination
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile)) whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE $ throwE
@ -872,7 +963,10 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
) )
=> Maybe Tool => Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
@ -891,7 +985,7 @@ listVersions lt' criteria = do
go lt cSet cabals hlsSet' hlses sSet stacks = do go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of case lt of
Just t -> do Just t -> do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-- get versions from GHCupDownloads -- get versions from GHCupDownloads
let avTools = availableToolVersions dls t let avTools = availableToolVersions dls t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
@ -917,7 +1011,13 @@ listVersions lt' criteria = do
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -959,7 +1059,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
@ -988,7 +1094,12 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayHLS avTools = do strayHLS avTools = do
@ -1016,7 +1127,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayStacks avTools = do strayStacks avTools = do
@ -1045,7 +1162,14 @@ listVersions lt' criteria = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- 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 => Tool
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
@ -1056,12 +1180,9 @@ listVersions lt' criteria = do
-> (Version, [Tag]) -> (Version, [Tag])
-> m ListResult -> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case t of case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq dls lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
let tver = mkTVer v let tver = mkTVer v
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
@ -1069,7 +1190,7 @@ listVersions lt' criteria = do
hlsPowered <- fmap (elem v) hlsGHCVersions hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do 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 lSet = cSet == Just v
let lInstalled = elem v $ rights cabals let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v pure ListResult { lVer = v
@ -1095,7 +1216,7 @@ listVersions lt' criteria = do
, .. , ..
} }
HLS -> 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 lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v pure ListResult { lVer = v
@ -1108,7 +1229,7 @@ listVersions lt' criteria = do
, .. , ..
} }
Stack -> 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 lSet = stackSet' == Just v
let lInstalled = elem v $ rights stacks let lInstalled = elem v $ rights stacks
pure ListResult { lVer = v pure ListResult { lVer = v
@ -1140,7 +1261,8 @@ listVersions lt' criteria = do
-- This may leave GHCup without a "set" version. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- older version).
rmGHCVer :: ( MonadReader AppState m rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1181,7 +1303,7 @@ rmGHCVer ver = do
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
liftIO liftIO
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
@ -1191,7 +1313,8 @@ rmGHCVer ver = do
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmCabalVer :: ( MonadMask m rmCabalVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1206,7 +1329,7 @@ rmCabalVer ver = do
cSet <- lift cabalSet cSet <- lift cabalSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
@ -1221,7 +1344,8 @@ rmCabalVer ver = do
-- | Delete a hls version. Will try to fix the hls symlinks -- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmHLSVer :: ( MonadMask m rmHLSVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1236,7 +1360,7 @@ rmHLSVer ver = do
isHlsSet <- lift hlsSet isHlsSet <- lift hlsSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f) forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
@ -1258,7 +1382,8 @@ rmHLSVer ver = do
-- | Delete a stack version. Will try to fix the @stack@ symlink -- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmStackVer :: ( MonadMask m rmStackVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1273,7 +1398,7 @@ rmStackVer ver = do
sSet <- lift stackSet sSet <- lift stackSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile) liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
@ -1286,15 +1411,15 @@ rmStackVer ver = do
-- assuming the current scheme of having just 1 ghcup bin, no version info is required. -- 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 , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
) )
=> m () => m ()
rmGhcup = do rmGhcup = do
AppState {dirs = Dirs {binDir}} <- ask Dirs {binDir} <- getDirs
let ghcupFilename = "ghcup" <> exeExt let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename let ghcupFilepath = binDir </> ghcupFilename
@ -1338,14 +1463,14 @@ rmGhcup = do
<> path <> <> path <>
"\n you may have to uninstall it manually." "\n you may have to uninstall it manually."
rmTool :: ( MonadReader AppState m rmTool :: ( MonadReader env m
, MonadLogger m , HasDirs env
, MonadFail m , MonadLogger m
, MonadMask m , MonadFail m
, MonadUnliftIO m) , MonadMask m
=> ListResult , MonadUnliftIO m)
-> Excepts '[NotInstalled ] m () => ListResult
-> Excepts '[NotInstalled ] m ()
rmTool ListResult {lVer, lTool, lCross} = do rmTool ListResult {lVer, lTool, lCross} = do
case lTool of case lTool of
GHC -> GHC ->
@ -1357,7 +1482,8 @@ rmTool ListResult {lVer, lTool, lCross} = do
GHCup -> lift rmGhcup GHCup -> lift rmGhcup
rmGhcupDirs :: ( MonadReader AppState m rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadCatch m , MonadCatch m
@ -1369,7 +1495,7 @@ rmGhcupDirs = do
, binDir , binDir
, logsDir , logsDir
, cacheDir , cacheDir
} <- asks dirs } <- getDirs
let envFilePath = baseDir </> "env" let envFilePath = baseDir </> "env"
@ -1477,13 +1603,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 => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let diBaseDir = baseDir let diBaseDir = baseDir
let diBinDir = binDir let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir diGHCDir <- lift ghcupGHCBaseDir
@ -1503,7 +1636,11 @@ getDebugInfo = do
-- | Compile a GHC from source. This behaves wrt symlinks and installation -- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'. -- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m compileGHC :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , MonadLogger m
@ -1538,10 +1675,9 @@ compileGHC :: ( MonadMask m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
= do = do
AppState { pfreq = PlatformRequest {..} PlatformRequest { .. } <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls } GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
, settings
, dirs } <- lift ask
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
@ -1551,7 +1687,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
dlInfo <- dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached settings dirs dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@ -1618,11 +1754,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
Right g -> pure $ Right g Right g -> pure $ Right g
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
(bindist, bmk) <- liftE $ runBuildAction (mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack tmpUnpack
Nothing Nothing
(do (do
b <- compileBindist bghc tver workdir b <- compileBindist bghc tver workdir ghcdir
bmk <- liftIO $ B.readFile (build_mk workdir) bmk <- liftIO $ B.readFile (build_mk workdir)
pure (b, bmk) pure (b, bmk)
) )
@ -1630,10 +1766,12 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
when alreadyInstalled $ do when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|] lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver liftE $ rmGHCVer tver
liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*") forM_ mBindist $ \bindist -> do
ghcdir liftE $ installPackedGHC bindist
(tver ^. tvVersion) (Just $ RegexDir "ghc-.*")
ghcdir
(tver ^. tvVersion)
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
@ -1660,7 +1798,10 @@ BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|] HADDOCK_DOCS = YES|]
compileBindist :: ( MonadReader AppState m compileBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
@ -1670,15 +1811,17 @@ HADDOCK_DOCS = YES|]
=> Either FilePath FilePath => Either FilePath FilePath
-> GHCTargetVersion -> GHCTargetVersion
-> FilePath -> FilePath
-> FilePath
-> Excepts -> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError] '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m m
FilePath -- ^ output path of bindist (Maybe FilePath) -- ^ output path of bindist, None for cross
compileBindist bghc tver workdir = do compileBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig liftE checkBuildConfig
AppState { dirs = Dirs {..}, pfreq } <- lift ask Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@ -1695,6 +1838,7 @@ HADDOCK_DOCS = YES|]
("./configure" : maybe mempty ("./configure" : maybe mempty
(\x -> ["--target=" <> T.unpack x]) (\x -> ["--target=" <> T.unpack x])
(_tvTarget tver) (_tvTarget tver)
++ ["--prefix=" <> ghcdir]
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"] ++ ["--enable-tarballs-autodownload"]
#endif #endif
@ -1711,8 +1855,9 @@ HADDOCK_DOCS = YES|]
++ maybe mempty ++ maybe mempty
(\x -> ["--target=" <> T.unpack x]) (\x -> ["--target=" <> T.unpack x])
(_tvTarget tver) (_tvTarget tver)
++ ["--prefix=" <> ghcdir]
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"] ++ ["--enable-tarballs-autodownload"]
#endif #endif
++ fmap T.unpack aargs ++ fmap T.unpack aargs
) )
@ -1731,30 +1876,35 @@ HADDOCK_DOCS = YES|]
lift $ $(logInfo) [i|Building (this may take a while)...|] lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
lift $ $(logInfo) [i|Creating bindist...|] if | isCross tver -> do
lEM $ make ["binary-dist"] (Just workdir) lift $ $(logInfo) [i|Installing cross toolchain...|]
[tar] <- liftIO $ findFiles lEM $ make ["install"] (Just workdir)
workdir pure Nothing
(makeRegexOpts compExtended | otherwise -> do
execBlank lift $ $(logInfo) [i|Creating bindist...|]
([s|^ghc-.*\.tar\..*$|] :: ByteString) lEM $ make ["binary-dist"] (Just workdir)
) [tar] <- liftIO $ findFiles
c <- liftIO $ BL.readFile (workdir </> tar) workdir
cDigest <- (makeRegexOpts compExtended
fmap (T.take 8) execBlank
. lift ([s|^ghc-.*\.tar\..*$|] :: ByteString)
. throwEither )
. E.decodeUtf8' c <- liftIO $ BL.readFile (workdir </> tar)
. B16.encode cDigest <-
. SHA256.hashlazy fmap (T.take 8)
$ c . lift
cTime <- liftIO getCurrentTime . throwEither
let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|] . E.decodeUtf8'
let tarPath = cacheDir </> tarName . B16.encode
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar) . SHA256.hashlazy
tarPath $ c
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|] cTime <- liftIO getCurrentTime
pure tarPath 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" build_mk workdir = workdir </> "mk" </> "build.mk"
@ -1781,6 +1931,9 @@ HADDOCK_DOCS = YES|]
) )
_ -> pure () _ -> pure ()
isCross :: GHCTargetVersion -> Bool
isCross = isJust . _tvTarget
@ -1792,7 +1945,11 @@ HADDOCK_DOCS = YES|]
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided. -- if no path is provided.
upgradeGHCup :: ( MonadMask m upgradeGHCup :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -1813,17 +1970,16 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup mtarget force' = do upgradeGHCup mtarget force' = do
AppState { dirs = Dirs {..} Dirs {..} <- lift getDirs
, pfreq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
, settings } <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ fst <$> getLatest dls GHCup let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
let fn = "ghcup" <> exeExt let fn = "ghcup" <> exeExt
p <- liftE $ download settings dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|] lift $ $(logDebug) [i|mkdir -p #{destDir}|]
@ -1865,7 +2021,8 @@ upgradeGHCup mtarget force' = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: ( MonadReader AppState m postGHCInstall :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -1896,7 +2053,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@ -- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@
-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@ -- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
-- * for ghcup, this reports the location of the currently running executable -- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader AppState m whereIsTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -1909,14 +2067,14 @@ whereIsTool :: ( MonadReader AppState m
-> GHCTargetVersion -> GHCTargetVersion
-> Excepts '[NotInstalled] m FilePath -> Excepts '[NotInstalled] m FilePath
whereIsTool tool ver@GHCTargetVersion {..} = do whereIsTool tool ver@GHCTargetVersion {..} = do
AppState { dirs } <- lift ask dirs <- lift getDirs
case tool of case tool of
GHC -> do GHC -> do
whenM (lift $ fmap not $ ghcInstalled ver) whenM (lift $ fmap not $ ghcInstalled ver)
$ throwE (NotInstalled GHC ver) $ throwE (NotInstalled GHC ver)
bdir <- lift $ ghcupGHCDir ver bdir <- lift $ ghcupGHCDir ver
pure (bdir </> "bin" </> "ghc" <> exeExt) pure (bdir </> "bin" </> ghcBinaryName ver)
Cabal -> do Cabal -> do
whenM (lift $ fmap not $ cabalInstalled _tvVersion) whenM (lift $ fmap not $ cabalInstalled _tvVersion)
$ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion)) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion))
@ -1933,3 +2091,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
GHCup -> do GHCup -> do
currentRunningExecPath <- liftIO getExecutablePath currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath liftIO $ canonicalizePath currentRunningExecPath

252
lib/GHCup/Download.hs
View File

@ -107,32 +107,31 @@ import qualified Data.Yaml as Y
getDownloadsF :: ( FromJSONKey Tool getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
, FromJSON VersionInfo , FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
) )
=> Settings => Excepts
-> Dirs
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError] '[JSONError , DownloadFailed , FileDoesNotExistError]
m m
GHCupInfo GHCupInfo
getDownloadsF settings@Settings{ urlSource } dirs = do getDownloadsF = do
Settings { urlSource } <- lift getSettings
case urlSource of case urlSource of
GHCupURL -> liftE $ getBase dirs settings GHCupURL -> liftE $ getBase ghcupURL
(OwnSource url) -> do (OwnSource url) -> liftE $ getBase url
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av (OwnSpec av) -> pure av
(AddSource (Left ext)) -> do (AddSource (Left ext)) -> do
base <- liftE $ getBase dirs settings base <- liftE $ getBase ghcupURL
pure (mergeGhcupInfo base ext) pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do (AddSource (Right uri)) -> do
base <- liftE $ getBase dirs settings base <- liftE $ getBase ghcupURL
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri ext <- liftE $ getBase uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext) pure (mergeGhcupInfo base ext)
where where
@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
in GHCupInfo tr newDownloads newGlobalTools in GHCupInfo tr newDownloads newGlobalTools
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m) readFromCache :: ( MonadReader env m
=> Dirs , HasDirs env
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo , MonadIO m
readFromCache Dirs {..} = do , MonadCatch m)
lift $ $(logWarn) => URI
[i|Could not get download info, trying cached version (this may not be recent!)|] -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
let path = view pathL' ghcupURL readFromCache uri = do
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path) Dirs{..} <- lift getDirs
bs <- let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
handleIO' NoSuchThing handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
(\_ -> throwE $ FileDoesNotExistError yaml_file) . liftIO
$ liftIO . L.readFile
$ L.readFile yaml_file $ yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m) getBase :: ( MonadReader env m
=> Dirs , HasDirs env
-> Settings , HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
)
=> URI
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } = getBase uri = do
handleIO (\_ -> readFromCache dirs) Settings { noNetwork } <- lift getSettings
$ catchE @_ @'[JSONError, FileDoesNotExistError] bs <- if noNetwork
(\(DownloadFailed _) -> readFromCache dirs) then readFromCache uri
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL) else handleIO (\_ -> warnCache >> readFromCache uri)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict)) . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
where . 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 -- 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 -- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it. -- last 5 minutes, just reuse it.
@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
-- than the local file. -- than the local file.
-- --
-- Always save the local file with the mod time of the remote file. -- Always save the local file with the mod time of the remote file.
smartDl :: forall m1 smartDl :: forall m1 env1
. ( MonadCatch m1 . ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , MonadLogger m1
@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } =
, NoLocationHeader , NoLocationHeader
, TooManyRedirs , TooManyRedirs
, ProcessError , ProcessError
, NoNetwork
] ]
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Dirs{..} <- lift getDirs
let path = view pathL' uri' let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path) let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
if e if e
then do then do
accessTime <- liftIO $ getAccessTime json_file accessTime <- liftIO $ getAccessTime json_file
@ -237,11 +257,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
where where
dlWithMod modTime json_file = do dlWithMod modTime json_file = do
bs <- liftE $ downloadBS downloader uri' bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs liftIO $ writeFileWithModTime modTime json_file bs
pure bs pure bs
dlWithoutMod json_file = do dlWithoutMod json_file = do
bs <- liftE $ downloadBS downloader uri' bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file liftIO $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0)) liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
@ -279,39 +299,46 @@ getBase dirs@Dirs{..} Settings{ downloader } =
setModificationTime path utctime setModificationTime path utctime
getDownloadInfo :: Tool getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> Version -> Version
-- ^ tool version -- ^ tool version
-> PlatformRequest -> Excepts
-> GHCupDownloads '[NoDownload]
-> Either NoDownload DownloadInfo m
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe DownloadInfo
(Left NoDownload) getDownloadInfo t v = do
Right (PlatformRequest a p mv) <- lift getPlatformReq
(case p of GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro
)
where let distro_preview f g =
with_distro = distro_preview id id let platformVersionSpec =
without_distro_ver = distro_preview id (const Nothing) preview (ix t % ix v % viArch % ix a % ix (f p)) dls
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) 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 = maybe
let platformVersionSpec = (throwE NoDownload)
preview (ix t % ix v % viArch % ix a % ix (f p)) dls pure
mv' = g mv (case p of
in fmap snd -- non-musl won't work on alpine
. find Linux Alpine -> with_distro <|> without_distro_ver
(\(mverRange, _) -> maybe _ -> with_distro <|> without_distro_ver <|> without_distro
(isNothing mv') )
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
=<< platformVersionSpec
-- | Tries to download from the given http or https url -- | Tries to download from the given http or https url
@ -321,17 +348,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
-- 2. otherwise create a random file -- 2. otherwise create a random file
-- --
-- The file must not exist. -- The file must not exist.
download :: ( MonadMask m download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
) )
=> Settings => DownloadInfo
-> DownloadInfo
-> FilePath -- ^ destination dir -> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
download settings@Settings{ downloader } dli dest mfn download dli dest mfn
| scheme == "https" = dl | scheme == "https" = dl
| scheme == "http" = dl | scheme == "http" = dl
| scheme == "file" = cp | scheme == "file" = cp
@ -362,6 +391,8 @@ download settings@Settings{ downloader } dli dest mfn
liftIO (hideError doesNotExistErrorType $ rmFile destFile) liftIO (hideError doesNotExistErrorType $ rmFile destFile)
>> (throwE . DownloadFailed $ e) >> (throwE . DownloadFailed $ e)
) $ do ) $ do
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
case downloader of case downloader of
Curl -> do Curl -> do
o' <- liftIO getCurlOpts o' <- liftIO getCurlOpts
@ -377,58 +408,66 @@ download settings@Settings{ downloader } dli dest mfn
liftE $ downloadToFile https host fullPath port destFile liftE $ downloadToFile https host fullPath port destFile
#endif #endif
liftE $ checkDigest settings dli destFile liftE $ checkDigest dli destFile
pure destFile pure destFile
-- Manage to find a file we can write the body into. -- Manage to find a file we can write the body into.
getDestFile :: FilePath 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 -- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url. -- is omitted, infers the filename from the url.
downloadCached :: ( MonadMask m downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadResource m , MonadResource m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Settings => DownloadInfo
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached settings@Settings{ cache } dirs dli mfn = do downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
case cache of case cache of
True -> downloadCached' settings dirs dli mfn True -> downloadCached' dli mfn Nothing
False -> do False -> do
tmp <- lift withGHCupTmpDir 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 , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Settings => DownloadInfo
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' settings Dirs{..} 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 fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn let cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> do | fileExists -> do
liftE $ checkDigest settings dli cachfile liftE $ checkDigest dli cachfile
pure cachfile pure cachfile
| otherwise -> liftE $ download settings dli cacheDir mfn | otherwise -> liftE $ download dli destDir mfn
@ -441,9 +480,13 @@ downloadCached' settings Dirs{..} dli mfn = do
-- | This is used for downloading the JSON. -- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) downloadBS :: ( MonadReader env m
=> Downloader , HasSettings env
-> URI , MonadCatch m
, MonadIO m
, MonadLogger m
)
=> URI
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
, HTTPStatusError , HTTPStatusError
@ -452,10 +495,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
, NoLocationHeader , NoLocationHeader
, TooManyRedirs , TooManyRedirs
, ProcessError , ProcessError
, NoNetwork
] ]
m m
L.ByteString L.ByteString
downloadBS downloader uri' downloadBS uri'
| scheme == "https" | scheme == "https"
= dl True = dl True
| scheme == "http" | scheme == "http"
@ -475,6 +519,8 @@ downloadBS downloader uri'
dl _ = do dl _ = do
#endif #endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE NoNetwork
case downloader of case downloader of
Curl -> do Curl -> do
o' <- liftIO getCurlOpts o' <- liftIO getCurlOpts
@ -499,12 +545,18 @@ downloadBS downloader uri'
#endif #endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m) checkDigest :: ( MonadReader env m
=> Settings , HasDirs env
-> DownloadInfo , HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
)
=> DownloadInfo
-> FilePath -> FilePath
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
checkDigest Settings{ noVerify } dli file = do checkDigest dli file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify let verify = not noVerify
when verify $ do when verify $ do
let p' = takeFileName file let p' = takeFileName file

7
lib/GHCup/Errors.hs
View File

@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) = pPrint (NoToolVersionSet tool) =
text [i|No version is set for tool "#{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 ]-- --[ High-level errors ]--

21
lib/GHCup/Types.hs
View File

@ -1,9 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-| {-|
Module : GHCup.Types Module : GHCup.Types
@ -294,11 +297,12 @@ data UserSettings = UserSettings
, uDownloader :: Maybe Downloader , uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings , uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource , uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Key { kUp :: Maybe Key
@ -346,12 +350,21 @@ data AppState = AppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
, ghcupInfo :: ~GHCupInfo , ghcupInfo :: GHCupInfo
, pfreq :: ~PlatformRequest , pfreq :: PlatformRequest
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData AppState instance NFData AppState
data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
} deriving (Show, GHC.Generic)
instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, noVerify :: Bool , noVerify :: Bool
@ -359,6 +372,7 @@ data Settings = Settings
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
, urlSource :: URLSource , urlSource :: URLSource
, noNetwork :: Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@ -507,4 +521,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where
instance MonadLogger m => MonadLogger (Excepts e m) where instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d

87
lib/GHCup/Types/Optics.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-| {-|
Module : GHCup.Types.Optics Module : GHCup.Types.Optics
@ -13,6 +18,7 @@ module GHCup.Types.Optics where
import GHCup.Types import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Optics import Optics
import URI.ByteString import URI.ByteString
@ -58,3 +64,82 @@ pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL 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

150
lib/GHCup/Utils.hs
View File

@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool. -- | 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. => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion -> GHCTargetVersion
-> m FilePath -> m FilePath
ghcLinkDestination tool ver = do ghcLinkDestination tool ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
ghcd <- ghcupGHCDir ver ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> "bin" </> tool)) pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@GHCTargetVersion{..} = do rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
-- | Removes the set ghc version for the given target, if any. -- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m
=> Maybe Text -- ^ target => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
@ -159,17 +162,17 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@GHCTargetVersion{..} = do rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
-- | Whether the given GHC versin is installed. -- | 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 ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | 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 ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | 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 => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
ghcSet mtarget = do ghcSet mtarget = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc <> exeExt let ghcBin = binDir </> ghc <> exeExt
@ -239,7 +242,7 @@ ghcSet mtarget = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- 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 getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
@ -249,10 +252,15 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | 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] => m [Either FilePath Version]
getInstalledCabals = do getInstalledCabals = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@ -264,16 +272,16 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | 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 cabalInstalled ver = do
vers <- fmap rights getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver vers pure $ elem ver vers
-- Return the currently set cabal version, if any. -- 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 cabalSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -317,10 +325,10 @@ cabalSet = do
-- | Get all installed hls, by matching on -- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -- @~\/.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] => m [Either FilePath Version]
getInstalledHLSs = do getInstalledHLSs = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -337,10 +345,10 @@ getInstalledHLSs = do
-- | Get all installed stacks, by matching on -- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@. -- @~\/.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] => m [Either FilePath Version]
getInstalledStacks = do getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -355,9 +363,9 @@ getInstalledStacks = do
-- Return the currently set stack version, if any. -- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :> -- 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 stackSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt let stackBin = binDir </> "stack" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -395,13 +403,13 @@ stackSet = do
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
-- | Whether the given Stack version is installed. -- | 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 stackInstalled ver = do
vers <- fmap rights getInstalledStacks vers <- fmap rights getInstalledStacks
pure $ elem ver vers pure $ elem ver vers
-- | Whether the given HLS version is installed. -- | 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 hlsInstalled ver = do
vers <- fmap rights getInstalledHLSs vers <- fmap rights getInstalledHLSs
pure $ elem ver vers pure $ elem ver vers
@ -409,9 +417,9 @@ hlsInstalled ver = do
-- Return the currently set hls version, if any. -- 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 hlsSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -443,7 +451,8 @@ hlsSet = do
-- | Return the GHC versions the currently selected HLS supports. -- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader AppState m hlsGHCVersions :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
@ -466,11 +475,11 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any. -- | 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 => Version
-> m [FilePath] -> m [FilePath]
hlsServerBinaries ver = do hlsServerBinaries ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -482,12 +491,12 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any. -- | 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 => Version
-> m (Maybe FilePath) -> m (Maybe FilePath)
hlsWrapperBinary ver = do hlsWrapperBinary ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
compExtended compExtended
@ -503,7 +512,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any. -- | 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 hlsAllBinaries ver = do
hls <- hlsServerBinaries ver hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
@ -511,9 +520,9 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls. -- | 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 hlsSymlinks = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (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. -- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`. -- 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 -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple -> 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 ]-- --[ Other ]--
@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings
-- Returns unversioned relative files without extension, e.g.: -- Returns unversioned relative files without extension, e.g.:
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["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 => GHCTargetVersion
-> Excepts '[NotInstalled] m [FilePath] -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do ghcToolFiles ver = do
@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make. -- | 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] => [String]
-> Maybe FilePath -> Maybe FilePath
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -827,7 +828,7 @@ make args workdir = do
let mymake = if has_gmake then "gmake" else "make" let mymake = if has_gmake then "gmake" else "make"
execLogged mymake args workdir "ghc-make" Nothing execLogged mymake args workdir "ghc-make" Nothing
makeOut :: (MonadReader AppState m, MonadIO m) makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
=> [String] => [String]
-> Maybe FilePath -> Maybe FilePath
-> m CapturedProcess -> m CapturedProcess
@ -840,7 +841,7 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed' -- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure. -- 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 containing patches
-> FilePath -- ^ dir to apply patches in -> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m () -> Excepts '[PatchFailed] m ()
@ -858,7 +859,7 @@ applyPatches pdir ddir = do
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader AppState m, MonadIO m) darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
=> Platform => Platform
-> FilePath -> FilePath
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 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) => FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception -> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do runBuildAction bdir instdir action = do
AppState { settings = Settings {..} } <- lift ask Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir liftIO $ hideError doesNotExistErrorType $ rmPath dir
@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m
-> m () -> m ()
createLink link exe = do createLink link exe = do
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
AppState { dirs } <- ask dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe" let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim" let shim = dropExtension exe <.> "shim"
@ -1054,17 +1056,22 @@ ensureGlobalTools :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasGHCupInfo env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Excepts '[DigestError , DownloadFailed, NoDownload] m () => Excepts '[DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do ensureGlobalTools = do
#if defined(IS_WINDOWS) #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] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|] lift $ $(logDebug) [i|rm -f #{shimDownload}|]
@ -1093,3 +1100,16 @@ ensureDirectories dirs = do
createDirRecursive' logsDir createDirRecursive' logsDir
createDirRecursive' confDir createDirRecursive' confDir
pure () pure ()
-- | For ghc without arch triple, this is:
--
-- - ghc-<ver> (e.g. ghc-8.10.4)
--
-- For ghc with arch triple:
--
-- - <triple>-ghc-<ver> (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)

13
lib/GHCup/Utils/Dirs.hs
View File

@ -16,7 +16,7 @@ Stability : experimental
Portability : portable Portability : portable
-} -}
module GHCup.Utils.Dirs module GHCup.Utils.Dirs
( getDirs ( getAllDirs
, ghcupBaseDir , ghcupBaseDir
, ghcupConfigFile , ghcupConfigFile
, ghcupCacheDir , ghcupCacheDir
@ -37,6 +37,7 @@ where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
@ -190,8 +191,8 @@ ghcupLogsDir = do
#endif #endif
getDirs :: IO Dirs getAllDirs :: IO Dirs
getDirs = do getAllDirs = do
baseDir <- ghcupBaseDir baseDir <- ghcupBaseDir
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
@ -226,9 +227,9 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default. -- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir = do ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
pure (baseDir </> "ghc") pure (baseDir </> "ghc")
@ -236,7 +237,7 @@ ghcupGHCBaseDir = do
-- The dir may be of the form -- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3 -- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4 -- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion => GHCTargetVersion
-> m FilePath -> m FilePath
ghcupGHCDir ver = do ghcupGHCDir ver = do

10
lib/GHCup/Utils/File/Posix.hs
View File

@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common import GHCup.Utils.File.Common
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
SPP.executeFile path True args Nothing 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 => FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing -> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask Settings {..} <- getSettings
Dirs {..} <- getDirs
let logfile = logsDir </> lfile <> ".log" let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd closeFd

9
lib/GHCup/Utils/File/Windows.hs
View File

@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.File.Common import GHCup.Utils.File.Common
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent import Control.Concurrent
import Control.DeepSeq import Control.DeepSeq
@ -146,7 +147,11 @@ executeOut path args chdir = do
pure $ CapturedProcess exit out err 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 => FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing -> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
@ -154,7 +159,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
let stdoutLogfile = logsDir </> lfile <> ".stdout.log" let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log" stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args) cp <- createProcessWithMingwPath ((proc exe args)

4
stack.yaml
View File

@ -31,6 +31,10 @@ extra-deps:
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990 - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - 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 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7 - regex-posix-clib-2.7
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421 - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421