Compare commits
24 Commits
v0.1.15.2-
...
issue-187
| Author | SHA1 | Date | |
|---|---|---|---|
4ed72fb517
|
|||
|
5217aa0a1d
|
|||
|
3caf91c640
|
|||
|
eb26a5133f
|
|||
|
9e9402a3a2
|
|||
|
bc13a4555d
|
|||
|
eaad2caf25
|
|||
|
6143cdf2e0
|
|||
|
2c7176d998
|
|||
|
327b80cf56
|
|||
|
005c9fbb83
|
|||
|
42134fd2a5
|
|||
|
bc85a7d9c3
|
|||
|
7e14fd4a08
|
|||
|
bf74d1e828
|
|||
|
f04708e8ae
|
|||
|
80e1924e5f
|
|||
|
c7393bd7c5
|
|||
|
664713bb13
|
|||
|
01715fdefc
|
|||
|
ab9b24e109
|
|||
|
34ecb1a56e
|
|||
|
e3aef38f75
|
|||
|
2f35513f6e
|
109
.github/workflows/release.yaml
vendored
Normal file
109
.github/workflows/release.yaml
vendored
Normal file
@@ -0,0 +1,109 @@
|
||||
name: Create Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- 'v*'
|
||||
|
||||
jobs:
|
||||
draft_release:
|
||||
name: Draft Release
|
||||
runs-on: ubuntu-latest
|
||||
outputs:
|
||||
upload_url: ${{ steps.create_release.outputs.upload_url }}
|
||||
|
||||
steps:
|
||||
- name: Create Release
|
||||
id: create_release
|
||||
uses: actions/create-release@v1
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
with:
|
||||
tag_name: ${{ github.ref }}
|
||||
release_name: Release ${{ github.ref }}
|
||||
body: |
|
||||
Changes in this Release
|
||||
- First Change
|
||||
- Second Change
|
||||
draft: true
|
||||
prerelease: false
|
||||
|
||||
release-mac:
|
||||
name: Create Release
|
||||
needs: draft_release
|
||||
runs-on: ${{ matrix.os }}
|
||||
env:
|
||||
MACOSX_DEPLOYMENT_TARGET: 10.13
|
||||
strategy:
|
||||
matrix:
|
||||
os:
|
||||
- macOS-10.15
|
||||
steps:
|
||||
- name: Checkout code
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- uses: haskell/actions/setup@v1.2
|
||||
with:
|
||||
ghc-version: 8.10.4
|
||||
cabal-version: 3.4.0.0
|
||||
|
||||
- name: create ~/.local/bin
|
||||
run: mkdir -p "$HOME/.local/bin"
|
||||
shell: bash
|
||||
|
||||
- name: Add ~/.local/bin to PATH
|
||||
run: echo "$HOME/.local/bin" >> $GITHUB_PATH
|
||||
shell: bash
|
||||
|
||||
- name: Update cabal cache
|
||||
run: cabal update
|
||||
shell: bash
|
||||
|
||||
- name: Install cabal dependencies
|
||||
run: cabal build --only-dependencies --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
|
||||
shell: bash
|
||||
|
||||
- name: Build
|
||||
run: cabal build --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
|
||||
shell: bash
|
||||
|
||||
- name: Install
|
||||
run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
|
||||
shell: bash
|
||||
|
||||
- name: Strip
|
||||
run: strip ~/.local/bin/ghcup
|
||||
shell: bash
|
||||
|
||||
- name: Run tests
|
||||
run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
|
||||
shell: bash
|
||||
|
||||
- name: Install git
|
||||
run: brew install git
|
||||
|
||||
- name: set HOME
|
||||
run: echo "HOME=$HOME" >> $GITHUB_ENV
|
||||
shell: bash
|
||||
|
||||
- name: Set ASSET_PATH
|
||||
run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
|
||||
shell: bash
|
||||
|
||||
- name: Upload Release Asset
|
||||
id: upload-release-asset
|
||||
uses: actions/upload-release-asset@v1
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
with:
|
||||
upload_url: ${{ needs.draft_release.outputs.upload_url }}
|
||||
asset_path: ${{ env.ASSET_PATH }}
|
||||
asset_name: ghcup-${{ matrix.os }}
|
||||
asset_content_type: application/octet-stream
|
||||
|
||||
- if: always()
|
||||
uses: actions/upload-artifact@v2
|
||||
with:
|
||||
name: plan.json
|
||||
path: ./dist-newstyle/cache/plan.json
|
||||
|
||||
29
.github/workflows/shimgen.yaml
vendored
Normal file
29
.github/workflows/shimgen.yaml
vendored
Normal 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
|
||||
|
||||
@@ -21,6 +21,7 @@ variables:
|
||||
OS: "LINUX"
|
||||
ARCH: "64"
|
||||
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
|
||||
CROSS: ""
|
||||
|
||||
.alpine:64bit:
|
||||
image: "alpine:3.12"
|
||||
@@ -105,6 +106,10 @@ variables:
|
||||
- golden
|
||||
when: on_failure
|
||||
|
||||
# .test_ghcup_scoop:
|
||||
# script:
|
||||
# - cl /O1 scoop-better-shimexe/shim.c
|
||||
|
||||
.test_ghcup_version:linux:
|
||||
extends:
|
||||
- .test_ghcup_version
|
||||
@@ -184,6 +189,12 @@ variables:
|
||||
- set CABAL_DIR="$CI_PROJECT_DIR/cabal"
|
||||
- bash ./.gitlab/before_script/windows/install_deps.sh
|
||||
|
||||
# .test_ghcup_scoop:windows:
|
||||
# extends:
|
||||
# - .windows
|
||||
# - .test_ghcup_scoop
|
||||
# - .root_cleanup
|
||||
|
||||
.release_ghcup:
|
||||
script:
|
||||
- bash ./.gitlab/script/ghcup_release.sh
|
||||
@@ -258,6 +269,24 @@ test:linux:latest:
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
test:linux:cross-armv7:
|
||||
stage: test
|
||||
extends:
|
||||
- .test_ghcup_version
|
||||
- .debian
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
GHC_TARGET_VERSION: "8.10.5"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: "arm-linux-gnueabihf"
|
||||
needs: []
|
||||
when: manual
|
||||
before_script:
|
||||
- ./.gitlab/before_script/linux/install_deps.sh
|
||||
script:
|
||||
- ./.gitlab/script/ghcup_cross.sh
|
||||
|
||||
|
||||
######## linux 32bit test ########
|
||||
|
||||
test:linux:recommended:32bit:
|
||||
@@ -276,6 +305,7 @@ test:linux:recommended:armv7:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
@@ -285,6 +315,7 @@ test:linux:recommended:aarch64:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
@@ -338,6 +369,11 @@ test:windows:recommended:
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
# test:windows:scoop:
|
||||
# stage: test
|
||||
# extends: .test_ghcup_scoop:windows
|
||||
# needs: []
|
||||
|
||||
######## linux release ########
|
||||
|
||||
release:linux:64bit:
|
||||
@@ -379,6 +415,7 @@ release:linux:armv7:
|
||||
ARTIFACT: "armv7-linux-ghcup"
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
|
||||
release:linux:aarch64:
|
||||
stage: release
|
||||
@@ -392,6 +429,7 @@ release:linux:aarch64:
|
||||
ARTIFACT: "aarch64-linux-ghcup"
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
CROSS: ""
|
||||
|
||||
######## darwin release ########
|
||||
|
||||
@@ -420,13 +458,19 @@ release:darwin:aarch64:
|
||||
script: |
|
||||
set -Eeuo pipefail
|
||||
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 \
|
||||
--argstr system "aarch64-darwin" \
|
||||
--pure \
|
||||
--keep CI_PROJECT_DIR --keep MAKE_ARGS --keep HADRIAN_ARGS --keep CABAL_CACHE \
|
||||
--keep CI_PROJECT_DIR \
|
||||
--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
|
||||
}
|
||||
runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1
|
||||
|
||||
@@ -9,6 +9,13 @@ mkdir -p "${TMPDIR}"
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https
|
||||
|
||||
if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then
|
||||
sudo apt-get install -y autoconf build-essential gcc-arm-linux-gnueabihf
|
||||
sudo dpkg --add-architecture armhf
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libncurses-dev:armhf
|
||||
fi
|
||||
|
||||
case "${ARCH}" in
|
||||
ARM*)
|
||||
case "${ARCH}" in
|
||||
@@ -57,9 +64,9 @@ case "${ARCH}" in
|
||||
chmod +x ghcup-bin
|
||||
|
||||
./ghcup-bin upgrade -i -f
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin set ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin install ghc ${GHC_VERSION}
|
||||
./ghcup-bin set ghc ${GHC_VERSION}
|
||||
./ghcup-bin install cabal ${CABAL_VERSION}
|
||||
|
||||
;;
|
||||
esac
|
||||
|
||||
52
.gitlab/script/ghcup_cross.sh
Executable file
52
.gitlab/script/ghcup_cross.sh
Executable 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" ]
|
||||
|
||||
@@ -15,10 +15,6 @@ git describe
|
||||
# build
|
||||
ecabal update
|
||||
|
||||
(
|
||||
cd /tmp
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
)
|
||||
|
||||
if [ "${OS}" = "LINUX" ] ; then
|
||||
if [ "${ARCH}" = "32" ] ; then
|
||||
|
||||
@@ -26,11 +26,6 @@ git describe --always
|
||||
|
||||
ecabal update
|
||||
|
||||
(
|
||||
cd /tmp
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
)
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} -ftui
|
||||
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
|
||||
@@ -83,10 +78,10 @@ ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
|
||||
|
||||
eghcup --numeric-version
|
||||
|
||||
eghcup install ${GHC_VERSION}
|
||||
eghcup install ghc ${GHC_VERSION}
|
||||
[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
|
||||
eghcup set ${GHC_VERSION}
|
||||
eghcup install-cabal ${CABAL_VERSION}
|
||||
eghcup set ghc ${GHC_VERSION}
|
||||
eghcup install cabal ${CABAL_VERSION}
|
||||
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
|
||||
|
||||
cabal --version
|
||||
@@ -112,17 +107,19 @@ else
|
||||
# test installing new ghc doesn't mess with currently set GHC
|
||||
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
|
||||
if [ "${OS}" = "LINUX" ] ; then
|
||||
eghcup --downloader=wget install 8.10.3
|
||||
eghcup --downloader=wget prefetch ghc 8.10.3
|
||||
eghcup --offline install ghc 8.10.3
|
||||
else # test wget a bit
|
||||
eghcup install 8.10.3
|
||||
eghcup prefetch ghc 8.10.3
|
||||
eghcup --offline install ghc 8.10.3
|
||||
fi
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
eghcup set 8.10.3
|
||||
eghcup --offline set 8.10.3
|
||||
eghcup set 8.10.3
|
||||
[ "$(ghc --numeric-version)" = "8.10.3" ]
|
||||
eghcup set ${GHC_VERSION}
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
eghcup rm 8.10.3
|
||||
eghcup --offline rm 8.10.3
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
@@ -142,6 +139,11 @@ else
|
||||
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)
|
||||
|
||||
@@ -153,6 +155,7 @@ if [ "${OS}" = "LINUX" ] ; then
|
||||
fi
|
||||
fi
|
||||
|
||||
|
||||
eghcup upgrade
|
||||
eghcup upgrade -f
|
||||
|
||||
|
||||
@@ -12,7 +12,7 @@ import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types hiding ( LeanAppState (..) )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
@@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
, rawOutter = \_ -> pure ()
|
||||
}
|
||||
downloadAll dli = do
|
||||
dirs <- liftIO getDirs
|
||||
dirs <- liftIO getAllDirs
|
||||
|
||||
pfreq <- (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
@@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
liftIO $ exitWith (ExitFailure 2)
|
||||
|
||||
let appstate = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
|
||||
let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
|
||||
|
||||
r <-
|
||||
runLogger
|
||||
@@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
case etool of
|
||||
Right (Just GHCup) -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
pure Nothing
|
||||
Right _ -> do
|
||||
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
|
||||
p <- liftE $ downloadCached dli Nothing
|
||||
fmap (Just . head . splitDirectories . head)
|
||||
. liftE
|
||||
. getArchiveFiles
|
||||
$ p
|
||||
Left ShimGen -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
pure Nothing
|
||||
case r of
|
||||
VRight (Just basePath) -> do
|
||||
|
||||
@@ -13,7 +13,7 @@ module BrickMain where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types hiding ( LeanAppState(..) )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Prelude ( decUTF8Safe )
|
||||
import GHCup.Utils.File
|
||||
@@ -53,8 +53,6 @@ import System.IO.Unsafe
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHCup.Types as GT
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Data.Vector as V
|
||||
@@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do
|
||||
settings' :: IORef AppState
|
||||
{-# NOINLINE settings' #-}
|
||||
settings' = unsafePerformIO $ do
|
||||
dirs <- getDirs
|
||||
dirs <- getAllDirs
|
||||
newIORef $ AppState (Settings { cache = True
|
||||
, noVerify = False
|
||||
, keepDirs = Never
|
||||
, downloader = Curl
|
||||
, verbose = False
|
||||
, urlSource = GHCupURL
|
||||
, noNetwork = False
|
||||
, ..
|
||||
})
|
||||
dirs
|
||||
@@ -578,9 +577,8 @@ logger' = unsafePerformIO
|
||||
|
||||
brickMain :: AppState
|
||||
-> LoggerConfig
|
||||
-> GHCupInfo
|
||||
-> IO ()
|
||||
brickMain s l gi = do
|
||||
brickMain s l = do
|
||||
writeIORef settings' s
|
||||
-- logger interpreter
|
||||
writeIORef logger' l
|
||||
@@ -588,7 +586,7 @@ brickMain s l gi = do
|
||||
|
||||
no_color <- isJust <$> lookupEnv "NO_COLOR"
|
||||
|
||||
eAppData <- getAppData (Just gi)
|
||||
eAppData <- getAppData (Just $ ghcupInfo s)
|
||||
case eAppData of
|
||||
Right ad ->
|
||||
defaultMain
|
||||
@@ -596,7 +594,7 @@ brickMain s l gi = do
|
||||
(BrickState ad
|
||||
defaultAppSettings
|
||||
(constructList ad defaultAppSettings Nothing)
|
||||
(keyBindings s)
|
||||
(keyBindings (s :: AppState))
|
||||
|
||||
)
|
||||
$> ()
|
||||
@@ -620,7 +618,7 @@ getGHCupInfo = do
|
||||
. flip runReaderT settings
|
||||
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF (GT.settings settings) (GT.dirs settings)
|
||||
$ getDownloadsF
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
|
||||
@@ -21,6 +21,7 @@ import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Requirements
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
@@ -33,6 +34,8 @@ import GHCup.Version
|
||||
import Codec.Archive
|
||||
#endif
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq ( force )
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@@ -88,6 +91,7 @@ data Options = Options
|
||||
, optNoVerify :: Maybe Bool
|
||||
, optKeepDirs :: Maybe KeepDirs
|
||||
, optsDownloader :: Maybe Downloader
|
||||
, optNoNetwork :: Maybe Bool
|
||||
-- commands
|
||||
, optCommand :: Command
|
||||
}
|
||||
@@ -108,6 +112,7 @@ data Command
|
||||
#if defined(BRICK)
|
||||
| Interactive
|
||||
#endif
|
||||
| Prefetch PrefetchCommand
|
||||
|
||||
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
||||
| ToolTag Tag
|
||||
@@ -197,6 +202,21 @@ data WhereisOptions = WhereisOptions {
|
||||
directory :: Bool
|
||||
}
|
||||
|
||||
data PrefetchOptions = PrefetchOptions {
|
||||
pfCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
|
||||
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
|
||||
| PrefetchMetadata
|
||||
|
||||
data PrefetchGHCOptions = PrefetchGHCOptions {
|
||||
pfGHCSrc :: Bool
|
||||
, pfGHCCacheDir :: Maybe FilePath
|
||||
}
|
||||
|
||||
|
||||
-- https://github.com/pcapriotti/optparse-applicative/issues/148
|
||||
|
||||
@@ -274,6 +294,7 @@ opts =
|
||||
#endif
|
||||
<> hidden
|
||||
))
|
||||
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
@@ -354,6 +375,16 @@ com =
|
||||
(progDesc "Find a tools location"
|
||||
<> footerDoc ( Just $ text whereisFooter ))
|
||||
)
|
||||
<> command
|
||||
"prefetch"
|
||||
(info
|
||||
( (Prefetch
|
||||
<$> prefetchP
|
||||
) <**> helper
|
||||
)
|
||||
(progDesc "Prefetch assets"
|
||||
<> footerDoc ( Just $ text prefetchFooter ))
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
@@ -437,6 +468,17 @@ Examples:
|
||||
# outputs ~/.ghcup/bin/
|
||||
ghcup whereis --directory cabal 3.4.0.0|]
|
||||
|
||||
prefetchFooter :: String
|
||||
prefetchFooter = [s|Discussion:
|
||||
Prefetches tools or assets into "~/.ghcup/cache" directory. This can
|
||||
be then combined later with '--offline' flag, ensuring all assets that
|
||||
are required for offline use have been prefetched.
|
||||
|
||||
Examples:
|
||||
ghcup prefetch metadata
|
||||
ghcup prefetch ghc 8.10.5
|
||||
ghcup --offline install ghc 8.10.5|]
|
||||
|
||||
|
||||
installCabalFooter :: String
|
||||
installCabalFooter = [s|Discussion:
|
||||
@@ -822,6 +864,55 @@ Examples:
|
||||
ghcup whereis --directory stack 2.7.1|]
|
||||
|
||||
|
||||
prefetchP :: Parser PrefetchCommand
|
||||
prefetchP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
(info
|
||||
(PrefetchGHC
|
||||
<$> (PrefetchGHCOptions
|
||||
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
|
||||
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
|
||||
( progDesc "Download GHC assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"cabal"
|
||||
(info
|
||||
(PrefetchCabal
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
|
||||
( progDesc "Download cabal assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"hls"
|
||||
(info
|
||||
(PrefetchHLS
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
|
||||
( progDesc "Download HLS assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"stack"
|
||||
(info
|
||||
(PrefetchStack
|
||||
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
|
||||
( progDesc "Download stack assets for installation")
|
||||
)
|
||||
<>
|
||||
command
|
||||
"metadata"
|
||||
(const PrefetchMetadata <$> info
|
||||
helper
|
||||
( progDesc "Download ghcup's metadata, needed for various operations")
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
ghcCompileOpts :: Parser GHCCompileOptions
|
||||
ghcCompileOpts =
|
||||
GHCCompileOptions
|
||||
@@ -939,14 +1030,20 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
|
||||
|
||||
tagCompleter :: Tool -> [String] -> Completer
|
||||
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
|
||||
{ lcPrintDebug = False
|
||||
, colorOutter = mempty
|
||||
, rawOutter = mempty
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
|
||||
|
||||
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (\t -> t /= Old)
|
||||
@@ -959,19 +1056,24 @@ tagCompleter tool add = listIOCompleter $ do
|
||||
|
||||
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
|
||||
versionCompleter criteria tool = listIOCompleter $ do
|
||||
dirs' <- liftIO getDirs
|
||||
dirs' <- liftIO getAllDirs
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = False
|
||||
, colorOutter = mempty
|
||||
, rawOutter = mempty
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
|
||||
mpFreq <- runLogger . runE $ platformRequest
|
||||
forFold mpFreq $ \pfreq ->
|
||||
settings = Settings True False Never Curl False GHCupURL True
|
||||
let leanAppState = LeanAppState
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
|
||||
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
|
||||
forFold mpFreq $ \pfreq -> do
|
||||
forFold mGhcUpInfo $ \ghcupInfo -> do
|
||||
let appState = AppState
|
||||
(Settings True False Never Curl False GHCupURL)
|
||||
settings
|
||||
dirs'
|
||||
defaultKeyBindings
|
||||
ghcupInfo
|
||||
@@ -1120,6 +1222,7 @@ toSettings options = do
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
||||
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
|
||||
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
|
||||
in (Settings {..}, keyBindings)
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
defaultDownloader = Internal
|
||||
@@ -1164,8 +1267,10 @@ describe_result :: String
|
||||
describe_result = $( LitE . StringL <$>
|
||||
runIO (do
|
||||
CapturedProcess{..} <- do
|
||||
dirs <- liftIO getDirs
|
||||
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
|
||||
dirs <- liftIO getAllDirs
|
||||
let settings = AppState (Settings True False Never Curl False GHCupURL False)
|
||||
dirs
|
||||
defaultKeyBindings
|
||||
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
|
||||
@@ -1217,7 +1322,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(footerDoc (Just $ text main_footer))
|
||||
)
|
||||
>>= \opt@Options {..} -> do
|
||||
dirs <- getDirs
|
||||
dirs@Dirs{..} <- getAllDirs
|
||||
|
||||
-- create ~/.ghcup dir
|
||||
ensureDirectories dirs
|
||||
@@ -1225,7 +1330,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(settings, keybindings) <- toSettings opt
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging (logsDir dirs)
|
||||
logfile <- initGHCupFileLogging logsDir
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = verbose settings
|
||||
, colorOutter = B.hPut stderr
|
||||
@@ -1237,53 +1342,64 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
|
||||
|
||||
pfreq <- (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
) >>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
-------------------------
|
||||
-- Setting up appstate --
|
||||
-------------------------
|
||||
|
||||
|
||||
let leanAppstate = LeanAppState settings dirs keybindings
|
||||
appState = do
|
||||
pfreq <- (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
) >>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
----------------------------------------
|
||||
-- Getting download and platform info --
|
||||
----------------------------------------
|
||||
ghcupInfo <-
|
||||
( runLogger
|
||||
. flip runReaderT leanAppstate
|
||||
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq
|
||||
|
||||
ghcupInfo <-
|
||||
( runLogger
|
||||
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE
|
||||
$ getDownloadsF settings dirs
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
|
||||
Just _ -> pure ()
|
||||
|
||||
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
|
||||
Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
|
||||
Just _ -> pure ()
|
||||
-- TODO: always run for windows
|
||||
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 30)
|
||||
pure s'
|
||||
|
||||
|
||||
-- ensure global tools
|
||||
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 30)
|
||||
#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 =
|
||||
runLogger
|
||||
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform)
|
||||
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
@@ -1313,12 +1429,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runInstTool = runInstTool' appstate
|
||||
let runInstTool mInstPlatform action' = do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s' mInstPlatform action'
|
||||
|
||||
let
|
||||
runLeanSetGHC =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
@@ -1328,9 +1457,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
]
|
||||
|
||||
let
|
||||
runLeanSetCabal =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
runSetCabal =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
@@ -1341,7 +1480,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let
|
||||
runSetHLS =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
@@ -1349,20 +1488,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . flip runReaderT appstate
|
||||
runLeanSetHLS =
|
||||
runLogger
|
||||
. runLeanAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . runAppState
|
||||
|
||||
let runRm =
|
||||
runLogger . flip runReaderT appstate . runE @'[NotInstalled]
|
||||
runLogger . runAppState . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
let runCompileGHC =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
@@ -1382,9 +1531,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
]
|
||||
|
||||
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 =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, NoToolVersionSet
|
||||
@@ -1394,7 +1555,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
let runUpgrade =
|
||||
runLogger
|
||||
. flip runReaderT appstate
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ DigestError
|
||||
@@ -1405,6 +1566,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runPrefetch =
|
||||
runLogger
|
||||
. runAppState
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, NoDownload
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, JSONError
|
||||
, FileDoesNotExistError
|
||||
]
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Command functions --
|
||||
@@ -1417,13 +1593,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
liftE $ installGHCBin (_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- liftIO appState
|
||||
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
liftE $ installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
when instSet $ void $ liftE $ setGHC v SetGHCOnly
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@@ -1455,12 +1633,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
liftE $ installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@@ -1484,12 +1664,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer HLS
|
||||
liftE $ installHLSBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@@ -1513,12 +1695,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBin (_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
Just uri -> do
|
||||
s' <- appState
|
||||
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@@ -1537,11 +1721,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
runSetGHC (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
let setGHC' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
|
||||
_ -> runSetGHC (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@@ -1552,12 +1738,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 5
|
||||
|
||||
let setCabal' SetOptions{..} =
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setCabal' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
|
||||
_ -> runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@@ -1568,12 +1756,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setHLS' SetOptions{..} =
|
||||
runSetHLS (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setHLS' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
|
||||
_ -> runSetHLS (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@@ -1584,12 +1774,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setStack' SetOptions{..} =
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
let setStack' SetOptions{ sToolVer } =
|
||||
case sToolVer of
|
||||
(SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
|
||||
_ -> runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
@@ -1604,6 +1796,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmGHCVer ghcVer
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
|
||||
)
|
||||
>>= \case
|
||||
@@ -1619,6 +1812,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmCabalVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv Cabal dls)
|
||||
)
|
||||
>>= \case
|
||||
@@ -1634,6 +1828,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmHLSVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv HLS dls)
|
||||
)
|
||||
>>= \case
|
||||
@@ -1649,6 +1844,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runRm (do
|
||||
liftE $
|
||||
rmStackVer tv
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
pure (getVersionInfo tv Stack dls)
|
||||
)
|
||||
>>= \case
|
||||
@@ -1663,7 +1859,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
res <- case optCommand of
|
||||
#if defined(BRICK)
|
||||
Interactive -> do
|
||||
liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess
|
||||
s' <- appState
|
||||
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
|
||||
#endif
|
||||
Install (Right iopts) -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
||||
@@ -1713,6 +1910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runCompileGHC (do
|
||||
case targetGhc of
|
||||
Left targetVer -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo targetVer GHC dls
|
||||
forM_ (_viPreCompile =<< vi) $ \msg -> do
|
||||
lift $ $(logInfo) msg
|
||||
@@ -1728,6 +1926,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
buildConfig
|
||||
patchDir
|
||||
addConfArgs
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
|
||||
when setCompile $ void $ liftE $
|
||||
setGHC targetVer SetGHCOnly
|
||||
@@ -1755,6 +1954,21 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 9
|
||||
|
||||
Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
|
||||
runLeanWhereIs (do
|
||||
loc <- liftE $ whereIsTool tool v
|
||||
if directory
|
||||
then pure $ takeDirectory loc
|
||||
else pure loc
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
putStr r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
|
||||
runWhereIs (do
|
||||
(v, _) <- liftE $ fromVersion whereVer tool
|
||||
@@ -1771,14 +1985,15 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
Upgrade uOpts force -> do
|
||||
Upgrade uOpts force' -> do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> Just <$> liftIO getExecutablePath
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
|
||||
|
||||
runUpgrade (liftE $ upgradeGHCup target force) >>= \case
|
||||
runUpgrade (liftE $ upgradeGHCup target force') >>= \case
|
||||
VRight v' -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
|
||||
let pretty_v = prettyVer v'
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
runLogger $ $(logInfo)
|
||||
@@ -1793,23 +2008,26 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 11
|
||||
|
||||
ToolRequirements ->
|
||||
flip runReaderT appstate
|
||||
$ runLogger
|
||||
(runE
|
||||
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
|
||||
$ do
|
||||
platform <- liftE getPlatform
|
||||
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
ToolRequirements -> do
|
||||
s' <- appState
|
||||
flip runReaderT s'
|
||||
$ runLogger
|
||||
(runE
|
||||
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
|
||||
$ do
|
||||
GHCupInfo { .. } <- lift getGHCupInfo
|
||||
platform' <- liftE getPlatform
|
||||
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
|
||||
ChangeLog ChangeLogOptions{..} -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
|
||||
let tool = fromMaybe GHC clTool
|
||||
ver' = maybe
|
||||
(Right Latest)
|
||||
@@ -1827,6 +2045,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
)
|
||||
pure ExitSuccess
|
||||
Just uri -> do
|
||||
pfreq <- runAppState getPlatformReq
|
||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||
cmd = case _rPlatform pfreq of
|
||||
Darwin -> "open"
|
||||
@@ -1835,20 +2054,23 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
Windows -> "start"
|
||||
|
||||
if clOpen
|
||||
then
|
||||
flip runReaderT appstate $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
Right _ -> pure ExitSuccess
|
||||
Left e -> runLogger ($(logError) [i|#{e}|])
|
||||
>> pure (ExitFailure 13)
|
||||
then do
|
||||
s' <- appState
|
||||
flip runReaderT s' $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
Right _ -> pure ExitSuccess
|
||||
Left e -> runLogger ($(logError) [i|#{e}|])
|
||||
>> pure (ExitFailure 13)
|
||||
else putStrLn uri' >> pure ExitSuccess
|
||||
|
||||
Nuke ->
|
||||
runRm (do
|
||||
s' <- liftIO appState
|
||||
void $ liftIO $ evaluate $ force s'
|
||||
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
|
||||
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
|
||||
liftIO $ threadDelay 10000000 -- wait 10s
|
||||
@@ -1875,6 +2097,37 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
Prefetch pfCom ->
|
||||
runPrefetch (do
|
||||
case pfCom of
|
||||
PrefetchGHC
|
||||
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt GHC
|
||||
if pfGHCSrc
|
||||
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
|
||||
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
|
||||
PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Cabal
|
||||
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
|
||||
PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt HLS
|
||||
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
|
||||
PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Stack
|
||||
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
|
||||
PrefetchMetadata -> do
|
||||
_ <- liftE $ getDownloadsF
|
||||
pure ""
|
||||
) >>= \case
|
||||
VRight _ -> do
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
|
||||
case res of
|
||||
@@ -1884,22 +2137,46 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
pure ()
|
||||
|
||||
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
fromVersion :: ( MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion tv = fromVersion' (toSetToolVer tv)
|
||||
|
||||
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
fromVersion' :: ( MonadLogger m
|
||||
, MonadFail m
|
||||
, MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> SetToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion' SetRecommended tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
|
||||
?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolVersion v) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion v) tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of
|
||||
Left _ -> pure (v, vi)
|
||||
@@ -1909,16 +2186,16 @@ fromVersion' (SetToolVersion v) tool = do
|
||||
Nothing -> pure (v, vi)
|
||||
Right _ -> pure (v, vi)
|
||||
fromVersion' (SetToolTag Latest) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
fromVersion' (SetToolTag Recommended) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolTag (Base pvp'')) GHC = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
|
||||
fromVersion' SetNext tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
next <- case tool of
|
||||
GHC -> do
|
||||
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
|
||||
@@ -2119,7 +2396,10 @@ printListResult raw lr = do
|
||||
| otherwise -> 1
|
||||
|
||||
|
||||
checkForUpdates :: ( MonadReader AppState m
|
||||
checkForUpdates :: ( MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
@@ -2129,7 +2409,7 @@ checkForUpdates :: ( MonadReader AppState m
|
||||
)
|
||||
=> m ()
|
||||
checkForUpdates = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
lInstalled <- listVersions Nothing (Just ListInstalled)
|
||||
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
|
||||
|
||||
|
||||
@@ -82,7 +82,6 @@ library
|
||||
QuasiQuotes
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
TypeApplications
|
||||
@@ -117,7 +116,7 @@ library
|
||||
, megaparsec >=8.0.0 && <9.1
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
, optics >=0.2 && <0.5
|
||||
, optics ^>=0.4
|
||||
, optics-vl ^>=0.2
|
||||
, os-release ^>=1.0.0
|
||||
, parsec ^>=3.1
|
||||
@@ -195,7 +194,6 @@ executable ghcup
|
||||
PackageImports
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
|
||||
@@ -207,6 +205,7 @@ executable ghcup
|
||||
, base >=4.13 && <5
|
||||
, bytestring ^>=0.10
|
||||
, containers ^>=0.6
|
||||
, deepseq ^>=1.4
|
||||
, filepath ^>=1.4.2.1
|
||||
, ghcup
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
@@ -261,7 +260,6 @@ executable ghcup-gen
|
||||
QuasiQuotes
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
TypeApplications
|
||||
@@ -281,7 +279,7 @@ executable ghcup-gen
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
, optics >=0.2 && <0.5
|
||||
, optics ^>=0.4
|
||||
, optparse-applicative >=0.15.1.0 && <0.17
|
||||
, pretty ^>=1.1.3.1
|
||||
, pretty-terminal ^>=0.1.0.0
|
||||
@@ -305,6 +303,7 @@ executable ghcup-gen
|
||||
test-suite ghcup-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
build-tool-depends: hspec-discover:hspec-discover -any
|
||||
hs-source-dirs: test
|
||||
other-modules:
|
||||
GHCup.ArbitraryTypes
|
||||
|
||||
502
lib/GHCup.hs
502
lib/GHCup.hs
File diff suppressed because it is too large
Load Diff
@@ -107,32 +107,31 @@ import qualified Data.Yaml as Y
|
||||
getDownloadsF :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Settings
|
||||
-> Dirs
|
||||
-> Excepts
|
||||
=> Excepts
|
||||
'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
m
|
||||
GHCupInfo
|
||||
getDownloadsF settings@Settings{ urlSource } dirs = do
|
||||
getDownloadsF = do
|
||||
Settings { urlSource } <- lift getSettings
|
||||
case urlSource of
|
||||
GHCupURL -> liftE $ getBase dirs settings
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
GHCupURL -> liftE $ getBase ghcupURL
|
||||
(OwnSource url) -> liftE $ getBase url
|
||||
(OwnSpec av) -> pure av
|
||||
(AddSource (Left ext)) -> do
|
||||
base <- liftE $ getBase dirs settings
|
||||
base <- liftE $ getBase ghcupURL
|
||||
pure (mergeGhcupInfo base ext)
|
||||
(AddSource (Right uri)) -> do
|
||||
base <- liftE $ getBase dirs settings
|
||||
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
|
||||
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
|
||||
base <- liftE $ getBase ghcupURL
|
||||
ext <- liftE $ getBase uri
|
||||
pure (mergeGhcupInfo base ext)
|
||||
|
||||
where
|
||||
@@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
|
||||
in GHCupInfo tr newDownloads newGlobalTools
|
||||
|
||||
|
||||
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
|
||||
=> Dirs
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
readFromCache Dirs {..} = do
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
$ liftIO
|
||||
$ L.readFile yaml_file
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
readFromCache :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m)
|
||||
=> URI
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
|
||||
readFromCache uri = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
|
||||
handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
. liftIO
|
||||
. L.readFile
|
||||
$ yaml_file
|
||||
|
||||
|
||||
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
|
||||
=> Dirs
|
||||
-> Settings
|
||||
getBase :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
handleIO (\_ -> readFromCache dirs)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache dirs)
|
||||
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
|
||||
where
|
||||
getBase uri = do
|
||||
Settings { noNetwork } <- lift getSettings
|
||||
bs <- if noNetwork
|
||||
then readFromCache uri
|
||||
else handleIO (\_ -> warnCache >> readFromCache uri)
|
||||
. catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
|
||||
. reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
|
||||
$ smartDl uri
|
||||
liftE
|
||||
. lE' @_ @_ @'[JSONError] JSONDecodeError
|
||||
. first show
|
||||
. Y.decodeEither'
|
||||
. L.toStrict
|
||||
$ bs
|
||||
where
|
||||
warnCache = lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
@@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
-- than the local file.
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
smartDl :: forall m1
|
||||
. ( MonadCatch m1
|
||||
smartDl :: forall m1 env1
|
||||
. ( MonadReader env1 m1
|
||||
, HasDirs env1
|
||||
, HasSettings env1
|
||||
, MonadCatch m1
|
||||
, MonadIO m1
|
||||
, MonadFail m1
|
||||
, MonadLogger m1
|
||||
@@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let path = view pathL' uri'
|
||||
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <- liftIO $ getAccessTime json_file
|
||||
@@ -237,11 +257,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
|
||||
where
|
||||
dlWithMod modTime json_file = do
|
||||
bs <- liftE $ downloadBS downloader uri'
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
dlWithoutMod json_file = do
|
||||
bs <- liftE $ downloadBS downloader uri'
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile json_file
|
||||
liftIO $ L.writeFile json_file bs
|
||||
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
@@ -279,39 +299,46 @@ getBase dirs@Dirs{..} Settings{ downloader } =
|
||||
setModificationTime path utctime
|
||||
|
||||
|
||||
getDownloadInfo :: Tool
|
||||
getDownloadInfo :: ( MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
)
|
||||
=> Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> PlatformRequest
|
||||
-> GHCupDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
-> Excepts
|
||||
'[NoDownload]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo t v = do
|
||||
(PlatformRequest a p mv) <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
let distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
=<< platformVersionSpec
|
||||
maybe
|
||||
(throwE NoDownload)
|
||||
pure
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
@@ -321,17 +348,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
-- 2. otherwise create a random file
|
||||
--
|
||||
-- The file must not exist.
|
||||
download :: ( MonadMask m
|
||||
download :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Settings
|
||||
-> DownloadInfo
|
||||
=> DownloadInfo
|
||||
-> FilePath -- ^ destination dir
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
download settings@Settings{ downloader } dli dest mfn
|
||||
download dli dest mfn
|
||||
| scheme == "https" = dl
|
||||
| scheme == "http" = dl
|
||||
| scheme == "file" = cp
|
||||
@@ -362,6 +391,8 @@ download settings@Settings{ downloader } dli dest mfn
|
||||
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
Settings{ downloader, noNetwork } <- lift getSettings
|
||||
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
@@ -377,58 +408,66 @@ download settings@Settings{ downloader } dli dest mfn
|
||||
liftE $ downloadToFile https host fullPath port destFile
|
||||
#endif
|
||||
|
||||
liftE $ checkDigest settings dli destFile
|
||||
liftE $ checkDigest dli destFile
|
||||
pure destFile
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: FilePath
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
|
||||
(dest </>)
|
||||
mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
downloadCached :: ( MonadMask m
|
||||
downloadCached :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadMask m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Settings
|
||||
-> Dirs
|
||||
-> DownloadInfo
|
||||
=> DownloadInfo
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
downloadCached settings@Settings{ cache } dirs dli mfn = do
|
||||
downloadCached dli mfn = do
|
||||
Settings{ cache } <- lift getSettings
|
||||
case cache of
|
||||
True -> downloadCached' settings dirs dli mfn
|
||||
True -> downloadCached' dli mfn Nothing
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download settings dli tmp mfn
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
|
||||
downloadCached' :: ( MonadMask m
|
||||
downloadCached' :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Settings
|
||||
-> Dirs
|
||||
-> DownloadInfo
|
||||
=> DownloadInfo
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
|
||||
-> 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 cachfile = cacheDir </> fn
|
||||
let cachfile = destDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest settings dli cachfile
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure cachfile
|
||||
| otherwise -> liftE $ download settings dli cacheDir mfn
|
||||
| otherwise -> liftE $ download dli destDir mfn
|
||||
|
||||
|
||||
|
||||
@@ -441,9 +480,13 @@ downloadCached' settings Dirs{..} dli mfn = do
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
|
||||
=> Downloader
|
||||
-> URI
|
||||
downloadBS :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
@@ -452,10 +495,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS downloader uri'
|
||||
downloadBS uri'
|
||||
| scheme == "https"
|
||||
= dl True
|
||||
| scheme == "http"
|
||||
@@ -475,6 +519,8 @@ downloadBS downloader uri'
|
||||
dl _ = do
|
||||
#endif
|
||||
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
|
||||
Settings{ downloader, noNetwork } <- lift getSettings
|
||||
when noNetwork $ throwE NoNetwork
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
@@ -499,12 +545,18 @@ downloadBS downloader uri'
|
||||
#endif
|
||||
|
||||
|
||||
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
|
||||
=> Settings
|
||||
-> DownloadInfo
|
||||
checkDigest :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> FilePath
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest Settings{ noVerify } dli file = do
|
||||
checkDigest dli file = do
|
||||
Settings{ noVerify } <- lift getSettings
|
||||
let verify = not noVerify
|
||||
when verify $ do
|
||||
let p' = takeFileName file
|
||||
|
||||
@@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where
|
||||
pPrint (NoToolVersionSet tool) =
|
||||
text [i|No version is set for tool "#{tool}".|]
|
||||
|
||||
data NoNetwork = NoNetwork
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoNetwork where
|
||||
pPrint NoNetwork =
|
||||
text [i|A download was required or requested, but '--offline' was specified.|]
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ High-level errors ]--
|
||||
|
||||
@@ -1,7 +1,12 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
@@ -21,6 +26,7 @@ module GHCup.Types
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq ( NFData, rnf )
|
||||
import Control.Monad.Logger
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||
@@ -60,6 +66,8 @@ data GHCupInfo = GHCupInfo
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData GHCupInfo
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
@@ -79,6 +87,8 @@ data Requirements = Requirements
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Requirements
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -105,9 +115,13 @@ data Tool = GHC
|
||||
| Stack
|
||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||
|
||||
instance NFData Tool
|
||||
|
||||
data GlobalTool = ShimGen
|
||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||
|
||||
instance NFData GlobalTool
|
||||
|
||||
|
||||
-- | All necessary information of a tool version, including
|
||||
-- source download and per-architecture downloads.
|
||||
@@ -123,6 +137,8 @@ data VersionInfo = VersionInfo
|
||||
}
|
||||
deriving (Eq, GHC.Generic, Show)
|
||||
|
||||
instance NFData VersionInfo
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
@@ -133,6 +149,8 @@ data Tag = Latest
|
||||
| UnknownTag String -- ^ used for upwardscompat
|
||||
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
|
||||
|
||||
instance NFData Tag
|
||||
|
||||
tagToString :: Tag -> String
|
||||
tagToString Recommended = "recommended"
|
||||
tagToString Latest = "latest"
|
||||
@@ -159,6 +177,8 @@ data Architecture = A_64
|
||||
| A_ARM64
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData Architecture
|
||||
|
||||
archToString :: Architecture -> String
|
||||
archToString A_64 = "x86_64"
|
||||
archToString A_32 = "i386"
|
||||
@@ -181,6 +201,8 @@ data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData Platform
|
||||
|
||||
platformToString :: Platform -> String
|
||||
platformToString (Linux distro) = "linux-" ++ distroToString distro
|
||||
platformToString Darwin = "darwin"
|
||||
@@ -206,6 +228,8 @@ data LinuxDistro = Debian
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData LinuxDistro
|
||||
|
||||
distroToString :: LinuxDistro -> String
|
||||
distroToString Debian = "debian"
|
||||
distroToString Ubuntu = "ubuntu"
|
||||
@@ -232,6 +256,7 @@ data DownloadInfo = DownloadInfo
|
||||
}
|
||||
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"
|
||||
deriving (Eq, Ord, GHC.Generic, Show)
|
||||
|
||||
instance NFData TarDir
|
||||
|
||||
instance Pretty TarDir where
|
||||
pPrint (RealDir path) = text path
|
||||
pPrint (RegexDir regex) = text regex
|
||||
@@ -257,6 +284,10 @@ data URLSource = GHCupURL
|
||||
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
|
||||
instance NFData URLSource
|
||||
instance NFData (URIRef Absolute) where
|
||||
rnf (URI !_ !_ !_ !_ !_) = ()
|
||||
|
||||
|
||||
data UserSettings = UserSettings
|
||||
{ uCache :: Maybe Bool
|
||||
@@ -266,11 +297,12 @@ data UserSettings = UserSettings
|
||||
, uDownloader :: Maybe Downloader
|
||||
, uKeyBindings :: Maybe UserKeyBindings
|
||||
, uUrlSource :: Maybe URLSource
|
||||
, uNoNetwork :: Maybe Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
{ kUp :: Maybe Key
|
||||
@@ -298,6 +330,9 @@ data KeyBindings = KeyBindings
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData KeyBindings
|
||||
instance NFData Key
|
||||
|
||||
defaultKeyBindings :: KeyBindings
|
||||
defaultKeyBindings = KeyBindings
|
||||
{ bUp = KUp
|
||||
@@ -317,7 +352,18 @@ data AppState = AppState
|
||||
, keyBindings :: KeyBindings
|
||||
, ghcupInfo :: GHCupInfo
|
||||
, 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
|
||||
{ cache :: Bool
|
||||
@@ -326,29 +372,39 @@ data Settings = Settings
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noNetwork :: Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Settings
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: FilePath
|
||||
, binDir :: FilePath
|
||||
, cacheDir :: FilePath
|
||||
, logsDir :: FilePath
|
||||
, confDir :: FilePath
|
||||
, tmpDir :: FilePath
|
||||
}
|
||||
deriving Show
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Dirs
|
||||
|
||||
data KeepDirs = Always
|
||||
| Errors
|
||||
| Never
|
||||
deriving (Eq, Show, Ord)
|
||||
deriving (Eq, Show, Ord, GHC.Generic)
|
||||
|
||||
instance NFData KeepDirs
|
||||
|
||||
data Downloader = Curl
|
||||
| Wget
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
| Internal
|
||||
#endif
|
||||
deriving (Eq, Show, Ord)
|
||||
deriving (Eq, Show, Ord, GHC.Generic)
|
||||
|
||||
instance NFData Downloader
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: FilePath
|
||||
@@ -371,7 +427,9 @@ data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance NFData PlatformResult
|
||||
|
||||
platResToString :: PlatformResult -> String
|
||||
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
@@ -387,7 +445,9 @@ data PlatformRequest = PlatformRequest
|
||||
, _rPlatform :: Platform
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance NFData PlatformRequest
|
||||
|
||||
pfReqToString :: PlatformRequest -> String
|
||||
pfReqToString (PlatformRequest arch plat ver) =
|
||||
@@ -434,6 +494,8 @@ data VersionCmp = VR_gt Versioning
|
||||
| VR_eq Versioning
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData VersionCmp
|
||||
|
||||
|
||||
-- | A version range. Supports && and ||, but not arbitrary
|
||||
-- combinations. This is a little simplified.
|
||||
@@ -441,6 +503,7 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
|
||||
| OrRange (NonEmpty VersionCmp) VersionRange
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData VersionRange
|
||||
|
||||
instance Pretty Versioning where
|
||||
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
|
||||
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
|
||||
|
||||
|
||||
|
||||
@@ -1,4 +1,9 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types.Optics
|
||||
@@ -13,6 +18,7 @@ module GHCup.Types.Optics where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Optics
|
||||
import URI.ByteString
|
||||
@@ -58,3 +64,82 @@ pathL' = lensVL pathL
|
||||
|
||||
queryL' :: Lens' (URIRef a) Query
|
||||
queryL' = lensVL queryL
|
||||
|
||||
|
||||
|
||||
----------------------
|
||||
--[ Lens utilities ]--
|
||||
----------------------
|
||||
|
||||
|
||||
gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
|
||||
=> m a
|
||||
gets = asks (^. labelOptic @f)
|
||||
|
||||
|
||||
getAppState :: MonadReader AppState m => m AppState
|
||||
getAppState = ask
|
||||
|
||||
|
||||
getLeanAppState :: ( MonadReader env m
|
||||
, LabelOptic' "settings" A_Lens env Settings
|
||||
, LabelOptic' "dirs" A_Lens env Dirs
|
||||
, LabelOptic' "keyBindings" A_Lens env KeyBindings
|
||||
)
|
||||
=> m LeanAppState
|
||||
getLeanAppState = do
|
||||
s <- gets @"settings"
|
||||
d <- gets @"dirs"
|
||||
k <- gets @"keyBindings"
|
||||
pure (LeanAppState s d k)
|
||||
|
||||
|
||||
getSettings :: ( MonadReader env m
|
||||
, LabelOptic' "settings" A_Lens env Settings
|
||||
)
|
||||
=> m Settings
|
||||
getSettings = gets @"settings"
|
||||
|
||||
|
||||
getDirs :: ( MonadReader env m
|
||||
, LabelOptic' "dirs" A_Lens env Dirs
|
||||
)
|
||||
=> m Dirs
|
||||
getDirs = gets @"dirs"
|
||||
|
||||
|
||||
getKeyBindings :: ( MonadReader env m
|
||||
, LabelOptic' "keyBindings" A_Lens env KeyBindings
|
||||
)
|
||||
=> m KeyBindings
|
||||
getKeyBindings = gets @"keyBindings"
|
||||
|
||||
|
||||
getGHCupInfo :: ( MonadReader env m
|
||||
, LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
|
||||
)
|
||||
=> m GHCupInfo
|
||||
getGHCupInfo = gets @"ghcupInfo"
|
||||
|
||||
|
||||
getPlatformReq :: ( MonadReader env m
|
||||
, LabelOptic' "pfreq" A_Lens env PlatformRequest
|
||||
)
|
||||
=> m PlatformRequest
|
||||
getPlatformReq = gets @"pfreq"
|
||||
|
||||
|
||||
type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
|
||||
type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
|
||||
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
|
||||
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
|
||||
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
|
||||
|
||||
|
||||
getCache :: (MonadReader env m, HasSettings env) => m Bool
|
||||
getCache = getSettings <&> cache
|
||||
|
||||
|
||||
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
|
||||
getDownloader = getSettings <&> downloader
|
||||
|
||||
|
||||
@@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
ghcLinkDestination :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m, MonadIO m)
|
||||
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> GHCTargetVersion
|
||||
-> m FilePath
|
||||
ghcLinkDestination tool ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
|
||||
|
||||
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
rmMinorSymlinks :: ( MonadReader AppState m
|
||||
rmMinorSymlinks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
@@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
rmPlain :: ( MonadReader AppState m
|
||||
rmPlain :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
@@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m
|
||||
=> Maybe Text -- ^ target
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain target = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
mtv <- lift $ ghcSet target
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
@@ -159,17 +162,17 @@ rmPlain target = do
|
||||
|
||||
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
rmMajorSymlinks :: ( MonadReader AppState m
|
||||
rmMajorSymlinks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
Dirs {..} <- lift getDirs
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
|
||||
@@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
|
||||
-- | Whether the given GHC versin is installed.
|
||||
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
liftIO $ doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
-- | Whether the given GHC version is installed from source.
|
||||
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
-- | Whether the given GHC version is set as the current.
|
||||
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
||||
let ghcBin = binDir </> ghc <> exeExt
|
||||
|
||||
@@ -239,7 +242,7 @@ ghcSet mtarget = do
|
||||
|
||||
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
|
||||
-- If a dir cannot be parsed, returns left.
|
||||
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs = do
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
||||
@@ -249,10 +252,15 @@ getInstalledGHCs = do
|
||||
|
||||
|
||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
||||
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledCabals :: ( MonadLogger m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledCabals = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
@@ -264,16 +272,16 @@ getInstalledCabals = do
|
||||
|
||||
|
||||
-- | Whether the given cabal version is installed.
|
||||
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled ver = do
|
||||
vers <- fmap rights getInstalledCabals
|
||||
pure $ elem ver vers
|
||||
|
||||
|
||||
-- Return the currently set cabal version, if any.
|
||||
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@@ -317,10 +325,10 @@ cabalSet = do
|
||||
|
||||
-- | Get all installed hls, by matching on
|
||||
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
|
||||
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledHLSs = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@@ -337,10 +345,10 @@ getInstalledHLSs = do
|
||||
|
||||
-- | Get all installed stacks, by matching on
|
||||
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
|
||||
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledStacks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@@ -355,9 +363,9 @@ getInstalledStacks = do
|
||||
|
||||
-- Return the currently set stack version, if any.
|
||||
-- TODO: there's a lot of code duplication here :>
|
||||
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
|
||||
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
|
||||
stackSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let stackBin = binDir </> "stack" <> exeExt
|
||||
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@@ -395,13 +403,13 @@ stackSet = do
|
||||
stripRelativePath = MP.many (MP.try stripPathComponet)
|
||||
|
||||
-- | Whether the given Stack version is installed.
|
||||
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled ver = do
|
||||
vers <- fmap rights getInstalledStacks
|
||||
pure $ elem ver vers
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled ver = do
|
||||
vers <- fmap rights getInstalledHLSs
|
||||
pure $ elem ver vers
|
||||
@@ -409,9 +417,9 @@ hlsInstalled ver = do
|
||||
|
||||
|
||||
-- Return the currently set hls version, if any.
|
||||
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
@@ -443,7 +451,8 @@ hlsSet = do
|
||||
|
||||
|
||||
-- | Return the GHC versions the currently selected HLS supports.
|
||||
hlsGHCVersions :: ( MonadReader AppState m
|
||||
hlsGHCVersions :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
@@ -466,11 +475,11 @@ hlsGHCVersions = do
|
||||
|
||||
|
||||
-- | Get all server binaries for an hls version, if any.
|
||||
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
|
||||
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Version
|
||||
-> m [FilePath]
|
||||
hlsServerBinaries ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
@@ -482,12 +491,12 @@ hlsServerBinaries ver = do
|
||||
|
||||
|
||||
-- | Get the wrapper binary for an hls version, if any.
|
||||
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Version
|
||||
-> m (Maybe FilePath)
|
||||
hlsWrapperBinary ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
Dirs {..} <- getDirs
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
@@ -503,7 +512,7 @@ hlsWrapperBinary ver = do
|
||||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
@@ -511,9 +520,9 @@ hlsAllBinaries ver = do
|
||||
|
||||
|
||||
-- | Get the active symlinks for hls.
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
@@ -549,7 +558,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> Maybe Text -- ^ the target triple
|
||||
@@ -729,19 +738,6 @@ getLatestBaseVersion av pvpVer =
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ AppState Getter ]--
|
||||
-----------------------
|
||||
|
||||
|
||||
getCache :: MonadReader AppState m => m Bool
|
||||
getCache = ask <&> cache . settings
|
||||
|
||||
|
||||
getDownloader :: MonadReader AppState m => m Downloader
|
||||
getDownloader = ask <&> downloader . settings
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
@@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings
|
||||
-- Returns unversioned relative files without extension, e.g.:
|
||||
--
|
||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
||||
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m [FilePath]
|
||||
ghcToolFiles ver = do
|
||||
@@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
|
||||
make :: ( MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
-> m (Either ProcessError ())
|
||||
@@ -827,7 +828,7 @@ make args workdir = do
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake args workdir "ghc-make" Nothing
|
||||
|
||||
makeOut :: (MonadReader AppState m, MonadIO m)
|
||||
makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
-> m CapturedProcess
|
||||
@@ -840,7 +841,7 @@ makeOut args workdir = do
|
||||
|
||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||
-- on first failure.
|
||||
applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
|
||||
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
|
||||
=> FilePath -- ^ dir containing patches
|
||||
-> FilePath -- ^ dir to apply patches in
|
||||
-> Excepts '[PatchFailed] m ()
|
||||
@@ -858,7 +859,7 @@ applyPatches pdir ddir = do
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: (MonadReader AppState m, MonadIO m)
|
||||
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Platform
|
||||
-> FilePath
|
||||
-> m (Either ProcessError ())
|
||||
@@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) =
|
||||
--
|
||||
-- 1. the build directory, depending on the KeepDirs setting
|
||||
-- 2. the install destination, depending on whether the build failed
|
||||
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
|
||||
runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
|
||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe FilePath -- ^ dir to *always* clean up on exception
|
||||
-> Excepts e m a
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
AppState { settings = Settings {..} } <- lift ask
|
||||
Settings {..} <- lift getSettings
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ rmPath dir
|
||||
@@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
@@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m
|
||||
-> m ()
|
||||
createLink link exe = do
|
||||
#if defined(IS_WINDOWS)
|
||||
AppState { dirs } <- ask
|
||||
dirs <- getDirs
|
||||
let shimGen = cacheDir dirs </> "gs.exe"
|
||||
|
||||
let shim = dropExtension exe <.> "shim"
|
||||
@@ -1054,17 +1056,22 @@ ensureGlobalTools :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader AppState m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasGHCupInfo env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
|
||||
ensureGlobalTools = do
|
||||
#if defined(IS_WINDOWS)
|
||||
AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
|
||||
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
|
||||
settings <- lift getSettings
|
||||
dirs <- lift getDirs
|
||||
shimDownload <- liftE $ lE @_ @'[NoDownload]
|
||||
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
|
||||
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")
|
||||
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
||||
void $ (\(DigestError _ _) -> do
|
||||
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
|
||||
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
|
||||
@@ -1079,17 +1086,25 @@ ensureGlobalTools = do
|
||||
|
||||
-- | Ensure ghcup directory structure exists.
|
||||
ensureDirectories :: Dirs -> IO ()
|
||||
ensureDirectories dirs = do
|
||||
let Dirs
|
||||
{ baseDir
|
||||
, binDir
|
||||
, cacheDir
|
||||
, logsDir
|
||||
, confDir
|
||||
} = dirs
|
||||
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
|
||||
createDirRecursive' baseDir
|
||||
createDirRecursive' (baseDir </> "ghc")
|
||||
createDirRecursive' binDir
|
||||
createDirRecursive' cacheDir
|
||||
createDirRecursive' logsDir
|
||||
createDirRecursive' confDir
|
||||
createDirRecursive' tmpDir
|
||||
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)
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
( getAllDirs
|
||||
, ghcupBaseDir
|
||||
, ghcupConfigFile
|
||||
, ghcupCacheDir
|
||||
@@ -37,6 +37,7 @@ where
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
@@ -190,13 +191,23 @@ ghcupLogsDir = do
|
||||
#endif
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
getDirs = do
|
||||
-- | Defaults to '~/.ghcup/tmp.
|
||||
--
|
||||
-- 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
|
||||
binDir <- ghcupBinDir
|
||||
cacheDir <- ghcupCacheDir
|
||||
logsDir <- ghcupLogsDir
|
||||
confDir <- ghcupConfigDir
|
||||
tmpDir <- ghcupTmpDir
|
||||
pure Dirs { .. }
|
||||
|
||||
|
||||
@@ -226,9 +237,9 @@ ghcupConfigFile = do
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
|
||||
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
|
||||
ghcupGHCBaseDir = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
pure (baseDir </> "ghc")
|
||||
|
||||
|
||||
@@ -236,7 +247,7 @@ ghcupGHCBaseDir = do
|
||||
-- The dir may be of the form
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
||||
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m FilePath
|
||||
ghcupGHCDir ver = do
|
||||
|
||||
@@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
@@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
|
||||
SPP.executeFile path True args Nothing
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
@@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
|
||||
Settings {..} <- getSettings
|
||||
Dirs {..} <- getDirs
|
||||
let logfile = logsDir </> lfile <> ".log"
|
||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||
closeFd
|
||||
|
||||
@@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
@@ -146,7 +147,11 @@ executeOut path args chdir = do
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
@@ -154,7 +159,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
Dirs {..} <- getDirs
|
||||
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = logsDir </> lfile <> ".stderr.log"
|
||||
cp <- createProcessWithMingwPath ((proc exe args)
|
||||
|
||||
9
scoop-better-shimexe/LICENSE-MIT
Normal file
9
scoop-better-shimexe/LICENSE-MIT
Normal 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.
|
||||
10
scoop-better-shimexe/LICENSE-UNLICENSE
Normal file
10
scoop-better-shimexe/LICENSE-UNLICENSE
Normal 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/>
|
||||
71
scoop-better-shimexe/README.md
Normal file
71
scoop-better-shimexe/README.md
Normal 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`
|
||||
15
scoop-better-shimexe/repshims.bat
Normal file
15
scoop-better-shimexe/repshims.bat
Normal 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
256
scoop-better-shimexe/shim.c
Normal 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;
|
||||
}
|
||||
11
stack.yaml
11
stack.yaml
@@ -1,4 +1,4 @@
|
||||
resolver: lts-17.11
|
||||
resolver: lts-18.2
|
||||
|
||||
packages:
|
||||
- .
|
||||
@@ -12,6 +12,7 @@ extra-deps:
|
||||
|
||||
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
|
||||
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
|
||||
- base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231
|
||||
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
|
||||
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
|
||||
- chs-cabal-0.1.1.0@sha256:20ec6a9fb5ab6991f1a4adf157c537bd5d3b98d08d3c09c387c954c7c50bd011,1153
|
||||
@@ -20,17 +21,21 @@ extra-deps:
|
||||
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
|
||||
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
|
||||
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
|
||||
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
||||
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
|
||||
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
|
||||
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
|
||||
- hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
|
||||
- hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
|
||||
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
|
||||
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
||||
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
|
||||
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
|
||||
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
|
||||
- primitive-0.7.0.1@sha256:a381571c36edc7dca28b77fe8159b43c14c640087ec5946adacf949feec64231,3433
|
||||
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
|
||||
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
|
||||
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
|
||||
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
|
||||
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
|
||||
- regex-posix-clib-2.7
|
||||
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
|
||||
- streamly-bytestring-0.1.2@sha256:cc828f41d1c714c711d38fb213b4ed186febabba598ab080e13255f69c20b13c,2469
|
||||
|
||||
@@ -67,7 +67,7 @@
|
||||
<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>
|
||||
<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>
|
||||
</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.
|
||||
|
||||
Reference in New Issue
Block a user