Compare commits

...

23 Commits

Author SHA1 Message Date
bbbe52f453 Bump stack to 2.7.3 2021-07-20 22:30:50 +02:00
7a2570019a Return the version during 'ghcup compile ghc -g <commit>'
Fixes #181
2021-07-20 11:42:36 +02:00
c5b4e82b48 Merge branch 'issue-187' 2021-07-20 00:57:08 +02:00
4ed72fb517 Preserve mtimes on unpacked GHC tarballs on windows wrt #187 2021-07-19 23:33:01 +02:00
5217aa0a1d Merge branch 'issue-180' 2021-07-19 20:55:17 +02:00
3caf91c640 Fix ensureGlobalTools 2021-07-19 19:08:43 +02:00
eb26a5133f Merge branch 'www-fix-true' 2021-07-19 17:01:03 +02:00
9e9402a3a2 Fix www 2021-07-19 16:58:42 +02:00
bc13a4555d Fix runLeanWhereIs on windows 2021-07-19 16:56:28 +02:00
eaad2caf25 Add prefetch command 2021-07-19 16:51:40 +02:00
6143cdf2e0 Add --offline switch wrt #186 2021-07-19 13:49:24 +02:00
2c7176d998 Use LabelOptic and add LeanAppState
Wrt #186
2021-07-18 14:39:49 +02:00
327b80cf56 Add cross compilation to CI test 2021-07-15 23:26:48 +02:00
005c9fbb83 Modernize CI scripts 2021-07-15 22:44:54 +02:00
42134fd2a5 Fix whereIsTool for cross 2021-07-15 22:38:42 +02:00
bc85a7d9c3 Fix cross installation
See https://gitlab.haskell.org/ghc/ghc/-/issues/14297
2021-07-15 20:32:09 +02:00
7e14fd4a08 Only run unsafeInterleaveIO when necessary 2021-07-15 20:30:14 +02:00
bf74d1e828 Merge branch 'issue-179' 2021-07-15 20:01:25 +02:00
f04708e8ae Speed up 'whereis' subcommand wrt #179 2021-07-15 20:01:00 +02:00
80e1924e5f Merge branch 'scoop' 2021-07-13 20:27:15 +02:00
c7393bd7c5 Fork shimgen into main repo, fixes #161 2021-07-13 20:25:29 +02:00
664713bb13 Fix darwin:aarch64 release 2021-07-13 19:41:12 +02:00
01715fdefc Merge branch 'github-actions' 2021-07-13 17:26:03 +02:00
27 changed files with 1777 additions and 553 deletions

29
.github/workflows/shimgen.yaml vendored Normal file
View File

@@ -0,0 +1,29 @@
name: Shimgen CI
on:
push:
branches: [ master ]
pull_request:
branches: [ master ]
jobs:
build-shimgen:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [windows-latest]
steps:
- uses: actions/checkout@v2
- uses: ilammy/msvc-dev-cmd@v1
- name: compile
run: cl /O1 scoop-better-shimexe/shim.c
- uses: actions/upload-artifact@v2
with:
name: shim.exe
path: shim.exe

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"
@@ -105,6 +106,10 @@ variables:
- golden - golden
when: on_failure when: on_failure
# .test_ghcup_scoop:
# script:
# - cl /O1 scoop-better-shimexe/shim.c
.test_ghcup_version:linux: .test_ghcup_version:linux:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
@@ -184,6 +189,12 @@ variables:
- set CABAL_DIR="$CI_PROJECT_DIR/cabal" - set CABAL_DIR="$CI_PROJECT_DIR/cabal"
- bash ./.gitlab/before_script/windows/install_deps.sh - bash ./.gitlab/before_script/windows/install_deps.sh
# .test_ghcup_scoop:windows:
# extends:
# - .windows
# - .test_ghcup_scoop
# - .root_cleanup
.release_ghcup: .release_ghcup:
script: script:
- bash ./.gitlab/script/ghcup_release.sh - bash ./.gitlab/script/ghcup_release.sh
@@ -258,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:
@@ -276,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: []
@@ -285,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: []
@@ -338,6 +369,11 @@ test:windows:recommended:
CABAL_VERSION: "3.4.0.0" CABAL_VERSION: "3.4.0.0"
needs: [] needs: []
# test:windows:scoop:
# stage: test
# extends: .test_ghcup_scoop:windows
# needs: []
######## linux release ######## ######## linux release ########
release:linux:64bit: release:linux:64bit:
@@ -379,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
@@ -392,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 ########
@@ -420,13 +458,19 @@ release:darwin:aarch64:
script: | script: |
set -Eeuo pipefail set -Eeuo pipefail
function runInNixShell() { function runInNixShell() {
time nix-shell .gitlab/shell.nix \ time nix-shell $CI_PROJECT_DIR/.gitlab/shell.nix \
-I nixpkgs=https://github.com/angerman/nixpkgs/archive/75f7281738b.tar.gz \ -I nixpkgs=https://github.com/angerman/nixpkgs/archive/75f7281738b.tar.gz \
--argstr system "aarch64-darwin" \ --argstr system "aarch64-darwin" \
--pure \ --pure \
--keep CI_PROJECT_DIR --keep MAKE_ARGS --keep HADRIAN_ARGS --keep CABAL_CACHE \ --keep CI_PROJECT_DIR \
--keep MACOSX_DEPLOYMENT_TARGET \ --keep MACOSX_DEPLOYMENT_TARGET \
--keep JSON_VERSION --keep ARTIFACT \ --keep JSON_VERSION \
--keep ARTIFACT \
--keep OS \
--keep ARCH \
--keep CABAL_DIR \
--keep GHC_VERSION \
--keep CABAL_VERSION \
--run "$1" 2>&1 --run "$1" 2>&1
} }
runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1 runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1

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

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

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
@@ -142,6 +139,11 @@ else
fi fi
fi fi
# check that lazy loading works for 'whereis'
cp "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
eghcup whereis ghc $(ghc --numeric-version)
mv -f "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
eghcup rm $(ghc --numeric-version) eghcup rm $(ghc --numeric-version)
@@ -153,6 +155,7 @@ if [ "${OS}" = "LINUX" ] ; then
fi fi
fi fi
eghcup upgrade eghcup upgrade
eghcup upgrade -f eghcup upgrade -f

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

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

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
@@ -33,6 +34,8 @@ import GHCup.Version
import Codec.Archive import Codec.Archive
#endif #endif
import Control.Concurrent import Control.Concurrent
import Control.DeepSeq ( force )
import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -88,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
} }
@@ -108,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
@@ -197,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
@@ -274,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' =
@@ -354,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
@@ -437,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:
@@ -822,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
@@ -939,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)
@@ -959,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
@@ -1120,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
@@ -1164,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
@@ -1217,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
@@ -1225,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
@@ -1237,6 +1342,14 @@ 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 () }
-------------------------
-- Setting up appstate --
-------------------------
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- ( pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case ) >>= \case
@@ -1246,17 +1359,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
($(logError) $ T.pack $ prettyShow e) ($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
----------------------------------------
-- Getting download and platform info --
----------------------------------------
ghcupInfo <- ghcupInfo <-
( runLogger ( runLogger
. flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF settings dirs $ getDownloadsF
) )
>>= \case >>= \case
VRight r -> pure r VRight r -> pure r
@@ -1264,26 +1372,34 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger runLogger
($(logError) $ T.pack $ prettyShow e) ($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
let appstate@AppState{dirs = Dirs{..}
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls, .. }
} = AppState settings dirs keybindings ghcupInfo pfreq
case optCommand of
Upgrade _ _ -> pure ()
_ -> do
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure () Just _ -> pure ()
-- TODO: always run for windows
-- ensure global tools (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
VRight _ -> pure () VRight _ -> pure ()
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) $ T.pack $ prettyShow e) ($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 30) exitWith (ExitFailure 30)
pure s'
#if defined(IS_WINDOWS)
-- FIXME: windows needs 'ensureGlobalTools', which requires
-- full appstate
runLeanAppState = runAppState
#else
runLeanAppState = flip runReaderT leanAppstate
#endif
runAppState action' = do
s' <- liftIO appState
flip runReaderT s' action'
------------------------- -------------------------
@@ -1292,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
@@ -1313,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
@@ -1328,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
@@ -1341,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
@@ -1349,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
@@ -1382,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
@@ -1394,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
@@ -1405,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 --
@@ -1417,7 +1593,9 @@ 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
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
@@ -1455,7 +1633,9 @@ 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
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@@ -1484,7 +1664,9 @@ 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
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@@ -1513,7 +1695,9 @@ 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
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist liftE $ installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@@ -1537,8 +1721,10 @@ 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
(SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
_ -> runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly
) )
@@ -1552,8 +1738,10 @@ 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
(SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v) liftE $ setCabal (_tvVersion v)
pure v pure v
@@ -1568,8 +1756,10 @@ 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
(SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
_ -> runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v) liftE $ setHLS (_tvVersion v)
pure v pure v
@@ -1584,8 +1774,10 @@ 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
(SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v) liftE $ setStack (_tvVersion v)
pure v pure v
@@ -1604,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
@@ -1619,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
@@ -1634,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
@@ -1649,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
@@ -1663,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.|])
@@ -1713,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
@@ -1728,17 +1926,19 @@ 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
pure vi pure (vi, targetVer)
) )
>>= \case >>= \case
VRight vi -> do VRight (vi, tv) -> do
runLogger $ $(logInfo) runLogger $ $(logInfo)
"GHC successfully compiled and installed" "GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
putStr (T.unpack $ tVerToText tv)
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) runLogger $ $(logWarn)
@@ -1755,6 +1955,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
@@ -1771,14 +1986,15 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 30 pure $ ExitFailure 30
Upgrade uOpts force -> do Upgrade uOpts force' -> do
target <- case uOpts of target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p (UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt)) UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
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)
@@ -1793,14 +2009,16 @@ 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
flip runReaderT s'
$ runLogger $ runLogger
(runE (runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do $ do
platform <- liftE getPlatform GHCupInfo { .. } <- lift getGHCupInfo
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements platform' <- liftE getPlatform
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req) liftIO $ T.hPutStr stdout (prettyRequirements req)
) )
>>= \case >>= \case
@@ -1810,6 +2028,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 12 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)
@@ -1827,6 +2046,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"
@@ -1835,8 +2055,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
Windows -> "start" Windows -> "start"
if clOpen if clOpen
then then do
flip runReaderT appstate $ s' <- appState
flip runReaderT s' $
exec cmd exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri] [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing Nothing
@@ -1849,6 +2070,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
Nuke -> Nuke ->
runRm (do runRm (do
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
@@ -1875,6 +2098,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
@@ -1884,22 +2138,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)
@@ -1909,16 +2187,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
@@ -2119,7 +2397,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
@@ -2129,7 +2410,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

View File

@@ -2155,14 +2155,13 @@ ghcupDownloads:
unknown_versioning: *stack-251-64 unknown_versioning: *stack-251-64
2.7.1: 2.7.1:
viTags: viTags:
- Recommended - old
- Latest
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271 viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
viPostInstall: *stack-post viPostInstall: *stack-post
viArch: viArch:
A_64: A_64:
Linux_UnknownLinux: Linux_UnknownLinux:
unknown_versioning: &stack-64 unknown_versioning: &stack-271-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
dlSubdir: dlSubdir:
@@ -2180,5 +2179,33 @@ ghcupDownloads:
dlSubdir: dlSubdir:
RegexDir: "stack-.*" RegexDir: "stack-.*"
Linux_Alpine: Linux_Alpine:
unknown_versioning: *stack-64 unknown_versioning: *stack-271-64
2.7.3:
viTags:
- Latest
- Recommended
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v273
viPostInstall: *stack-post
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &stack-273-64
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-linux-x86_64.tar.gz
dlHash: a6c090555fa1c64aa61c29aa4449765a51d79e870cf759cde192937cd614e72b
dlSubdir:
RegexDir: "stack-.*"
Darwin:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-osx-x86_64.tar.gz
dlHash: 42e5000a00af44a7b26852421ac63ce75f510ad1a97742cb131107088ee9fe30
dlSubdir:
RegexDir: "stack-.*"
Windows:
unknown_versioning:
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-windows-x86_64.tar.gz
dlHash: e6ba12e0ecabf0df2567d88a0d247da238bc114bcccfca4195f5e86472c9330c
dlSubdir:
RegexDir: "stack-.*"
Linux_Alpine:
unknown_versioning: *stack-273-64

View File

@@ -82,7 +82,6 @@ library
QuasiQuotes QuasiQuotes
RecordWildCards RecordWildCards
ScopedTypeVariables ScopedTypeVariables
Strict
StrictData StrictData
TupleSections TupleSections
TypeApplications TypeApplications
@@ -117,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
@@ -195,7 +194,6 @@ executable ghcup
PackageImports PackageImports
RecordWildCards RecordWildCards
ScopedTypeVariables ScopedTypeVariables
Strict
StrictData StrictData
TupleSections TupleSections
@@ -207,6 +205,7 @@ executable ghcup
, base >=4.13 && <5 , base >=4.13 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10
, containers ^>=0.6 , containers ^>=0.6
, deepseq ^>=1.4
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghcup , ghcup
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
@@ -261,7 +260,6 @@ executable ghcup-gen
QuasiQuotes QuasiQuotes
RecordWildCards RecordWildCards
ScopedTypeVariables ScopedTypeVariables
Strict
StrictData StrictData
TupleSections TupleSections
TypeApplications TypeApplications
@@ -281,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
@@ -305,6 +303,7 @@ executable ghcup-gen
test-suite ghcup-test test-suite ghcup-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Main.hs main-is: Main.hs
build-tool-depends: hspec-discover:hspec-discover -any
hs-source-dirs: test hs-source-dirs: test
other-modules: other-modules:
GHCup.ArbitraryTypes GHCup.ArbitraryTypes
@@ -324,8 +323,6 @@ test-suite ghcup-test
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -fwarn-incomplete-record-updates
build-tool-depends: hspec-discover:hspec-discover
build-depends: build-depends:
, base >=4.13 && <5 , base >=4.13 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10

View File

@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@@ -42,6 +43,7 @@ import GHCup.Version
import Codec.Archive ( ArchiveResult ) import Codec.Archive ( ArchiveResult )
#endif #endif
import Control.Applicative import Control.Applicative
import Control.DeepSeq ( force )
import Control.Exception ( evaluate ) import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
@@ -75,6 +77,9 @@ import System.Directory hiding ( findFiles )
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp
#endif
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
@@ -93,6 +98,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 ]--
@@ -104,7 +172,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
@@ -128,14 +199,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
@@ -161,7 +230,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
@@ -180,7 +252,23 @@ installPackedGHC :: ( MonadMask m
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver = do installPackedGHC dl msubdir inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask #if defined(IS_WINDOWS)
lift $ $(logInfo) "Installing GHC (this may take a while)"
Dirs { tmpDir } <- lift getDirs
unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
liftIO $ rmFile unpackDir
liftE $ unpackToDir unpackDir dl
d <- case msubdir of
Just td -> liftE $ intoSubdir unpackDir td
Nothing -> pure unpackDir
liftIO $ Win32.moveFileEx d (Just inst) 0
liftIO $ rmPath unpackDir
#else
PlatformRequest {..} <- lift getPlatformReq
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@@ -195,11 +283,15 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack liftE $ runBuildAction tmpUnpack
(Just inst) (Just inst)
(installUnpackedGHC workdir inst ver) (installUnpackedGHC workdir inst ver)
#endif
-- | 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
@@ -208,15 +300,8 @@ installUnpackedGHC :: ( MonadReader AppState m
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
#if defined(IS_WINDOWS)
installUnpackedGHC path inst _ = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
-- windows bindists are relocatable and don't need
-- to run configure
liftIO $ copyDirectoryRecursive path inst
#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
@@ -237,7 +322,6 @@ installUnpackedGHC path inst ver = do
Nothing Nothing
lEM $ make ["install"] (Just path) lEM $ make ["install"] (Just path)
pure () pure ()
#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -248,7 +332,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
@@ -271,9 +359,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
@@ -281,7 +367,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
@@ -308,9 +397,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 $
@@ -322,7 +410,7 @@ 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
@@ -362,7 +450,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
@@ -386,9 +478,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
@@ -396,7 +486,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
@@ -423,15 +516,14 @@ 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
@@ -486,7 +578,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
@@ -510,9 +606,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
@@ -521,7 +615,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
@@ -545,8 +643,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
@@ -554,7 +651,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
@@ -581,16 +681,14 @@ 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
@@ -642,7 +740,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
@@ -661,7 +760,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)
@@ -699,12 +798,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
@@ -731,7 +833,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
@@ -743,7 +846,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
@@ -762,7 +865,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
@@ -773,7 +877,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.
@@ -802,7 +906,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
@@ -815,7 +920,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
@@ -870,7 +975,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
@@ -889,7 +997,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)
@@ -915,7 +1023,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
@@ -957,7 +1071,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]
@@ -986,7 +1106,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
@@ -1014,7 +1139,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
@@ -1043,7 +1174,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]
@@ -1054,12 +1192,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
@@ -1067,7 +1202,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
@@ -1093,7 +1228,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
@@ -1106,7 +1241,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
@@ -1138,7 +1273,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
@@ -1179,7 +1315,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
@@ -1189,7 +1325,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
@@ -1204,7 +1341,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)
@@ -1219,7 +1356,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
@@ -1234,7 +1372,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)
@@ -1256,7 +1394,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
@@ -1271,7 +1410,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)
@@ -1284,15 +1423,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
@@ -1336,14 +1475,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
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
, MonadUnliftIO m) , MonadUnliftIO m)
=> ListResult => ListResult
-> Excepts '[NotInstalled ] m () -> Excepts '[NotInstalled ] m ()
rmTool ListResult {lVer, lTool, lCross} = do rmTool ListResult {lVer, lTool, lCross} = do
case lTool of case lTool of
GHC -> GHC ->
@@ -1355,7 +1494,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
@@ -1367,7 +1507,8 @@ rmGhcupDirs = do
, binDir , binDir
, logsDir , logsDir
, cacheDir , cacheDir
} <- asks dirs , tmpDir
} <- getDirs
let envFilePath = baseDir </> "env" let envFilePath = baseDir </> "env"
@@ -1378,6 +1519,7 @@ rmGhcupDirs = do
rmDir cacheDir rmDir cacheDir
rmDir logsDir rmDir logsDir
rmBinDir binDir rmBinDir binDir
rmDir tmpDir
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
rmDir (baseDir </> "msys64") rmDir (baseDir </> "msys64")
#endif #endif
@@ -1393,19 +1535,21 @@ rmGhcupDirs = do
rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m () rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
rmEnvFile enFilePath = do rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File" $logInfo "Removing Ghcup Environment File"
hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath liftIO $ deleteFile enFilePath
rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m () rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
rmConfFile confFilePath = do rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File" $logInfo "removing Ghcup Config File"
hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath liftIO $ deleteFile confFilePath
rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m () rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir = do rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do
$logInfo [i|removing #{dir}|] $logInfo [i|removing #{dir}|]
contents <- hideErrorDef [doesNotExistErrorType] [] contents <- liftIO $ getDirectoryContentsRecursive dir
$ liftIO
(getDirectoryContentsRecursive dir >>= evaluate)
forM_ contents (liftIO . deleteFile . (dir </>)) forM_ contents (liftIO . deleteFile . (dir </>))
rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m () rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
@@ -1421,7 +1565,9 @@ rmGhcupDirs = do
reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath] reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
reportRemainingFiles dir = do reportRemainingFiles dir = do
remainingFiles <- liftIO $ getDirectoryContentsRecursive dir -- force the files so the errors don't leak
(force -> !remainingFiles) <- liftIO
(getDirectoryContentsRecursive dir >>= evaluate)
let normalizedFilePaths = fmap normalise remainingFiles let normalizedFilePaths = fmap normalise remainingFiles
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
@@ -1448,7 +1594,8 @@ rmGhcupDirs = do
deleteFile :: FilePath -> IO () deleteFile :: FilePath -> IO ()
deleteFile filepath = do deleteFile filepath = do
hideError InappropriateType $ rmFile filepath hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m () removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath = removeDirIfEmptyOrIsSymlink filepath =
@@ -1470,13 +1617,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
@@ -1496,7 +1650,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
@@ -1531,10 +1689,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
@@ -1544,7 +1701,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
@@ -1611,11 +1768,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)
) )
@@ -1623,6 +1780,8 @@ 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
forM_ mBindist $ \bindist -> do
liftE $ installPackedGHC bindist liftE $ installPackedGHC bindist
(Just $ RegexDir "ghc-.*") (Just $ RegexDir "ghc-.*")
ghcdir ghcdir
@@ -1653,7 +1812,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
@@ -1663,15 +1825,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
@@ -1688,6 +1852,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
@@ -1704,6 +1869,7 @@ 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
@@ -1724,6 +1890,11 @@ 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)
if | isCross tver -> do
lift $ $(logInfo) [i|Installing cross toolchain...|]
lEM $ make ["install"] (Just workdir)
pure Nothing
| otherwise -> do
lift $ $(logInfo) [i|Creating bindist...|] lift $ $(logInfo) [i|Creating bindist...|]
lEM $ make ["binary-dist"] (Just workdir) lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles [tar] <- liftIO $ findFiles
@@ -1747,7 +1918,7 @@ HADDOCK_DOCS = YES|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar) handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath tarPath
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|] lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
pure tarPath pure $ Just tarPath
build_mk workdir = workdir </> "mk" </> "build.mk" build_mk workdir = workdir </> "mk" </> "build.mk"
@@ -1774,6 +1945,9 @@ HADDOCK_DOCS = YES|]
) )
_ -> pure () _ -> pure ()
isCross :: GHCTargetVersion -> Bool
isCross = isJust . _tvTarget
@@ -1785,7 +1959,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
@@ -1806,17 +1984,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}|]
@@ -1858,7 +2035,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
@@ -1889,7 +2067,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
@@ -1902,14 +2081,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))
@@ -1926,3 +2105,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
GHCup -> do GHCup -> do
currentRunningExecPath <- liftIO getExecutablePath currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath liftIO $ canonicalizePath currentRunningExecPath

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)
. reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
$ smartDl uri
liftE
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first show
. Y.decodeEither'
. L.toStrict
$ bs
where 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,10 +218,12 @@ 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
@@ -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,27 +299,22 @@ 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
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
distro_preview f g =
let platformVersionSpec = let platformVersionSpec =
preview (ix t % ix v % viArch % ix a % ix (f p)) dls preview (ix t % ix v % viArch % ix a % ix (f p)) dls
mv' = g mv mv' = g mv
@@ -312,6 +327,18 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
) )
. M.toList . M.toList
=<< platformVersionSpec =<< platformVersionSpec
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
maybe
(throwE NoDownload)
pure
(case p of
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro
)
-- | Tries to download from the given http or https url -- | 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

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

View File

@@ -1,7 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-| {-|
Module : GHCup.Types Module : GHCup.Types
@@ -21,6 +26,7 @@ module GHCup.Types
where where
import Control.Applicative import Control.Applicative
import Control.DeepSeq ( NFData, rnf )
import Control.Monad.Logger import Control.Monad.Logger
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
@@ -60,6 +66,8 @@ data GHCupInfo = GHCupInfo
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
instance NFData GHCupInfo
------------------------- -------------------------
@@ -79,6 +87,8 @@ data Requirements = Requirements
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
instance NFData Requirements
@@ -105,9 +115,13 @@ data Tool = GHC
| Stack | Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded) deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance NFData Tool
data GlobalTool = ShimGen data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded) deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance NFData GlobalTool
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
-- source download and per-architecture downloads. -- source download and per-architecture downloads.
@@ -123,6 +137,8 @@ data VersionInfo = VersionInfo
} }
deriving (Eq, GHC.Generic, Show) deriving (Eq, GHC.Generic, Show)
instance NFData VersionInfo
-- | A tag. These are currently attached to a version of a tool. -- | A tag. These are currently attached to a version of a tool.
data Tag = Latest data Tag = Latest
@@ -133,6 +149,8 @@ data Tag = Latest
| UnknownTag String -- ^ used for upwardscompat | UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
instance NFData Tag
tagToString :: Tag -> String tagToString :: Tag -> String
tagToString Recommended = "recommended" tagToString Recommended = "recommended"
tagToString Latest = "latest" tagToString Latest = "latest"
@@ -159,6 +177,8 @@ data Architecture = A_64
| A_ARM64 | A_ARM64
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance NFData Architecture
archToString :: Architecture -> String archToString :: Architecture -> String
archToString A_64 = "x86_64" archToString A_64 = "x86_64"
archToString A_32 = "i386" archToString A_32 = "i386"
@@ -181,6 +201,8 @@ data Platform = Linux LinuxDistro
-- ^ must exit -- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance NFData Platform
platformToString :: Platform -> String platformToString :: Platform -> String
platformToString (Linux distro) = "linux-" ++ distroToString distro platformToString (Linux distro) = "linux-" ++ distroToString distro
platformToString Darwin = "darwin" platformToString Darwin = "darwin"
@@ -206,6 +228,8 @@ data LinuxDistro = Debian
-- ^ must exit -- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance NFData LinuxDistro
distroToString :: LinuxDistro -> String distroToString :: LinuxDistro -> String
distroToString Debian = "debian" distroToString Debian = "debian"
distroToString Ubuntu = "ubuntu" distroToString Ubuntu = "ubuntu"
@@ -232,6 +256,7 @@ data DownloadInfo = DownloadInfo
} }
deriving (Eq, Ord, GHC.Generic, Show) deriving (Eq, Ord, GHC.Generic, Show)
instance NFData DownloadInfo
@@ -245,6 +270,8 @@ data TarDir = RealDir FilePath
| RegexDir String -- ^ will be compiled to regex, the first match will "win" | RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Ord, GHC.Generic, Show) deriving (Eq, Ord, GHC.Generic, Show)
instance NFData TarDir
instance Pretty TarDir where instance Pretty TarDir where
pPrint (RealDir path) = text path pPrint (RealDir path) = text path
pPrint (RegexDir regex) = text regex pPrint (RegexDir regex) = text regex
@@ -257,6 +284,10 @@ data URLSource = GHCupURL
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
deriving (GHC.Generic, Show) deriving (GHC.Generic, Show)
instance NFData URLSource
instance NFData (URIRef Absolute) where
rnf (URI !_ !_ !_ !_ !_) = ()
data UserSettings = UserSettings data UserSettings = UserSettings
{ uCache :: Maybe Bool { uCache :: Maybe Bool
@@ -266,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
@@ -298,6 +330,9 @@ data KeyBindings = KeyBindings
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
instance NFData KeyBindings
instance NFData Key
defaultKeyBindings :: KeyBindings defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings defaultKeyBindings = KeyBindings
{ bUp = KUp { bUp = KUp
@@ -317,7 +352,18 @@ data AppState = AppState
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo , ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest , pfreq :: PlatformRequest
} deriving (Show) } deriving (Show, GHC.Generic)
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
@@ -326,29 +372,39 @@ 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)
instance NFData Settings
data Dirs = Dirs data Dirs = Dirs
{ baseDir :: FilePath { baseDir :: FilePath
, binDir :: FilePath , binDir :: FilePath
, cacheDir :: FilePath , cacheDir :: FilePath
, logsDir :: FilePath , logsDir :: FilePath
, confDir :: FilePath , confDir :: FilePath
, tmpDir :: FilePath
} }
deriving Show deriving (Show, GHC.Generic)
instance NFData Dirs
data KeepDirs = Always data KeepDirs = Always
| Errors | Errors
| Never | Never
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord, GHC.Generic)
instance NFData KeepDirs
data Downloader = Curl data Downloader = Curl
| Wget | Wget
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
| Internal | Internal
#endif #endif
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord, GHC.Generic)
instance NFData Downloader
data DebugInfo = DebugInfo data DebugInfo = DebugInfo
{ diBaseDir :: FilePath { diBaseDir :: FilePath
@@ -371,7 +427,9 @@ data PlatformResult = PlatformResult
{ _platform :: Platform { _platform :: Platform
, _distroVersion :: Maybe Versioning , _distroVersion :: Maybe Versioning
} }
deriving (Eq, Show) deriving (Eq, Show, GHC.Generic)
instance NFData PlatformResult
platResToString :: PlatformResult -> String platResToString :: PlatformResult -> String
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' } platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
@@ -387,7 +445,9 @@ data PlatformRequest = PlatformRequest
, _rPlatform :: Platform , _rPlatform :: Platform
, _rVersion :: Maybe Versioning , _rVersion :: Maybe Versioning
} }
deriving (Eq, Show) deriving (Eq, Show, GHC.Generic)
instance NFData PlatformRequest
pfReqToString :: PlatformRequest -> String pfReqToString :: PlatformRequest -> String
pfReqToString (PlatformRequest arch plat ver) = pfReqToString (PlatformRequest arch plat ver) =
@@ -434,6 +494,8 @@ data VersionCmp = VR_gt Versioning
| VR_eq Versioning | VR_eq Versioning
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance NFData VersionCmp
-- | A version range. Supports && and ||, but not arbitrary -- | A version range. Supports && and ||, but not arbitrary
-- combinations. This is a little simplified. -- combinations. This is a little simplified.
@@ -441,6 +503,7 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
| OrRange (NonEmpty VersionCmp) VersionRange | OrRange (NonEmpty VersionCmp) VersionRange
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance NFData VersionRange
instance Pretty Versioning where instance Pretty Versioning where
pPrint = text . T.unpack . prettyV pPrint = text . T.unpack . prettyV
@@ -459,4 +522,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

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

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,11 +491,11 @@ 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
@@ -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}|]
@@ -1079,17 +1086,25 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO () ensureDirectories :: Dirs -> IO ()
ensureDirectories dirs = do ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
let Dirs
{ baseDir
, binDir
, cacheDir
, logsDir
, confDir
} = dirs
createDirRecursive' baseDir createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir createDirRecursive' binDir
createDirRecursive' cacheDir createDirRecursive' cacheDir
createDirRecursive' logsDir createDirRecursive' logsDir
createDirRecursive' confDir createDirRecursive' confDir
createDirRecursive' tmpDir
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)

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,13 +191,23 @@ ghcupLogsDir = do
#endif #endif
getDirs :: IO Dirs -- | Defaults to '~/.ghcup/tmp.
getDirs = do --
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
getAllDirs :: IO Dirs
getAllDirs = do
baseDir <- ghcupBaseDir baseDir <- ghcupBaseDir
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir
pure Dirs { .. } pure Dirs { .. }
@@ -226,9 +237,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 +247,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

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

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)

View File

@@ -0,0 +1,9 @@
MIT License
Copyright (c) 2019 Grégoire Geis
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice (including the next paragraph) shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

View File

@@ -0,0 +1,10 @@
This is free and unencumbered software released into the public domain.
Anyone is free to copy, modify, publish, use, compile, sell, or distribute this software, either in source code form or as a compiled binary, for any purpose, commercial or non-commercial, and by any means.
In jurisdictions that recognize copyright laws, the author or authors of this software dedicate any and all copyright interest in the software to the public domain. We make this dedication for the benefit of the public at large and to the detriment of our heirs and
successors. We intend this dedication to be an overt act of relinquishment in perpetuity of all present and future rights to this software under copyright law.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
For more information, please refer to <http://unlicense.org/>

View File

@@ -0,0 +1,71 @@
# `shim.c`
[`shim.c`](./shim.c) is a simple Windows program that, when started:
1. Looks for a file with the exact same name as the running program, but with
the extension `shim` (e.g. `C:\bin\foo.exe` will read the file `C:\bin\foo.shim`).
2. Reads and [parses](#shim-format) the files into a
[Scoop](https://github.com/lukesampson/scoop) shim format.
3. Executes the target executable with the given arguments.
`shim.c` was originally made to replace [Scoop](https://github.com/lukesampson/scoop)'s
[`shim.cs`](https://github.com/lukesampson/scoop/blob/96de9c14bb483f9278e4b0a9e22b1923ee752901/supporting/shimexe/shim.cs)
since it had several important flaws:
1. [It was made in C#](https://github.com/lukesampson/scoop/tree/96de9c14bb483f9278e4b0a9e22b1923ee752901/supporting/shimexe),
and thus required an instantiation of a .NET command line app everytime it was started,
which can make a command run much slower than if it had been ran directly;
2. [It](https://github.com/lukesampson/scoop/issues/2339) [did](https://github.com/lukesampson/scoop/issues/1896)
[not](https://github.com/felixse/FluentTerminal/issues/221) handle Ctrl+C and other
signals correctly, which could be quite infuriating (and essentially killing REPLs and long-running apps).
[`shim.c`](./shim.c) is:
- **Faster**, because it does not use the .NET Framework, and parses the `.shim` file in a simpler way.
- **More efficient**, because by the time the target of the shim is started, all allocated memory will have been freed.
- And more importantly, it **works better**:
- Signals originating from pressing `Ctrl+C` are ignored, and therefore handled directly by the spawned child.
Your processes and REPLs will no longer close when pressing `Ctrl+C`.
- Children are automatically killed when the shim process is killed. No more orphaned processes and weird behaviors.
> **Note**: This project is not affiliated with [Scoop](https://github.com/lukesampson/scoop).
## Installation for Scoop
- In a Visual Studio command prompt, run `cl /O1 shim.c`.
- Replace any `.exe` in `scoop\shims` by `shim.exe`.
An additional script, `repshims.bat`, is provided. It will replace all `.exe`s in the user's Scoop directory
by `shim.exe`.
## Example
Given the following shim `gs.shim`:
```
path = C:\Program Files\Git\git.exe
args = status -u
```
In this directory, where `gs.exe` is the compiled `shim.c`:
```
C:\Bin\
gs.exe
gs.shim
```
Then calling `gs -s` will run the program `C:\Program Files\Git\git.exe status -u -s`.
## Shim format
Shims follow the same format as Scoop's shims: line-separated `key = value` pairs.
```
path = C:\Program Files\Git\git.exe
args = status -uno
```
`path` is a required value, but `args` can be omitted. Also, do note that lines **must** end with a line feed.
## License
`SPDX-License-Identifier: MIT OR Unlicense`

View File

@@ -0,0 +1,15 @@
@echo off
if not defined SCOOP set SCOOP=%USERPROFILE%\scoop
for %%x in ("%SCOOP%\shims\*.exe") do (
echo Replacing %%x by new shim.
copy /B /Y shim.exe "%%~x" >NUL
)
if not defined SCOOP_GLOBAL set SCOOP_GLOBAL=%ProgramData%\scoop
for %%x in ("%SCOOP_GLOBAL%\shims\*.exe") do (
echo Replacing %%x by new shim.
copy /B /Y shim.exe "%%~x" >NUL
)

256
scoop-better-shimexe/shim.c Normal file
View File

@@ -0,0 +1,256 @@
#pragma comment(lib, "SHELL32.LIB")
#include <stdio.h>
#include <stdlib.h>
#include <wchar.h>
#include <Windows.h>
#ifndef ERROR_ELEVATION_REQUIRED
# define ERROR_ELEVATION_REQUIRED 740
#endif
#define MAX_FILENAME_SIZE 512
BOOL WINAPI ctrlhandler(DWORD fdwCtrlType)
{
switch (fdwCtrlType) {
// Ignore all events, and let the child process
// handle them.
case CTRL_C_EVENT:
case CTRL_CLOSE_EVENT:
case CTRL_LOGOFF_EVENT:
case CTRL_BREAK_EVENT:
case CTRL_SHUTDOWN_EVENT:
return TRUE;
default:
return FALSE;
}
}
int compute_program_length(const wchar_t* commandline)
{
int i = 0;
if (commandline[0] == L'"') {
// Wait till end of string
i++;
for (;;) {
wchar_t c = commandline[i++];
if (c == 0)
return i - 1;
else if (c == L'\\')
i++;
else if (c == L'"')
return i;
}
} else {
for (;;) {
wchar_t c = commandline[i++];
if (c == 0)
return i - 1;
else if (c == L'\\')
i++;
else if (c == L' ')
return i;
}
}
}
int main()
{
DWORD exit_code = 0;
wchar_t* path = NULL;
wchar_t* args = NULL;
wchar_t* cmd = NULL;
// Find filename of current executable.
wchar_t filename[MAX_FILENAME_SIZE + 2];
const unsigned int filename_size = GetModuleFileNameW(NULL, filename, MAX_FILENAME_SIZE);
if (filename_size >= MAX_FILENAME_SIZE) {
fprintf(stderr, "The filename of the program is too long to handle.\n");
exit_code = 1;
goto cleanup;
}
// Use filename of current executable to find .shim
filename[filename_size - 3] = L's';
filename[filename_size - 2] = L'h';
filename[filename_size - 1] = L'i';
filename[filename_size - 0] = L'm';
filename[filename_size + 1] = 0 ;
FILE* shim_file;
if ((shim_file = _wfsopen(filename, L"r,ccs=UTF-8", _SH_DENYNO)) == NULL) {
fprintf(stderr, "Cannot open shim file for read.\n");
exit_code = 1;
goto cleanup;
}
size_t command_length = 256;
size_t path_length;
size_t args_length;
// Read shim
wchar_t linebuf[8192];
for (;;) {
const wchar_t* line = fgetws(linebuf, 8192, shim_file);
if (line == NULL)
break;
if (line[4] != L' ' || line[5] != L'=' || line[6] != L' ')
continue;
const int linelen = wcslen(line);
const int len = linelen - 8 + (line[linelen - 1] != '\n');
if (line[0] == L'p' && line[1] == L'a' && line[2] == L't' && line[3] == L'h') {
// Reading path
path = calloc(len + 1, sizeof(wchar_t));
wmemcpy(path, line + 7, len);
command_length += len;
path_length = len;
continue;
}
if (line[0] == L'a' && line[1] == L'r' && line[2] == L'g' && line[3] == L's') {
// Reading args
args = calloc(len + 1, sizeof(wchar_t));
wmemcpy(args, line + 7, len);
command_length += len + 1;
args_length = len;
continue;
}
continue;
}
fclose(shim_file);
if (path == NULL) {
fprintf(stderr, "Could not read shim file.\n");
exit_code = 1;
goto cleanup;
}
// Find length of command to run
wchar_t* given_cmd = GetCommandLineW();
const int program_length = compute_program_length(given_cmd);
given_cmd += program_length;
const int given_length = wcslen(given_cmd);
command_length += given_length;
// Start building command to run, using '[path] [args]', as given by shim.
cmd = calloc(command_length, sizeof(wchar_t));
int cmd_i = 0;
wmemcpy(cmd, path, path_length);
cmd[path_length] = ' ';
cmd_i += path_length + 1;
if (args != NULL) {
wmemcpy(cmd + path_length + 1, args, args_length);
cmd[path_length + args_length + 1] = ' ';
cmd_i += args_length + 1;
}
// Copy all given arguments to command
wmemcpy(cmd + cmd_i, given_cmd, given_length);
// Find out if the target program is a console app
SHFILEINFOW sfi = {0};
const BOOL is_windows_app = HIWORD(SHGetFileInfoW(path, -1, &sfi, sizeof(sfi), SHGFI_EXETYPE));
if (is_windows_app)
// Unfortunately, this technique will still show a window for a fraction of time,
// but there's just no workaround.
FreeConsole();
// Create job object, which can be attached to child processes
// to make sure they terminate when the parent terminates as well.
JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli = {0};
HANDLE jobHandle = CreateJobObject(NULL, NULL);
jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE | JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK;
SetInformationJobObject(jobHandle, JobObjectExtendedLimitInformation, &jeli, sizeof(jeli));
// Start subprocess
STARTUPINFOW si = {0};
PROCESS_INFORMATION pi = {0};
if (CreateProcessW(NULL, cmd, NULL, NULL, TRUE, CREATE_SUSPENDED, NULL, NULL, &si, &pi)) {
AssignProcessToJobObject(jobHandle, pi.hProcess);
ResumeThread(pi.hThread);
} else {
if (GetLastError() == ERROR_ELEVATION_REQUIRED) {
// We must elevate the process, which is (basically) impossible with
// CreateProcess, and therefore we fallback to ShellExecuteEx,
// which CAN create elevated processes, at the cost of opening a new separate
// window.
// Theorically, this could be fixed (or rather, worked around) using pipes
// and IPC, but... this is a question for another day.
SHELLEXECUTEINFOW sei = {0};
sei.cbSize = sizeof(SHELLEXECUTEINFOW);
sei.fMask = SEE_MASK_NOCLOSEPROCESS;
sei.lpFile = path;
sei.lpParameters = cmd + path_length + 1;
sei.nShow = SW_SHOW;
if (!ShellExecuteExW(&sei)) {
fprintf(stderr, "Unable to create elevated process: error %li.", GetLastError());
exit_code = 1;
goto cleanup;
}
pi.hProcess = sei.hProcess;
} else {
fprintf(stderr, "Could not create process with command '%ls'.\n", cmd);
exit_code = 1;
goto cleanup;
}
}
// Ignore Ctrl-C and other signals
if (!SetConsoleCtrlHandler(ctrlhandler, TRUE))
fprintf(stderr, "Could not set control handler; Ctrl-C behavior may be invalid.\n");
// Wait till end of process
WaitForSingleObject(pi.hProcess, INFINITE);
GetExitCodeProcess(pi.hProcess, &exit_code);
// Dispose of everything
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
CloseHandle(jobHandle);
cleanup:
// Free obsolete buffers
free(path);
free(args);
free(cmd);
return (int)exit_code;
}

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

View File

@@ -67,7 +67,7 @@
<div> <div>
<div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button> <div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
</div> </div>
<p class="other-help">If you want to run an interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p> <p class="other-help">If you want to run an non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p>
</div> </div>
</p> </p>
<p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell. <p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.