Compare commits

..

1 Commits

Author SHA1 Message Date
8d3d3922f2 Better logging WIP 2021-05-11 14:44:02 +02:00
57 changed files with 20928 additions and 21272 deletions

View File

@@ -7,7 +7,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: 8d0224e6b2a08157649651e69302380b2bd24e11
DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
############################################################
# CI Step
@@ -20,7 +20,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.alpine:64bit:
image: "alpine:3.12"
@@ -29,7 +28,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.alpine:32bit:
image: "i386/alpine:3.12"
@@ -38,7 +36,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "32"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:armv7:
image: "arm32v7/fedora"
@@ -47,7 +44,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "ARM"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:aarch64:
image: "arm64v8/fedora"
@@ -56,7 +52,6 @@ variables:
variables:
OS: "LINUX"
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.darwin:
tags:
@@ -64,15 +59,6 @@ variables:
variables:
OS: "DARWIN"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.darwin:aarch64:
tags:
- aarch64-darwin-m1
variables:
OS: "DARWIN"
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.freebsd:
tags:
@@ -80,25 +66,22 @@ variables:
variables:
OS: "FREEBSD"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.windows:
tags:
- new-x86_64-windows
variables:
OS: "WINDOWS"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.root_cleanup:
after_script:
- bash ./.gitlab/after_script.sh
- BUILD_DIR=$CI_PROJECT_DIR
- echo "Cleaning $BUILD_DIR"
- cd $HOME
- test -n "$BUILD_DIR"
- shopt -s extglob
- rm -Rf "$BUILD_DIR"/!(out)
- exit 0
.test_ghcup_version:
script:
- bash ./.gitlab/script/ghcup_version.sh
- ./.gitlab/script/ghcup_version.sh
variables:
JSON_VERSION: "0.0.5"
JSON_VERSION: "0.0.4"
artifacts:
expire_in: 2 week
paths:
@@ -141,32 +124,6 @@ variables:
before_script:
- ./.gitlab/before_script/darwin/install_deps.sh
.test_ghcup_version:darwin:aarch64:
extends:
- .test_ghcup_version
- .darwin:aarch64
- .root_cleanup
script: |
set -Eeuo pipefail
function runInNixShell() {
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 MACOSX_DEPLOYMENT_TARGET \
--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
runInNixShell ./.gitlab/script/ghcup_version.sh 2>&1
.test_ghcup_version:freebsd:
extends:
- .test_ghcup_version
@@ -175,18 +132,9 @@ variables:
before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh
.test_ghcup_version:windows:
extends:
- .test_ghcup_version
- .windows
- .root_cleanup
before_script:
- set CABAL_DIR="$CI_PROJECT_DIR/cabal"
- bash ./.gitlab/before_script/windows/install_deps.sh
.release_ghcup:
script:
- bash ./.gitlab/script/ghcup_release.sh
- ./.gitlab/script/ghcup_release.sh
artifacts:
expire_in: 2 week
paths:
@@ -194,7 +142,7 @@ variables:
only:
- tags
variables:
JSON_VERSION: "0.0.5"
JSON_VERSION: "0.0.4"
######## stack test ########
@@ -217,27 +165,10 @@ test:linux:bootstrap_script:
script:
- ./.gitlab/script/ghcup_bootstrap.sh
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
extends:
- .debian
- .root_cleanup
needs: []
test:windows:bootstrap_powershell_script:
stage: test
script:
- ./bootstrap-haskell.ps1 -InstallDir $CI_PROJECT_DIR -BootstrapUrl $CI_PROJECT_DIR/bootstrap-haskell -InBash
after_script:
- "[Environment]::SetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', $null, [System.EnvironmentVariableTarget]::User)"
- "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)"
- "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)"
- bash ./.gitlab/after_script.sh
variables:
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
extends:
- .windows
needs: []
######## linux test ########
@@ -246,7 +177,7 @@ test:linux:recommended:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
@@ -254,7 +185,7 @@ test:linux:latest:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "9.0.1"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
@@ -264,7 +195,7 @@ test:linux:recommended:32bit:
stage: test
extends: .test_ghcup_version:linux32
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.2.0.0"
needs: []
@@ -302,19 +233,10 @@ test:mac:latest:
stage: test
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "9.0.1"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
test:mac:recommended:aarch64:
stage: test
extends: .test_ghcup_version:darwin:aarch64
variables:
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
needs: []
allow_failure: true
######## freebsd test ########
@@ -328,16 +250,17 @@ test:freebsd:recommended:
when: manual
needs: []
######## windows test ########
test:windows:recommended:
test:freebsd:latest:
stage: test
extends: .test_ghcup_version:windows
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
######## linux release ########
release:linux:64bit:
@@ -350,7 +273,7 @@ release:linux:64bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
@@ -364,7 +287,7 @@ release:linux:32bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "i386-linux-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.2.0.0"
release:linux:armv7:
@@ -406,44 +329,16 @@ release:darwin:
- ./.gitlab/before_script/darwin/install_deps.sh
variables:
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
MACOSX_DEPLOYMENT_TARGET: "10.7"
release:darwin:aarch64:
stage: release
needs: ["test:mac:recommended:aarch64"]
extends:
- .darwin:aarch64
- .release_ghcup
- .root_cleanup
script: |
set -Eeuo pipefail
function runInNixShell() {
time nix-shell .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 MACOSX_DEPLOYMENT_TARGET \
--keep JSON_VERSION --keep ARTIFACT \
--run "$1" 2>&1
}
runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1
runInNixShell ./.gitlab/script/ghcup_release.sh 2>&1
variables:
ARTIFACT: "aarch64-apple-darwin-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
MACOSX_DEPLOYMENT_TARGET: "10.7"
allow_failure: true
######## freebsd release ########
release:freebsd:
stage: release
needs: ["test:freebsd:recommended"]
needs: ["test:freebsd:recommended", "test:freebsd:latest"]
extends:
- .freebsd
- .release_ghcup
@@ -452,25 +347,9 @@ release:freebsd:
- ./.gitlab/before_script/freebsd/install_deps.sh
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true
######## windows release ########
release:windows:
stage: release
needs: ["test:windows:recommended"]
extends:
- .windows
- .release_ghcup
- .root_cleanup
before_script:
- bash ./.gitlab/before_script/windows/install_deps.sh
variables:
ARTIFACT: "x86_64-mingw64-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
######## hlint ########
@@ -483,7 +362,7 @@ hlint:
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
allow_failure: true

View File

@@ -1,15 +0,0 @@
#!/bin/sh
set -eux
BUILD_DIR=$CI_PROJECT_DIR
echo "Cleaning $BUILD_DIR"
cd $HOME
test -n "$BUILD_DIR"
shopt -s extglob
rm -Rf "$BUILD_DIR"/!(out)
if [ "${OS}" = "WINDOWS" ] ; then
rm -Rf /c/ghcup
fi
exit 0

View File

@@ -6,27 +6,12 @@ set -eux
mkdir -p "${TMPDIR}"
if [ $ARCH = 'ARM64' ] ; then
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.15.1/aarch64-apple-darwin-ghcup-0.1.15.1 > ./ghcup-bin
chmod +x ghcup-bin
else
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
fi
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
chmod +x ghcup-bin
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
if [ $ARCH = 'ARM64' ] ; then
cabal update
mkdir vendored
cd vendored
cabal unpack network-3.1.2.1
cd network*
autoreconf -fi
cd ../..
fi
./ghcup-bin upgrade -i -f
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
exit 0

View File

@@ -12,8 +12,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
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 -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
exit 0

View File

@@ -28,8 +28,8 @@ else
fi
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
# utils
apk add --no-cache \
@@ -41,9 +41,6 @@ apk add --no-cache \
zlib \
zlib-dev \
zlib-static \
bzip2 \
bzip2-dev \
bzip2-static \
gmp \
gmp-dev \
openssl-dev \

View File

@@ -7,13 +7,13 @@ set -eux
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
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
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 -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}

View File

@@ -19,7 +19,7 @@ ednf() {
}
ednf update
ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils bzip2-devel
ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils
if [ "${ARCH}" = "ARM64" ] ; then
ednf install numactl numactl-libs numactl-devel
fi

View File

@@ -7,4 +7,4 @@ set -eux
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
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget

View File

@@ -1,21 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
mkdir -p "${TMPDIR}" "${CABAL_DIR}"
mkdir -p "$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin"
CI_PROJECT_DIR=$(pwd)
curl -o ghcup.exe https://downloads.haskell.org/~ghcup/0.1.15.1/x86_64-mingw64-ghcup-0.1.15.1.exe
chmod +x ghcup.exe
./ghcup.exe install ${GHC_VERSION}
./ghcup.exe set ${GHC_VERSION}
./ghcup.exe install-cabal ${CABAL_VERSION}
rm ./ghcup.exe
exit 0

View File

@@ -1,9 +1,3 @@
if [ "${OS}" = "WINDOWS" ] ; then
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"
else
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"
fi
export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
export TMPDIR="$CI_PROJECT_DIR/tmp"

View File

@@ -7,7 +7,7 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
eghcup() {

View File

@@ -7,7 +7,7 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
@@ -29,20 +29,18 @@ if [ "${OS}" = "LINUX" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" --constraint="zip +disable-zstd" -ftui
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static"
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" -ftui
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
fi
mkdir out
binary=$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')
ver=$("${binary}" --numeric-version)
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version)
if [ "${OS}" = "DARWIN" ] ; then
strip "${binary}"
strip ./ghcup
else
strip -s "${binary}"
strip -s ./ghcup
fi
cp "${binary}" out/${ARTIFACT}-${ver}
cp ghcup out/${ARTIFACT}-${ver}

View File

@@ -6,18 +6,12 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd)
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
eghcup() {
if [ "${OS}" = "WINDOWS" ] ; then
ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
else
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
fi
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
@@ -34,47 +28,31 @@ ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -ftui
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd" ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
elif [ "${OS}" = "WINDOWS" ] ; then
ecabal build -w ghc-${GHC_VERSION}
ecabal test -w ghc-${GHC_VERSION} ghcup-test
ecabal haddock -w ghc-${GHC_VERSION}
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
if [ "${OS}" = "WINDOWS" ] ; then
ext=".exe"
else
ext=''
fi
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup${ext}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" "$CI_PROJECT_DIR"/.local/bin/ghcup-gen${ext}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
### cleanup
if [ "${OS}" = "WINDOWS" ] ; then
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
else
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
fi
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
@@ -97,46 +75,35 @@ eghcup list -t cabal
ghc_ver=$(ghc --numeric-version)
ghc --version
ghc-${ghc_ver} --version
if [ "${OS}" != "WINDOWS" ] ; then
ghci --version
ghci-${ghc_ver} --version
ghci --version
ghc-$(ghc --numeric-version) --version
ghci-$(ghc --numeric-version) --version
# 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
else # test wget a bit
eghcup install 8.10.3
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup 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
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
if [ "${OS}" = "DARWIN" ] && [ "${ARCH}" = "ARM64" ] ; then
echo
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
else # test wget a bit
eghcup install 8.10.3
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup 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
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
if [ "${OS}" = "DARWIN" ] ; then
# install hls
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup install stack
stack --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup install stack
stack --version
fi
fi
fi
@@ -144,21 +111,9 @@ fi
eghcup rm $(ghc --numeric-version)
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
if [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "64" ] ; then
eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
eghcup rm cabal 3.4.0.0-rc4
fi
fi
eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
eghcup rm cabal 3.4.0.0-rc4
eghcup upgrade
eghcup upgrade -f
# nuke
eghcup nuke
if [ "${OS}" = "WINDOWS" ] ; then
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/ghcup" ]
else
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
fi

View File

@@ -1,89 +0,0 @@
{ system ? "aarch64-darwin"
#, nixpkgs ? fetchTarball https://github.com/angerman/nixpkgs/archive/257cb120334.tar.gz #apple-silicon.tar.gz
, pkgs ? import <nixpkgs> { inherit system; }
, compiler ? if system == "aarch64-darwin" then "ghc8103Binary" else "ghc8103"
}: pkgs.mkShell {
# this prevents nix from trying to write the env-vars file.
# we can't really, as NIX_BUILD_TOP/env-vars is not set.
noDumpEnvVars=1;
# stop polluting LDFLAGS with -liconv
dontAddExtraLibs = true;
# we need to inject ncurses into --with-curses-libraries.
# the real fix is to teach terminfo to use libcurses on macOS.
# CONFIGURE_ARGS = "--with-intree-gmp --with-curses-libraries=${pkgs.ncurses.out}/lib";
CONFIGURE_ARGS = "--with-intree-gmp --with-curses-libraries=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib --with-iconv-includes=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include --with-iconv-libraries=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib SH=/bin/bash";
# magic speedup pony :facepalm:
#
# nix has the ugly habbit of duplicating ld flags more than necessary. This
# somewhat consolidates this.
shellHook = ''
export NIX_LDFLAGS=$(for a in $NIX_LDFLAGS; do echo $a; done |sort|uniq|xargs)
export NIX_LDFLAGS_FOR_TARGET=$(for a in $NIX_LDFLAGS_FOR_TARGET; do echo $a; done |sort|uniq|xargs)
export NIX_LDFLAGS_FOR_TARGET=$(comm -3 <(for l in $NIX_LDFLAGS_FOR_TARGET; do echo $l; done) <(for l in $NIX_LDFLAGS; do echo $l; done))
# Impurity hack for GHC releases.
#################################
# We don't want binary releases to depend on nix, thus we'll need to make sure we don't leak in references.
# GHC externally depends only on iconv and curses. However we can't force a specific curses library for
# the terminfo package, as such we'll need to make sure we only look in the system path for the curses library
# and not pick up the tinfo from the nix provided ncurses package.
#
# We also need to force us to use the systems COREFOUNDATION, not the one that nix builds. Again this is impure,
# but it will allow us to have proper binary distributions.
#
# do not use nixpkgs provided core foundation
export NIX_COREFOUNDATION_RPATH=/System/Library/Frameworks
# drop curses from the LDFLAGS, we really want the system ones, not the nix ones.
export NIX_LDFLAGS=$(for lib in $NIX_LDFLAGS; do case "$lib" in *curses*);; *) echo -n "$lib ";; esac; done;)
export NIX_CFLAGS_COMPILE+=" -Wno-nullability-completeness -Wno-availability -Wno-expansion-to-defined -Wno-builtin-requires-header -Wno-unused-command-line-argument"
# unconditionally add the MacOSX.sdk and TargetConditional.h
export NIX_CFLAGS_COMPILE+=" -isystem /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include"
'';
nativeBuildInputs = (with pkgs; [
# This needs to come *before* ghc,
# otherwise we migth end up with the clang from
# the bootstrap GHC in PATH with higher priority.
clang_11
llvm_11
haskell.compiler.${compiler}
haskell.packages.${compiler}.cabal-install
haskell.packages.${compiler}.alex
haskell.packages.${compiler}.happy # _1_19_12 is needed for older GHCs.
automake
autoconf
m4
gmp
zlib.out
zlib.dev
glibcLocales
# locale doesn't build yet :-/
# locale
git
python3
# python3Full
# python3Packages.sphinx
perl
which
wget
curl
file
xz
xlibs.lndir
cacert ])
++ (with pkgs.darwin.apple_sdk.frameworks; [ Foundation Security ]);
}

View File

@@ -1,30 +1,10 @@
# Revision history for ghcup
## 0.1.16 -- ????-??-??
## 0.1.15 -- ????-??-??
* Add 'nuke' subcommand wrt [#135](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/135), implemented by Arjun Kathuria
## 0.1.15.2 -- 2021-06-13
* Remove legacy handling of cabal binary and be more graceful about binaries not installed by ghcup (e.g. stack)
* Fix GHC compilation from git
* Fix 'ghcup upgrade' on windows
* Allow to skip update checks via `GHCUP_SKIP_UPDATE_CHECK`
* Use libarchive on windows as well, fixing unpack errors wrt [#147](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/147)
## 0.1.15.1 -- 2021-06-11
* Add Apple Silicon support
* Add windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130)
* Add stack support
* Add date to GHC bindist names created by ghcup
* Warn when /tmp doesn't have 5GB or more of disk space
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
* Allow to set custom ghc version when running 'ghcup compile ghc' wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/136)
* Add date to GHC bindist names created by ghcup
## 0.1.14.2 -- 2021-05-12
* Remove dead dependency on ascii-string
## 0.1.14.1 -- 2021-04-11

View File

@@ -6,6 +6,10 @@
This is an open variant, similar to [plucky](https://hackage.haskell.org/package/plucky) or [oops](https://github.com/i-am-tom/oops) and allows us to combine different error types. Maybe it is too much and it's a little bit [unergonomic](https://github.com/haskus/packages/issues/32) at times. If it really hurts maintenance, it will be removed. It was more of an experiment.
### No use of filepath or directory
Filepath and directory have two fundamental problems: 1. they use String as filepath (see [AFPP](https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/abstract-file-path) as to why this is wrong) and 2. they try very hard to be cross-platform at the expense of low-level correctness. Instead, we use the [hpath](https://github.com/hasufell/hpath) libraries for file and filepath related stuff, which also gives us stronger filepath types.
### No use of haskell-TLS
I consider haskell-TLS an interesting experiment, but not a battle-tested and peer-reviewed crypto implementation. There is little to no research about what the intricacies of using haskell for low-level crypto are and how vulnerable such binaries are. Instead, we use either curl the binary (for FreeBSD and mac) or http-io-streams, which works with OpenSSL bindings.

View File

@@ -1,9 +1,11 @@
`ghcup` makes it easy to install specific versions of `ghc` on GNU/Linux,
macOS (aka Darwin), FreeBSD and Windows and can also bootstrap a fresh Haskell developer environment from scratch.
macOS (aka Darwin) and FreeBSD and can also bootstrap a fresh Haskell developer environment from scratch.
It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well).
Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
## Table of Contents
* [Installation](#installation)
@@ -77,7 +79,7 @@ ghcup install cabal
ghcup upgrade
```
GHCup works very well with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do.
### Configuration
@@ -85,7 +87,7 @@ handles your haskell packages and can demand that [a specific version](https://c
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml).
Partial configuration is fine. Command line options always override the config file settings.
Partial configuration is fine. Command line options always overwrite the config file settings.
### Manpages
@@ -123,9 +125,6 @@ Then you can control the locations via XDG environment variables as such:
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
**Note that `ghcup` makes some assumptions about structure of files in `XDG_BIN_HOME`. So if you have other tools
installing e.g. stack/cabal/ghc into it, this will likely clash. In that case consider disabling XDG support.**
### Env variables
This is the complete list of env variables that change GHCup behavior:
@@ -135,7 +134,6 @@ This is the complete list of env variables that change GHCup behavior:
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup
### Installing custom bindists
@@ -238,8 +236,8 @@ ghcup is not a reimplementation of stack. The only common part is automatic inst
2. Why not support windows?
We do.
Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
3. Why the haskell reimplementation?
:-)
Why not?

View File

@@ -69,15 +69,13 @@ tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
def = TarballFilter Nothing (makeRegex ("" :: String))
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
@@ -107,21 +105,26 @@ main :: IO ()
main = do
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
ValidateYAML vopts -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate
ValidateTarballs vopts tarballFilter -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit (validateTarballs tarballFilter)
pure ()
where
withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
(GHCupInfo _ av) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith

View File

@@ -11,7 +11,6 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
@@ -23,7 +22,6 @@ import qualified Codec.Archive.Tar as Tar
#else
import Codec.Archive
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
@@ -39,11 +37,12 @@ import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import HPath ( toFilePath, rel )
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import System.Posix.FilePath
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
@@ -68,9 +67,8 @@ addError = do
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validate dls _ = do
validate dls = do
ref <- liftIO $ newIORef 0
-- verify binary downloads --
@@ -108,10 +106,6 @@ validate dls _ = do
addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
when (notElem Windows pspecs && arch == A_64) $ do
lift $ $(logError)
[i|Windows missing for for #{t} #{v'} #{arch'}|]
addError
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
@@ -184,7 +178,7 @@ validate dls _ = do
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
{ tfTool :: Maybe Tool
, tfVersion :: Regex
}
@@ -194,23 +188,22 @@ validateTarballs :: ( Monad m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, Alternative m
, MonadFail m
)
=> TarballFilter
-> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
validateTarballs (TarballFilter tool versionRegex) dls = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ allDls downloadAll
let dlis = nubOrd $ dls ^.. each
%& indices (maybe (const True) (==) tool) %> each
%& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viSourceDL % _Just `summing` viArch % each % each % each)
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ dlis downloadAll
-- exit
e <- liftIO $ readIORef ref
@@ -227,21 +220,11 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
}
downloadAll dli = do
dirs <- liftIO getDirs
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(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 settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
r <-
runLogger
. flip runReaderT appstate
. flip runReaderT settings
. runResourceT
. runE @'[DigestError
, DownloadFailed
@@ -253,25 +236,23 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
#endif
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
case tool of
Just GHCup -> do
let fn = [rel|ghcup|]
dir <- liftIO ghcupCacheDir
p <- liftE $ download dli dir (Just fn)
liftE $ checkDigest dli p
pure Nothing
Right _ -> do
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
_ -> do
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
pure Nothing
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
Just (RealDir (toFilePath -> prel)) -> do
lift $ $(logInfo)
[i|verifying subdir: #{prel}|]
when (basePath /= prel) $ do

View File

@@ -6,7 +6,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
module BrickMain where
@@ -15,7 +14,6 @@ import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
import GHCup.Utils.Logger
@@ -33,7 +31,6 @@ import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
@@ -60,18 +57,16 @@ import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
hiddenTools :: [Tool]
hiddenTools = [Stack]
data BrickData = BrickData
{ lr :: [ListResult]
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
deriving Show
data BrickSettings = BrickSettings
{ showAllVersions :: Bool
, showAllTools :: Bool
{ showAll :: Bool
}
deriving Show
@@ -100,24 +95,19 @@ keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction ((liftIO .) . set'))
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions
, ( bShowAll
, \BrickSettings {..} ->
if showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler (not . showAllVersions) showAllTools
)
, ( bShowAllTools
, \BrickSettings {..} ->
if showAllTools then "Don't show all tools" else "Show all tools"
, hideShowHandler showAllVersions (not . showAllTools)
if showAll then "Hide old versions" else "Show all versions"
, hideShowHandler
)
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
]
where
hideShowHandler f p BrickState{..} =
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
hideShowHandler BrickState{..} =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
@@ -204,7 +194,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printTool GHC = str "GHC"
printTool GHCup = str "GHCup"
printTool HLS = str "HLS"
printTool Stack = str "Stack"
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
@@ -327,25 +316,21 @@ moveCursor steps ais@BrickInternalState{..} direction =
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (BrickState
-> (Int, ListResult)
-> ReaderT AppState IO (Either String a))
withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a))
-> BrickState
-> EventM n (Next BrickState)
withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as
Just (ix, e) -> do
suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action as (ix, e) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
Just (ix, e) -> suspendAndResume $ do
action as (ix, e) >>= \case
Left err -> putStrLn ("Error: " <> err)
Right _ -> putStrLn "Success"
getAppData Nothing (pfreq . appData $ as) >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
-- | Update app data and list internal state based on new evidence.
@@ -366,9 +351,7 @@ constructList :: BrickData
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
replaceLR (filterVisible (showAll appSettings)) (lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
@@ -401,32 +384,21 @@ replaceLR filterF lr s =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, not (elem (lTool e) hiddenTools) = True
| not v
, t
, not (elem Old (lTag e)) = True
| v
, t = True
| otherwise = not (elem Old (lTag e)) &&
not (elem (lTool e) hiddenTools)
filterVisible :: Bool -> ListResult -> Bool
filterVisible showAll e | lInstalled e = True
| showAll = True
| otherwise = not (elem Old (lTag e))
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -450,24 +422,21 @@ install' _ (_, ListResult {..}) = do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer $> vi
liftE $ installGHCBin dls lVer pfreq $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer $> vi
liftE $ installCabalBin dls lVer pfreq $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi
liftE $ upgradeGHCup dls Nothing False pfreq $> vi
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer $> vi
liftE $ installHLSBin dls lVer pfreq $> vi
)
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
runLogger $ $(logInfo) msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
@@ -491,7 +460,6 @@ set' _ (_, ListResult {..}) = do
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)
>>= \case
@@ -499,16 +467,13 @@ set' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left (prettyShow e)
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
@@ -516,7 +481,6 @@ del' _ (_, ListResult {..}) = do
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> vi
Stack -> liftE $ rmStackVer lVer $> vi
GHCup -> pure Nothing
)
>>= \case
@@ -527,12 +491,8 @@ del' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left (prettyShow e)
changelog' :: (MonadReader AppState m, MonadIO m)
=> BrickState
-> (Int, ListResult)
-> m (Either String ())
changelog' _ (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@@ -541,8 +501,7 @@ changelog' _ (_, ListResult {..}) = do
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e
@@ -561,8 +520,6 @@ settings' = unsafePerformIO $ do
})
dirs
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
@@ -578,9 +535,10 @@ logger' = unsafePerformIO
brickMain :: AppState
-> LoggerConfig
-> GHCupInfo
-> GHCupDownloads
-> PlatformRequest
-> IO ()
brickMain s l gi = do
brickMain s l av pfreq' = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
@@ -588,7 +546,7 @@ brickMain s l gi = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just gi)
eAppData <- getAppData (Just av) pfreq'
case eAppData of
Right ad ->
defaultMain
@@ -606,11 +564,11 @@ brickMain s l gi = do
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
defaultAppSettings = BrickSettings { showAll = False }
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
getDownloads' :: IO (Either String GHCupDownloads)
getDownloads' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
@@ -619,25 +577,29 @@ getGHCupInfo = do
runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ fmap _ghcupDownloads
$ liftE
$ getDownloadsF (GT.settings settings) (GT.dirs settings)
$ getDownloadsF (urlSource . GT.settings $ settings)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
getAppData :: Maybe GHCupInfo
getAppData :: Maybe GHCupDownloads
-> PlatformRequest
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
getAppData mg pfreq' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
r <- maybe getDownloads' (pure . Right) mg
runLogger . flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)
case r of
Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ BrickData (reverse lV) dls pfreq'
Left e -> pure $ Left [i|#{e}|]

View File

@@ -53,6 +53,8 @@ import Data.Versions hiding ( str )
import Data.Void
import GHC.IO.Encoding
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Language.Haskell.TH
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
@@ -62,7 +64,6 @@ import System.Console.Pretty hiding ( color )
import qualified System.Console.Pretty as Pretty
import System.Environment
import System.Exit
import System.FilePath
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -79,6 +80,8 @@ import qualified Text.Megaparsec.Char as MPC
data Options = Options
{
-- global options
@@ -103,7 +106,6 @@ data Command
| Upgrade UpgradeOpts Bool
| ToolRequirements
| ChangeLog ChangeLogOptions
| Nuke
#if defined(BRICK)
| Interactive
#endif
@@ -124,7 +126,6 @@ toSetToolVer Nothing = SetRecommended
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
@@ -136,7 +137,6 @@ data InstallOptions = InstallOptions
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
| SetStack SetOptions
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
@@ -157,7 +157,6 @@ data ListOptions = ListOptions
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
| RmStack Version
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
@@ -168,18 +167,17 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version FilePath
, bootstrapGhc :: Either Version (Path Abs)
, jobs :: Maybe Int
, buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt FilePath
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
deriving Show
@@ -220,7 +218,7 @@ invertableSwitch'
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
-> Parser (Maybe Bool)
invertableSwitch' longopt shortopt defv enmod dismod = optional
( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt)
( flag' True (enmod <> long longopt <> if defv then mempty else short shortopt)
<|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
)
where
@@ -293,7 +291,7 @@ com =
( Install
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal/HLS"
( progDesc "Install or update GHC/cabal"
<> footerDoc (Just $ text installToolFooter)
)
)
@@ -309,7 +307,7 @@ com =
"rm"
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal/HLS version"
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
@@ -369,14 +367,6 @@ com =
)
<> internal
)
<|> subparser
(command
"nuke"
(info (pure Nuke <**> helper)
(progDesc "Completely remove ghcup from your system"))
<> commandGroup "Nuclear Commands:"
)
where
installToolFooter :: String
installToolFooter = [s|Discussion:
@@ -402,6 +392,7 @@ com =
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
installCabalFooter :: String
installCabalFooter = [s|Discussion:
Installs the specified cabal-install version (or a recommended default one)
@@ -441,15 +432,6 @@ installParser =
<> footerDoc (Just $ text installHLSFooter)
)
)
<> command
"stack"
( InstallStack
<$> info
(installOpts (Just Stack) <**> helper)
( progDesc "Install stack"
<> footerDoc (Just $ text installStackFooter)
)
)
)
)
<|> (Right <$> installOpts Nothing)
@@ -460,17 +442,9 @@ installParser =
into "~/.ghcup/bin"
Examples:
# install recommended HLS
# install recommended GHC
ghcup install hls|]
installStackFooter :: String
installStackFooter = [s|Discussion:
Installs stack binaries into "~/.ghcup/bin"
Examples:
# install recommended Stack
ghcup install stack|]
installGHCFooter :: String
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
@@ -554,15 +528,6 @@ setParser =
<> footerDoc (Just $ text setHLSFooter)
)
)
<> command
"stack"
( SetStack
<$> info
(setOpts (Just Stack) <**> helper)
( progDesc "Set stack version"
<> footerDoc (Just $ text setStackFooter)
)
)
)
)
<|> (Right <$> setOpts Nothing)
@@ -577,10 +542,6 @@ setParser =
setCabalFooter = [s|Discussion:
Sets the the current Cabal version.|]
setStackFooter :: String
setStackFooter = [s|Discussion:
Sets the the current Stack version.|]
setHLSFooter :: String
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
@@ -633,12 +594,6 @@ rmParser =
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
<> command
"stack"
( RmStack
<$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
(progDesc "Remove stack version")
)
)
)
<|> (Right <$> rmOpts Nothing)
@@ -660,7 +615,6 @@ changelogP =
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
"stack" -> Right Stack
e -> Left e
)
)
@@ -727,7 +681,8 @@ ghcCompileOpts =
<*> option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
(bimap (const "Not a valid version") Left . version . T.pack $ x)
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
)
)
( short 'b'
@@ -745,14 +700,26 @@ ghcCompileOpts =
)
<*> optional
(option
str
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
<*> optional
(option
str
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applied in order, uses -p1)"
)
@@ -771,15 +738,6 @@ ghcCompileOpts =
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
)
)
toolVersionParser :: Parser ToolVersion
@@ -823,47 +781,53 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
runLogger = myLoggerT loggerConfig
dirs <- getDirs
let simpleSettings = Settings False False Never Curl False GHCupURL
simpleAppState = AppState simpleSettings dirs defaultKeyBindings
runEnv = runLogger . flip runReaderT simpleAppState
mGhcUpInfo <- runEnv . runE $ readFromCache
case mGhcUpInfo of
VRight ghcupInfo -> do
VRight dls -> do
let allTags = filter (\t -> t /= Old)
$ join
$ M.elems
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
$ availableToolVersions (_ghcupDownloads dls) tool
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
runLogger = myLoggerT loggerConfig
mpFreq <- runLogger . runE $ platformRequest
forFold mpFreq $ \pfreq ->
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
(Settings True False Never Curl False GHCupURL)
dirs'
defaultKeyBindings
ghcupInfo
pfreq
runEnv = runLogger . flip runReaderT appState
forFold mpFreq $ \pfreq -> do
dirs <- getDirs
let simpleSettings = Settings False False Never Curl False GHCupURL
simpleAppState = AppState simpleSettings dirs defaultKeyBindings
runEnv = runLogger . flip runReaderT simpleAppState
installedVersions <- runEnv $ listVersions (Just tool) criteria
mGhcUpInfo <- runEnv . runE $ readFromCache
forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do
installedVersions <- runEnv $ listVersions dls (Just tool) criteria pfreq
return $ T.unpack . prettyVer . lVer <$> installedVersions
@@ -984,8 +948,9 @@ bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings :: Options -> IO AppState
toSettings options = do
dirs <- getDirs
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
VRight r -> pure r
VLeft (V (JSONDecodeError e)) -> do
@@ -993,10 +958,10 @@ toSettings options = do
pure defaultUserSettings
_ -> do
die "Unexpected error!"
pure $ mergeConf options userConf
pure $ mergeConf options dirs userConf
where
mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} =
mergeConf :: Options -> Dirs -> UserSettings -> AppState
mergeConf Options{..} dirs UserSettings{..} =
let cache = fromMaybe (fromMaybe False uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
@@ -1004,7 +969,7 @@ toSettings options = do
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
in (Settings {..}, keyBindings)
in AppState (Settings {..}) dirs keyBindings
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
#else
@@ -1021,8 +986,7 @@ toSettings options = do
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
, bShowAll = fromMaybe bShowAll kShowAll
}
@@ -1035,7 +999,13 @@ upgradeOptsP =
)
<|> ( UpgradeAt
<$> option
str
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
@@ -1047,12 +1017,9 @@ upgradeOptsP =
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
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitSuccess -> pure . T.unpack . decUTF8Safe $ _stdOut
ExitFailure _ -> pure numericVer
)
)
@@ -1060,11 +1027,6 @@ describe_result = $( LitE . StringL <$>
main :: IO ()
main = do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
void enableAnsiSupport
let versionHelp = infoOption
( ("The GHCup Haskell installer, version " <>)
(head . lines $ describe_result)
@@ -1101,82 +1063,28 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
dirs <- getDirs
appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir
ensureDirectories dirs
(settings, keybindings) <- toSettings opt
createDirRecursive' baseDir
-- logger interpreter
logfile <- initGHCupFileLogging (logsDir dirs)
logfile <- flip runReaderT appstate $ initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> B.appendFile logfile
, rawOutter = appendFile logfile
}
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)
----------------------------------------
-- Getting download and platform info --
----------------------------------------
ghcupInfo <-
( runLogger
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF settings dirs
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let 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 ()
-- ensure global tools
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
-------------------------
-- Effect interpreters --
-------------------------
let runInstTool' appstate' mInstPlatform =
let runInstTool' appstate' =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform)
. flip runReaderT appstate'
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1279,22 +1187,57 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
(GHCupInfo treq dls) <-
( runLogger
. flip runReaderT appstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF (urlSource settings)
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
case optCommand of
Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
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
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
@@ -1310,8 +1253,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
Never -> runLogger ($(logError) $ T.pack $ prettyShow err)
_ -> runLogger ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
@@ -1324,15 +1267,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
pure vi
)
>>= \case
@@ -1353,15 +1297,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installHLS InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v)
Nothing -> runInstTool $ do
(v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
pure vi
)
>>= \case
@@ -1380,39 +1325,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v)
pure vi
Just uri -> runInstTool' appstate{ 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
runLogger $ $(logInfo) "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
v <- liftE $ fst <$> fromVersion' dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
@@ -1427,7 +1343,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setCabal' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
v <- liftE $ fst <$> fromVersion' dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
@@ -1443,7 +1359,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setHLS' SetOptions{..} =
runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
v <- liftE $ fst <$> fromVersion' dls sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
@@ -1457,22 +1373,6 @@ 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
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo)
[i|Stack #{prettyVer _tvVersion} successfully set as default version|]
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
runRm (do
liftE $
@@ -1518,25 +1418,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmStack' tv =
runRm (do
liftE $
rmStackVer tv
pure (getVersionInfo tv Stack dls)
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15
res <- case optCommand of
#if defined(BRICK)
Interactive -> do
liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess
Interactive -> liftIO $ brickMain appstate loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@@ -1544,7 +1429,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
@@ -1555,11 +1439,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
Set (Left (SetStack sopts)) -> setStack' sopts
List ListOptions {..} ->
runListGHC (do
l <- listVersions loTool lCriteria
l <- listVersions dls loTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
)
@@ -1570,7 +1453,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
Rm (Left (RmStack rmopts)) -> rmStack' rmopts
DInfo ->
do runDebugInfo $ liftE getDebugInfo
@@ -1593,14 +1475,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
targetVer <- liftE $ compileGHC
targetVer <- liftE $ compileGHC dls
(first (GHCTargetVersion crossTarget) targetGhc)
ovewrwiteVer
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
pfreq
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly
@@ -1619,8 +1501,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
Never -> runLogger $ $(logError) $ T.pack $ prettyShow err
_ -> runLogger ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 9
@@ -1630,11 +1512,14 @@ Make sure to clean up #{tmpdir} afterwards.|])
Upgrade uOpts force -> do
target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath
UpgradeInplace -> do
efp <- liftIO getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
runUpgrade (liftE $ upgradeGHCup target force) >>= \case
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
@@ -1651,13 +1536,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 11
ToolRequirements ->
flip runReaderT appstate
$ runLogger
runLogger
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
platform <- liftE getPlatform
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
req <- getCommonRequirements platform treq ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
@@ -1689,13 +1573,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
if clOpen
then
flip runReaderT appstate $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
True
[serializeURIRef' uri]
Nothing
Nothing
>>= \case
@@ -1704,78 +1587,42 @@ Make sure to clean up #{tmpdir} afterwards.|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
Nuke ->
runRm (do
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
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
forM_ lInstalled (liftE . rmTool)
lift rmGhcupDirs
) >>= \case
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
| otherwise -> do
runLogger $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15
case res of
ExitSuccess -> pure ()
ef@(ExitFailure _) -> exitWith ef
pure ()
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> Maybe ToolVersion
=> GHCupDownloads
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion av tv = fromVersion' av (toSetToolVer tv)
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> SetToolVersion
=> GHCupDownloads
-> SetToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
fromVersion' av SetRecommended tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool
?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
let vi = getVersionInfo (_tvVersion v) tool dls
fromVersion' av (SetToolVersion v) tool = do
let vi = getVersionInfo (_tvVersion v) tool av
case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi)
Right (PVP (major' :|[minor'])) ->
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of
Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi)
Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
(\(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
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
fromVersion' av (SetToolTag Latest) tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest av tool ?? TagNotFound Latest tool
fromVersion' av (SetToolTag Recommended) tool =
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool ?? TagNotFound Recommended tool
fromVersion' av (SetToolTag (Base pvp'')) GHC =
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' av SetNext tool = do
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
@@ -1807,25 +1654,18 @@ fromVersion' SetNext tool = do
. cycle
. sort
$ hlses) ?? NoToolVersionSet tool
Stack -> do
set <- stackSet !? NoToolVersionSet tool
stacks <- rights <$> lift getInstalledStacks
(fmap (GHCTargetVersion Nothing)
. headMay
. tail
. dropWhile (/= set)
. cycle
. sort
$ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls
let vi = getVersionInfo (_tvVersion next) tool av
pure (next, vi)
fromVersion' (SetToolTag t') tool =
fromVersion' _ (SetToolTag t') tool =
throwE $ TagNotFound t' tool
printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
no_color <- isJust <$> lookupEnv "NO_COLOR"
let
@@ -1849,15 +1689,9 @@ printListResult raw lr = do
. fmap
(\ListResult {..} ->
let marks = if
#if defined(IS_WINDOWS)
| lSet -> (color Green "IS")
| lInstalled -> (color Green "I ")
| otherwise -> (color Red "X ")
#else
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
#endif
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
@@ -1984,10 +1818,11 @@ checkForUpdates :: ( MonadReader AppState m
, MonadFail m
, MonadLogger m
)
=> m ()
checkForUpdates = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
lInstalled <- listVersions Nothing (Just ListInstalled)
=> GHCupDownloads
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
lInstalled <- listVersions dls Nothing (Just ListInstalled) pfreq
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
forM_ (getLatest dls GHCup) $ \(l, _) -> do
@@ -2017,21 +1852,14 @@ checkForUpdates = do
$ $(logWarn)
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
$ $(logWarn)
[i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info
==========
GHCup base dir: #{diBaseDir}
GHCup bin dir: #{diBinDir}
GHCup GHC directory: #{diGHCDir}
GHCup cache directory: #{diCacheDir}
GHCup base dir: #{toFilePath diBaseDir}
GHCup bin dir: #{toFilePath diBinDir}
GHCup GHC directory: #{toFilePath diGHCDir}
GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyShow diArch}
Platform: #{prettyShow diPlatform}
Version: #{describe_result}|]

View File

@@ -14,52 +14,26 @@
# safety subshell to avoid executing anything in case this script is not downloaded properly
(
plat="$(uname -s)"
arch=$(uname -m)
ghver="0.1.15.2"
base_url="https://downloads.haskell.org/~ghcup"
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
case "${plat}" in
MSYS*|MINGW*)
: "${GHCUP_INSTALL_BASE_PREFIX:=/c}"
GHCUP_DIR=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup")
GHCUP_BIN=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin")
: "${GHCUP_MSYS2:=${GHCUP_DIR}/msys64}"
;;
*)
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
export GHCUP_USE_XDG_DIRS
export GHCUP_USE_XDG_DIRS
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
;;
esac
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
die() {
(>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
exit 2
}
warn() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;35m$1\\033[0m"
;;
*)
printf "\\033[0;35m%s\\033[0m\\n" "$1"
;;
esac
}
edo() {
"$@" || die "\"$*\" failed!"
}
@@ -69,137 +43,92 @@ eghcup() {
}
_eghcup() {
if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then
args="-s ${BOOTSTRAP_HASKELL_YAML}"
fi
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
"${GHCUP_BIN}/ghcup" ${args} "$@"
ghcup "$@"
else
"${GHCUP_BIN}/ghcup" ${args} --verbose "$@"
ghcup --verbose "$@"
fi
}
_done() {
case "${plat}" in
MSYS*|MINGW*)
echo
echo "All done!"
echo
echo "In a new powershell or cmd.exe session, now you can..."
echo
echo "Start a simple repl via:"
echo " ghci"
echo
echo "Start a new haskell project in the current directory via:"
echo " cabal init --interactive"
echo
echo "Install other GHC versions and tools via:"
echo " ghcup list"
echo " ghcup install <tool> <version>"
echo
echo "To install system libraries and update msys2/mingw64,"
echo "open the \"Mingw haskell shell\""
echo "and the \"Mingw package management docs\""
echo "desktop shortcuts."
;;
*)
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions and tools, run:"
echo " ghcup tui"
;;
esac
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions, run:"
echo " ghcup tui"
exit 0
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.14.1"
_base_url="https://downloads.haskell.org/~ghcup"
case "${plat}" in
case "${_plat}" in
"linux"|"Linux")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
# we could be in a 32bit docker container, in which
# case uname doesn't give us what we want
if [ "$(getconf LONG_BIT)" = "32" ] ; then
_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${base_url}/${ghver}/x86_64-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
;;
i*86)
_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
;;
armv7*)
_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/armv7-linux-ghcup-${_ghver}
;;
aarch64|arm64|armv8l)
_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
_url=${_base_url}/${_ghver}/aarch64-linux-ghcup-${_ghver}
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
;;
"FreeBSD"|"freebsd")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
;;
i*86)
die "i386 currently not supported!"
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=${base_url}/${ghver}/x86_64-portbld-freebsd-ghcup-${ghver}
_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
;;
"Darwin"|"darwin")
case "${arch}" in
case "${_arch}" in
x86_64|amd64)
_url=${base_url}/${ghver}/x86_64-apple-darwin-ghcup-${ghver}
;;
aarch64|arm64|armv8l)
_url=${base_url}/${ghver}/aarch64-apple-darwin-ghcup-${ghver}
;;
i*86)
die "i386 currently not supported!"
;;
*) die "Unknown architecture: ${arch}"
*) die "Unknown architecture: ${_arch}"
;;
esac
;;
MSYS*|MINGW*)
case "${arch}" in
x86_64|amd64)
_url=${base_url}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe
;;
*) die "Unknown architecture: ${arch}"
;;
esac
;;
*) die "Unknown platform: ${plat}"
_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
*) die "Unknown platform: ${_plat}"
;;
esac
case "${plat}" in
MSYS*|MINGW*)
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup.exe
edo chmod +x "${GHCUP_BIN}"/ghcup.exe
;;
*)
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo chmod +x "${GHCUP_BIN}"/ghcup
;;
esac
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo chmod +x "${GHCUP_BIN}"/ghcup
edo mkdir -p "${GHCUP_DIR}"
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
@@ -208,90 +137,8 @@ download_ghcup() {
# shellcheck disable=SC1090
edo . "${GHCUP_DIR}"/env
eghcup upgrade
}
adjust_bashrc() {
case $SHELL in
*/zsh) # login shell is zsh
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh" ;;
*/bash) # login shell is bash
GHCUP_PROFILE_FILE="$HOME/.bashrc"
MY_SHELL="bash" ;;
*/sh) # login shell is sh, but might be a symlink to bash or zsh
if [ -n "${BASH}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.bashrc"
MY_SHELL="bash"
elif [ -n "${ZSH_VERSION}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh"
else
return
fi
;;
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) return ;;
esac
warn ""
warn "Detected ${MY_SHELL} shell on your system..."
warn "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"Y\")."
warn ""
while true; do
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r next_answer </dev/tty
else
next_answer="yes"
fi
case $next_answer in
[Nn]*)
return ;;
[Yy]* | "")
case $MY_SHELL in
"") break ;;
fish)
mkdir -p "${GHCUP_PROFILE_FILE%/*}"
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
break ;;
bash)
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
case "${plat}" in
"Darwin"|"darwin")
if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi
;;
esac
break ;;
zsh)
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
break ;;
esac
warn "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
warn "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
return
;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, update my \"${GHCUP_PROFILE_FILE}\" (default)"
echo "N - No, don't mess with my configuration"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
unset _plat _arch _url _ghver _base_url
}
@@ -300,22 +147,14 @@ echo "Welcome to Haskell!"
echo
echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer"
echo " (for managing GHC/cabal versions)"
echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool for managing Haskell software"
echo " * stack - (optional) A cross-platform program for developing Haskell projects"
echo " * hls - (optional) A language server for developers to integrate with their editor/IDE"
echo " * cabal - The Cabal build tool"
echo
if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo "ghcup installs only into the following directory,"
echo "which can be removed anytime:"
case "${plat}" in
MSYS*|MINGW*)
echo " $(cygpath -w "$GHCUP_DIR")"
;;
*)
echo " $GHCUP_DIR"
;;
esac
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
else
echo "ghcup installs into XDG directories as long as"
echo "'GHCUP_USE_XDG_DIRS' is set."
@@ -323,8 +162,8 @@ fi
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Press ENTER to proceed or ctrl-c to abort."
warn "Note that this script can be re-run at any given time."
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed or ctrl-c to abort."
printf "\\033[0;35m%s\\033[0m\\n" "Note that this script can be re-run at any given time."
echo
# Wait for user input to continue.
# shellcheck disable=SC2034
@@ -342,12 +181,12 @@ else
fi
echo
echo "$(if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then ghcup -s "${BOOTSTRAP_HASKELL_YAML}" tool-requirements ; else ghcup tool-requirements ; fi)"
echo "$(ghcup tool-requirements)"
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Press ENTER to proceed or ctrl-c to abort."
warn "Installation may take a while."
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed or ctrl-c to abort."
printf "\\033[0;35m%s\\033[0m\\n" "Installation may take a while."
echo
# Wait for user input to continue.
@@ -360,124 +199,116 @@ eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
adjust_cabal_config() {
edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$HOME"/AppData/Roaming/cabal/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
}
case "${plat}" in
MSYS*|MINGW*)
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Create an initial cabal.config including relevant msys2 paths (recommended)?"
warn "[Y] Yes [N] No [?] Help (default is \"Y\")."
echo
while true; do
read -r mingw_answer </dev/tty
case $mingw_answer in
[Yy]* | "")
adjust_cabal_config
break ;;
[Nn]*)
echo "Make sure that your global cabal.config references the correct mingw64 paths (extra-prog-path, extra-include-dirs and extra-lib-dirs)."
echo "And set the environment variable GHCUP_MSYS2 to the root path of your msys2 installation."
sleep 5
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, create a cabal.config with pre-set paths to msys2/mingw64 (default)"
echo "N - No, leave the current/default cabal config untouched"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
else
adjust_cabal_config
fi
;;
esac
edo cabal new-update
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Installation done!"
printf "\\033[0;35m%s\\033[0m\\n" ""
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
warn "Do you want to install haskell-language-server (HLS) now?"
warn "HLS is a language-server that provides IDE-like functionality"
warn "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
warn "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"N\")."
warn ""
printf "\\033[0;35m%s\\033[0m\\n" "Do you want to install haskell-language-server (HLS) now?"
printf "\\033[0;35m%s\\033[0m\\n" "HLS is a language-server that provides IDE-like functionality"
printf "\\033[0;35m%s\\033[0m\\n" "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
printf "\\033[0;35m%s\\033[0m\\n" "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Answer with YES or NO and press ENTER."
printf "\\033[0;35m%s\\033[0m\\n" ""
while true; do
read -r hls_answer </dev/tty
case $hls_answer in
[Yy]*)
eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
eghcup --cache install hls
break ;;
[Nn]* | "")
[Nn]*)
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, install the haskell-langauge-server"
echo "N - No, don't install anything more (default)"
echo
echo "Please make your choice and press ENTER."
;;
echo "Please type YES or NO and press enter.";;
esac
done
warn "Do you want to install stack now?"
warn "Stack is a haskell build tool similar to cabal that is used by some projects."
warn "Also see https://docs.haskellstack.org/"
warn ""
warn "[Y] Yes [N] No [?] Help (default is \"N\")."
warn ""
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_DIR/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
while true; do
read -r stack_answer </dev/tty
case $stack_answer in
[Yy]*)
eghcup --cache install stack || warn "Stack installation failed, continuing anyway"
break ;;
[Nn]* | "")
break ;;
*)
echo "Possible choices are:"
echo
echo "Y - Yes, install stack"
echo "N - No, don't install anything more (default)"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
fi
# short-circuit script based on platform
case "${plat}" in
MSYS*|MINGW*)
# For windows we always adjust bashrc, since it's inside msys2
adjust_bashrc
;;
*)
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_DIR/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
adjust_bashrc
case $SHELL in
*/zsh) # login shell is zsh
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh" ;;
*/bash) # login shell is bash
GHCUP_PROFILE_FILE="$HOME/.bashrc"
MY_SHELL="bash" ;;
*/sh) # login shell is sh, but might be a symlink to bash or zsh
if [ -n "${BASH}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.bashrc"
MY_SHELL="bash"
elif [ -n "${ZSH_VERSION}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh"
else
_done
fi
;;
esac
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) _done ;;
esac
_done
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Detected ${MY_SHELL} shell on your system..."
printf "\\033[0;35m%s\\033[0m\\n" "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
printf "\\033[0;35m%s\\033[0m\\n" "answer with YES, otherwise with NO and press ENTER."
printf "\\033[0;35m%s\\033[0m\\n" ""
while true; do
read -r next_answer </dev/tty
case $next_answer in
[Yy]*)
case $MY_SHELL in
"") break ;;
fish)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
mkdir -p "${GHCUP_PROFILE_FILE%/*}"
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
bash)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
case "$(uname -s)" in
"Darwin"|"darwin")
if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi
;;
esac
break ;;
zsh)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
esac
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
_done
;;
[Nn]*)
_done ;;
*)
echo "Please type YES or NO and press enter.";;
esac
done
fi
)
# vim: tabstop=4 shiftwidth=4 expandtab

View File

@@ -1,422 +0,0 @@
<#
.SYNOPSIS
Script to bootstrap a Haskell environment
.DESCRIPTION
This is the windows GHCup installer, installing:
* ghcup - The Haskell toolchain installer"
* ghc - The Glasgow Haskell Compiler"
* msys2 - Unix-style toolchain needed for dependencies and tools
* cabal - The Cabal build tool for managing Haskell software"
* stack - (optional) A cross-platform program for developing Haskell projects"
* hls - (optional) A language server for developers to integrate with their editor/IDE"
#>
param (
# Run an interactive installation
[switch]$Interactive,
# Specify the install root (default: 'C:\')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir,
# Overwrite (or rather backup) a previous install
[switch]$Overwrite,
# Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
[string]$BootstrapUrl,
# Run the final bootstrap script via 'bash' instead of a full newly spawned msys2 shell
[switch]$InBash
)
$Silent = !$Interactive
function Print-Msg {
param ( [Parameter(Mandatory=$true, HelpMessage='String to output')][string]$msg, [string]$color = "Green" )
Write-Host ('{0}' -f $msg) -ForegroundColor $color
}
function Create-Shortcut {
param ( [Parameter(Mandatory=$true,HelpMessage='Target path')][string]$SourceExe, [Parameter(Mandatory=$true,HelpMessage='Arguments to the path/exe')][AllowEmptyString()]$ArgumentsToSourceExe, [Parameter(Mandatory=$true,HelpMessage='The destination of the desktop link')][string]$DestinationPath )
$WshShell = New-Object -comObject WScript.Shell
$Shortcut = $WshShell.CreateShortcut($DestinationPath)
$Shortcut.TargetPath = $SourceExe
if($ArgumentsToSourceExe) {
$Shortcut.Arguments = $ArgumentsToSourceExe
}
$Shortcut.Save()
}
function Add-EnvPath {
param(
[Parameter(Mandatory=$true,HelpMessage='The Path to add to Users environment')]
[string] $Path,
[ValidateSet('Machine', 'User', 'Session')]
[string] $Container = 'Session'
)
if ($Container -eq 'Session') {
$envPaths = [Collections.Generic.List[String]]($env:Path -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$env:PATH = $envPaths -join ([IO.Path]::PathSeparator)
}
}
else {
[Microsoft.Win32.RegistryHive]$hive, $keyPath = switch ($Container) {
'Machine' { 'LocalMachine', 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment' }
'User' { 'CurrentUser', 'Environment' }
}
$hiveKey = $envKey = $null
try {
$hiveKey = [Microsoft.Win32.RegistryKey]::OpenRemoteBaseKey($hive, '')
$envKey = $hiveKey.OpenSubKey($keyPath, $true)
$rawPath = $envKey.GetValue('PATH', '', 'DoNotExpandEnvironmentNames')
$envPaths = [Collections.Generic.List[String]]($rawPath -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$envKey.SetValue('PATH', ($envPaths -join ([IO.Path]::PathSeparator)), 'ExpandString')
}
}
finally {
if ($envKey) { $envKey.Close() }
if ($hiveKey) { $hiveKey.Close() }
}
}
}
filter Get-FileSize {
'{0:N2} {1}' -f $(
if ($_ -lt 1kb) { $_, 'Bytes' }
elseif ($_ -lt 1mb) { ($_/1kb), 'KB' }
elseif ($_ -lt 1gb) { ($_/1mb), 'MB' }
elseif ($_ -lt 1tb) { ($_/1gb), 'GB' }
elseif ($_ -lt 1pb) { ($_/1tb), 'TB' }
else { ($_/1pb), 'PB' }
)
}
function Get-FileWCSynchronous{
param(
[Parameter(Mandatory=$true)]
[string]$url,
[string]$destinationFolder="$env:USERPROFILE\Downloads",
[switch]$includeStats
)
$wc = New-Object -TypeName Net.WebClient
$wc.UseDefaultCredentials = $true
$destination = Join-Path -Path $destinationFolder -ChildPath ($url | Split-Path -Leaf)
$start = Get-Date
$wc.DownloadFile($url, $destination)
$elapsed = ((Get-Date) - $start).ToString('hh\:mm\:ss')
$totalSize = (Get-Item -Path $destination).Length | Get-FileSize
if ($includeStats.IsPresent){
[PSCustomObject]@{Name=$MyInvocation.MyCommand;TotalSize=$totalSize;Time=$elapsed}
}
Get-Item -Path $destination | Unblock-File
}
function Test-AbsolutePath {
Param (
[Parameter(Mandatory=$True)]
[ValidateScript({[System.IO.Path]::IsPathRooted($_)})]
[String]$Path
)
}
function Exec
{
[CmdletBinding()]
param(
[Parameter(Position = 0, Mandatory = 1)][string]$cmd,
[Parameter()][string]$errorMessage,
[parameter(ValueFromRemainingArguments = $true)]
[string[]]$Passthrough
)
& $cmd @Passthrough
if ($lastexitcode -ne 0) {
if (!($errorMessage)) {
throw ('Exec: Error executing command {0} with arguments ''{1}''' -f $cmd, "$Passthrough")
} else {
throw ('Exec: ' + $errorMessage)
}
}
}
$ErrorActionPreference = 'Stop'
$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
if ($GhcupBasePrefixEnv) {
$defaultGhcupBasePrefix = $GhcupBasePrefixEnv
} else {
$partitions = Get-CimInstance win32_logicaldisk
$defaultGhcupBasePrefix = $null
foreach ($p in $partitions){
try {
if ($p."FreeSpace" -lt 5368709120) { # at least 5 GB are needed
throw ("Not enough free space on {0}" -f $p."DeviceId")
}
$null = New-Item -Path ('{0}\' -f $p."DeviceId") -Name "ghcup.test" -ItemType "directory" -Force
$defaultGhcupBasePrefix = ('{0}\' -f $p."DeviceId")
Remove-Item -LiteralPath ('{0}\ghcup.test' -f $p."DeviceId")
break
} catch {
Print-Msg -color Yellow -msg ("{0} not writable or not enough disk space, trying next device" -f $p."DeviceId")
}
}
if ($defaultGhcupBasePrefix) {
Print-Msg -color Green -msg ("Picked {0} as default Install prefix!" -f $defaultGhcupBasePrefix)
} else {
Print-Msg -color Red -msg "Couldn't find a writable partition with at least 5GB free disk space!"
Exit 1
}
}
if ($Silent -and !($InstallDir)) {
$GhcupBasePrefix = $defaultGhcupBasePrefix
} elseif ($InstallDir) {
if (!(Test-Path -LiteralPath ('{0}' -f $InstallDir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory!"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$InstallDir")) {
Print-Msg -color Red -msg "Non-absolute Path specified!"
Exit 1
} else {
$GhcupBasePrefix = $InstallDir
}
} else {
while ($true) {
Print-Msg -color Magenta -msg ('Where to install to (this should be a short Path, preferably a Drive like ''C:\''){1}Press enter to accept the default [{0}]:' -f $defaultGhcupBasePrefix, "`n")
$basePrefixPrompt = Read-Host
$GhcupBasePrefix = ($defaultGhcupBasePrefix,$basePrefixPrompt)[[bool]$basePrefixPrompt]
if (!($GhcupBasePrefix.EndsWith('\'))) {
$GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix)
}
if (!($GhcupBasePrefix)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) {
Print-Msg -color Red -msg "Directory does not exist, need to specify an existing Drive/Directory"
} elseif (!(Split-Path -IsAbsolute -Path "$GhcupBasePrefix")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
}
Print-Msg -msg ('Setting env variable GHCUP_INSTALL_BASE_PREFIX to ''{0}''' -f $GhcupBasePrefix)
$null = [Environment]::SetEnvironmentVariable("GHCUP_INSTALL_BASE_PREFIX", $GhcupBasePrefix, [System.EnvironmentVariableTarget]::User)
$GhcupDir = ('{0}\ghcup' -f $GhcupBasePrefix)
$MsysDir = ('{0}\msys64' -f $GhcupDir)
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
if (!($BootstrapUrl)) {
$BootstrapUrl = 'https://www.haskell.org/ghcup/sh/bootstrap-haskell'
}
$GhcupMsys2 = [System.Environment]::GetEnvironmentVariable('GHCUP_MSYS2', 'user')
Print-Msg -msg 'Preparing for GHCup installation...'
if (Test-Path -LiteralPath ('{0}' -f $GhcupDir)) {
Print-Msg -msg ('GHCup already installed at ''{0}''...' -f $GhcupDir)
if ($Overwrite) {
$decision = 0
} elseif (!($Silent)) {
$decision = $Host.UI.PromptForChoice('Install GHCup'
, 'GHCup is already installed, what do you want to do?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Reinstall'
'&Continue'
'&Abort'), 1)
} else {
$decision = 1
}
if ($decision -eq 0) {
$suffix = [IO.Path]::GetRandomFileName()
Print-Msg -msg ('Backing up {0} to {0}-{1} ...' -f $GhcupDir, $suffix)
Rename-Item -Path ('{0}' -f $GhcupDir) -NewName ('{0}-{1}' -f $GhcupDir, $suffix)
} elseif ($decision -eq 1) {
Print-Msg -msg 'Continuing installation...'
} elseif ($decision -eq 2) {
Exit 0
}
}
$null = New-Item -Path ('{0}' -f $GhcupDir) -ItemType 'directory' -ErrorAction SilentlyContinue
$null = New-Item -Path ('{0}' -f $GhcupDir) -Name 'bin' -ItemType 'directory' -ErrorAction SilentlyContinue
Print-Msg -msg 'First checking for Msys2...'
if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
if ($Silent) {
$msys2Decision = 0
} else {
$msys2Decision = $Host.UI.PromptForChoice('Install MSys2'
, 'Do you want GHCup to install a default MSys2 toolchain (recommended)?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'), 0)
}
if ($msys2Decision -eq 0) {
Print-Msg -msg ('...Msys2 doesn''t exist, installing into {0} ...this may take a while' -f $MsysDir)
# Download the archive
Print-Msg -msg 'Downloading Msys2 archive...'
$archive = 'msys2-x86_64-latest.sfx.exe'
if (Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) {
Exec "curl.exe" '-o' ('{0}\{1}' -f $env:TEMP, $archive) ('https://repo.msys2.org/distrib/{0}' -f $archive)
} else {
Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder "$env:TEMP" -includeStats
}
Print-Msg -msg 'Extracting Msys2 archive...'
$null = & "$env:TEMP\$archive" '-y' ('-o{0}' -f $GhcupDir) # Extract
Remove-Item -Path ('{0}/{1}' -f $env:TEMP, $archive)
Print-Msg -msg 'Processing MSYS2 bash for first time use...'
Exec "$Bash" '-lc' 'exit'
Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`"
Print-Msg -msg 'Upgrading full system...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
Print-Msg -msg 'Upgrading full system twice...'
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
Print-Msg -msg 'Installing Dependencies...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S --needed curl mingw-w64-x86_64-pkgconf'
Print-Msg -msg 'Updating SSL root certificate authorities...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S ca-certificates'
Print-Msg -msg 'Setting default home directory...'
Exec "$Bash" '-lc' "sed -i -e 's/db_home:.*$/db_home: windows/' /etc/nsswitch.conf"
} elseif ($msys2Decision -eq 1) {
Print-Msg -color Yellow -msg 'Skipping MSys2 installation.'
while ($true) {
if ($GhcupMsys2) {
$defaultMsys2Dir = $GhcupMsys2
Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory. Press enter to accept the default [{0}]:' -f $defaultMsys2Dir)
$MsysDirPrompt = Read-Host
$MsysDir = ($defaultMsys2Dir,$MsysDirPrompt)[[bool]$MsysDirPrompt]
} else {
Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:'
$MsysDir = Read-Host
}
if (!($MsysDir)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) {
Print-Msg -color Red -msg ('MSys2 installation at ''{0}'' could not be found!' -f $MsysDir)
} elseif (!(Split-Path -IsAbsolute -Path "$MsysDir")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
Print-Msg -msg ('Setting GHCUP_MSYS2 env var to ''{0}''' -f $MsysDir)
$null = [Environment]::SetEnvironmentVariable("GHCUP_MSYS2", $MsysDir, [System.EnvironmentVariableTarget]::User)
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
}
} else {
Print-Msg -msg ('...Msys2 found in {0} ...skipping Msys2 installation.' -f $MsysDir)
}
Print-Msg -msg 'Creating shortcuts...'
$DesktopDir = [Environment]::GetFolderPath("Desktop")
$GhcInstArgs = '-mingw64 -mintty -c "pacman --noconfirm -S --needed base-devel gettext autoconf make libtool automake python p7zip patch unzip"'
Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe $GhcInstArgs -DestinationPath ('{0}\Install GHC dev dependencies.lnk' -f $DesktopDir)
Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath ('{0}\Mingw haskell shell.lnk' -f $DesktopDir)
Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath ('{0}\Mingw package management docs.url' -f $DesktopDir)
Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir)
Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User'
if ($CabalDir) {
$CabDirEnv = $CabalDir
if (!($CabDirEnv)) {
Print-Msg -color Red -msg "No directory specified!"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
Exit 1
}
} elseif (!($Silent)) {
while ($true) {
$defaultCabalDir = ('{0}\cabal' -f $GhcupBasePrefix)
Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up). Press enter to accept the default [{0}]:' -f $defaultCabalDir)
$CabalDirPrompt = Read-Host
$CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
if (!($CabDirEnv)) {
Print-Msg -color Red -msg "No directory specified!"
} elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
} else {
Break
}
}
} else {
$CabDirEnv = ('{0}\cabal' -f $GhcupBasePrefix)
}
$CabalDirFull = [System.IO.Path]::GetFullPath("$CabDirEnv")
Print-Msg -msg ('Setting CABAL_DIR to ''{0}''' -f $CabalDirFull)
$null = [Environment]::SetEnvironmentVariable("CABAL_DIR", $CabalDirFull, [System.EnvironmentVariableTarget]::User)
Print-Msg -msg 'Starting GHCup installer...'
$Msys2Shell = ('{0}\msys2_shell.cmd' -f $MsysDir)
if ($Silent) {
$SilentExport = 'export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 ;'
} else {
$SilentExport = ''
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull)
}
# SIG # Begin signature block
# MIID4QYJKoZIhvcNAQcCoIID0jCCA84CAQExCzAJBgUrDgMCGgUAMGkGCisGAQQB
# gjcCAQSgWzBZMDQGCisGAQQBgjcCAR4wJgIDAQAABBAfzDtgWUsITrck0sYpfvNR
# AgEAAgEAAgEAAgEAAgEAMCEwCQYFKw4DAhoFAAQUVqKek181kF/Jx/P7z176herc
# ZyCgggH/MIIB+zCCAWSgAwIBAgIQGOezhGS1A5tHh9VubW0liDANBgkqhkiG9w0B
# AQUFADAYMRYwFAYDVQQDDA1KdWxpYW4gT3NwYWxkMB4XDTIxMDUzMDE4Mzk1OVoX
# DTI1MDUzMDAwMDAwMFowGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZDCBnzANBgkq
# hkiG9w0BAQEFAAOBjQAwgYkCgYEAs76XCXYPM14buR1RkVKhOB8pyM4Df6kPaz75
# nkbA0nq1VmMhBfCYFWyYHd7jniqTH0LoAKGGquN1bniREaCP9j2pFWpMIgLpQH3H
# +jpsfmxV2BTG8q+Jok88gTXS1FlAk72E85zO/Jhr6Fja1aFYAdibBRsRxcVMTVh7
# 4AGLNGUCAwEAAaNGMEQwEwYDVR0lBAwwCgYIKwYBBQUHAwMwHQYDVR0OBBYEFC+R
# hdhPo0Ty5HnzHyo1pN35IfZQMA4GA1UdDwEB/wQEAwIHgDANBgkqhkiG9w0BAQUF
# AAOBgQAl3IdBVIwbJJDp7BksMYPeM4ivB3UyNvlw8aVxGwAzNgdSaezYIdMFtKXV
# CSv5bd4VnFRAPDJW9dhW0h3SkeJUoklUxMjKXhR3qygQhSxPDjIatAuOCffGACba
# ZZ7Om40b+pKXc6i/HnlApk9DGbXJ59bFcLGGcZ9QjoUae6Ex1DGCAUwwggFIAgEB
# MCwwGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZAIQGOezhGS1A5tHh9VubW0liDAJ
# BgUrDgMCGgUAoHgwGAYKKwYBBAGCNwIBDDEKMAigAoAAoQKAADAZBgkqhkiG9w0B
# CQMxDAYKKwYBBAGCNwIBBDAcBgorBgEEAYI3AgELMQ4wDAYKKwYBBAGCNwIBFTAj
# BgkqhkiG9w0BCQQxFgQUosm9nN1JgajqSBa1cUwxxhLrAsYwDQYJKoZIhvcNAQEB
# BQAEgYCnKzfsH1aDjS6xkC/uymjaBowHSnh6nFu2AkjcKu8RgcBZzP5SLBXgU9wm
# aED5Ujwyq3Qre+TGVRUqwkEauDhQiX2A008G00fRO6+di6yJRCRn5eaRAbdU3Xww
# E5VhEwLBnwzWrvLKtdEclhgUCo5Tq87QMXVdgX4aRmunl4ZE+Q==
# SIG # End signature block

View File

@@ -1,26 +1,18 @@
packages: ./ghcup.cabal
optional-packages: ./vendored/*/*.cabal
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell, language-c
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1,2 +0,0 @@
-- windows picks weird version
constraints: any.hsc2hs ==0.68.7

View File

@@ -29,8 +29,6 @@ key-bindings:
KChar: 'c'
show-all:
KChar: 'a'
show-all-tools:
KChar: 't'
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code.

View File

@@ -1286,7 +1286,6 @@ ghcupDownloads:
dlHash: bb9c97826b1f4d7a8ef8bce0616b612f1ded10480ef10fcf7fb4e6d10a6681c8
8.10.3:
viTags:
- old
- base-4.14.1.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.3/docs/html/users_guide/8.10.3-notes.html
viSourceDL:
@@ -1376,6 +1375,7 @@ ghcupDownloads:
dlHash: b823b58cae36fbac0741680ca7605180fa4cf4c6ae439123d282184b94d32fd6
8.10.4:
viTags:
- Recommended
- base-4.14.1.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.4/docs/html/users_guide/8.10.4-notes.html
viSourceDL:
@@ -1383,7 +1383,7 @@ ghcupDownloads:
dlSubdir: ghc-8.10.4
dlHash: 52af871b4e08550257d720c2944ac85727d0b948407cef1bebfe7508c224910e
viPostRemove: *ghc-post-remove
viPreCompile: &ghc-pre-compile "If you have autoconf >= 2.70 you'll need this patch https://gitlab.haskell.org/ghc/ghc/-/snippets/2040 (see the --patchdir option)"
viPreCompile: "If you have autoconf >= 2.70 you'll need this patch https://gitlab.haskell.org/ghc/ghc/-/snippets/2040 (see the --patchdir option)"
viArch:
A_64:
Linux_Debian:
@@ -1464,97 +1464,6 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.4
dlHash: 0d18ef83593272f6196a41cc3abdc48dfe5e14372db75d71ea19fe35320c4e81
8.10.5:
viTags:
- Recommended
- base-4.14.2.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.5/docs/html/users_guide/8.10.5-notes.html
viSourceDL:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-src.tar.xz
dlSubdir: ghc-8.10.5
dlHash: f10941f16e4fbd98580ab5241b9271bb0851304560c4d5ca127e3b0e20e3076f
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viArch:
A_64:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8105-64-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-deb9-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 15e71325c3bdfe3804be0f84c2fc5c913d811322d19b0f4d4cff20f29cdd804d
'( >= 10 && < 11 )': &ghc-8105-64-deb10
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: bc623c20ca4c5c18e952071ba14aa0cfc5c94d34219bffaa615f7b491f376787
unknown_versioning: *ghc-8105-64-deb9
Linux_Ubuntu:
unknown_versioning: &ghc-8105-64-fedora
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-fedora27-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 73528ebfb219b50aa9042ee51a0a2bd764828d605f058404989d0b645752d210
'( >= 16 && < 19 )': *ghc-8105-64-deb9
Linux_Mint:
unknown_versioning: *ghc-8105-64-deb10
Linux_Fedora:
'( >= 27 && < 28 )': *ghc-8105-64-fedora
unknown_versioning: *ghc-8105-64-fedora
Linux_CentOS:
'( >= 7 && < 8 )': &ghc-8105-64-centos
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-centos7-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 4cdb259ec74d1408dab45dab20dcedc21690f39921c2ea4546486fb3e81f4fbd
unknown_versioning: *ghc-8105-64-centos
Linux_RedHat:
unknown_versioning: *ghc-8105-64-centos
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.5-x86_64-unknown-linux
dlHash: f4d7cd9ed12a4b8592219c9a63a86db1a256a09fa9e6ed755a60afc57dc782e2
Linux_AmazonLinux:
unknown_versioning: *ghc-8105-64-centos
Linux_UnknownLinux:
unknown_versioning: *ghc-8105-64-fedora
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.5
dlHash: ef0f47eff8962d58fa447123636cf8ef31c1e5b2d0ae90177d3388861ddf4a22
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/8.10.5/ghc-8.10.5-x86_64-portbld-freebsd.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 11a0b490bfb2f57b5bc87c69c197542eafce1b4991cc22f625179a6c6e567834
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8105-32-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-i386-deb9-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 0ccb5b2c1222374874795c35410754dd650f649b774872abbea2a4ef21ac9c9d
unknown_versioning: *ghc-8105-32-deb9
Linux_Ubuntu:
unknown_versioning: *ghc-8105-32-deb9
Linux_Mint:
unknown_versioning: *ghc-8105-32-deb9
Linux_UnknownLinux:
unknown_versioning: *ghc-8105-32-deb9
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/8.10.5/ghc-8.10.5-i386-alpine-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 0e91abe61607f9375d4e252ee9c261e4856df396f60641bb1b880ab8a3a83ea7
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-aarch64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 9a085cd8a7f8e0ace21ac67dbf659a56fcf41564b48817ba42cd8a1aac7f0ddc
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.5/ghc-8.10.5-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.5
dlHash: 56170d1a8450e18b7eb9c23c94723da352815b27ec250bb23742a62f16dcab6c
9.0.1:
viTags:
- Latest
@@ -1868,7 +1777,7 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.4.0.0/cabal-install-3.4.0.0-armv7-linux-bootstrapped.tar.xz
dlHash: 16c0d1eaba24bed14f3e152970179a45d9f9bb5cc839b2c210ad06eb7d4826ed
GHCup:
0.1.15.2:
0.1.14.1:
viTags:
- Recommended
- Latest
@@ -1878,39 +1787,35 @@ ghcupDownloads:
A_64:
Linux_UnknownLinux:
unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-linux-ghcup-0.1.15.2
dlHash: 1eb1bb318a327754f42eaa2245bc81fe53be7c791160d28a186893ded3004ed7
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-linux-ghcup-0.1.14.1
dlHash: 59e31b2ede3ed20f79dce0f8ba0a68b6fb25e5f00ba2d7243f6a8af68d979ff5
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-apple-darwin-ghcup-0.1.15.2
dlHash: c2a6436a49f19f108493954d4a3efcb27503e343dd6288c2641784d32320b1ea
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-apple-darwin-ghcup-0.1.14.1
dlHash: 3e1dd173b3e7b5d90dcdece423c3ddd3efb4c83e964967b0fb574c9b7b2c44e1
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-portbld-freebsd-ghcup-0.1.15.2
dlHash: 7e0c17dd78ebd9fd03e6ecea278c192bac31ca333721bde5b0ef99438b847a20
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-portbld-freebsd-ghcup-0.1.14.1
dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/i386-linux-ghcup-0.1.15.2
dlHash: 3b1fe710cded0398e920ec9716089ba65226abf181741897f387e7c539a619c2
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/i386-linux-ghcup-0.1.14.1
dlHash: 610aac7c3be3ba3874c07b9cae5b2ca0da9a92bf381afc2597bd2dc9c70aae0c
Linux_Alpine:
unknown_versioning: *ghcup-32
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-linux-ghcup-0.1.15.2
dlHash: d91b7a5416f292f2cf813824eb419f76ad9976d258cee3581123cb6eb01db9a7
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-apple-darwin-ghcup-0.1.15.2
dlHash: 20625ba5e7488f2a6155331750ecead3815ea16b2695c20521633c1412f012cc
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/aarch64-linux-ghcup-0.1.14.1
dlHash: e9ae07b7d41ea03e6af9c1f3587f61287827c4e29478b6a5d46ea1ce5af4cee5
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/armv7-linux-ghcup-0.1.15.2
dlHash: 03a4af5ed895ada1dd21f4cc3f64dc9078a5bf4268313021d004c04bea7f9c2e
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/armv7-linux-ghcup-0.1.14.1
dlHash: 646832030efbc0a848df24c08b5eb7507bd15d1c2eb95fea6d9d03890f3662be
HLS:
1.1.0:
viTags:

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.15.2
version: 0.1.14.1
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
@@ -19,7 +19,6 @@ extra-doc-files:
CHANGELOG.md
config.yaml
ghcup-0.0.4.yaml
ghcup-0.0.5.yaml
HACKING.md
README.md
RELEASING.md
@@ -29,21 +28,19 @@ source-repository head
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui
description:
Build the brick powered tui (ghcup tui). This is disabled on windows.
description: Build the brick powered tui (ghcup tui)
default: False
manual: True
flag internal-downloader
description:
Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
Compile the internal downloader, which links against OpenSSL
default: False
manual: True
flag tar
description: Use tar-bytestring instead of libarchive.
description: Use tar-bytestring instead of libarchive
default: False
manual: True
@@ -61,7 +58,6 @@ library
GHCup.Utils
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.File.Common
GHCup.Utils.Logger
GHCup.Utils.MegaParsec
GHCup.Utils.Prelude
@@ -74,20 +70,14 @@ library
autogen-modules: Paths_ghcup
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
@@ -95,25 +85,28 @@ library
build-depends:
, aeson >=1.4 && <1.6
, ascii-string ^>=1.0
, async >=0.8 && <2.3
, base >=4.13 && <5
, base16-bytestring >=0.1.1.6 && <1.1
, binary ^>=0.8.6.0
, bytestring ^>=0.10
, bz2 >=0.5.0.5 && <1.1
, case-insensitive ^>=1.2.1.0
, casing ^>=0.1.4.1
, concurrent-output ^>=1.10.11
, containers ^>=0.6
, cryptohash-sha256 ^>=0.11.101.0
, deepseq ^>=1.4.4.0
, directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1
, extra ^>=1.7.9
, filepath ^>=1.4.2.1
, generics-sop ^>=0.5
, haskus-utils-types ^>=1.5
, haskus-utils-variant >=3.0 && <3.2
, lzma-static ^>=5.2.5.3
, hpath >=0.11 && <0.13
, hpath-directory ^>=0.14.1
, hpath-filepath ^>=0.10.3
, hpath-io ^>=0.14.1
, hpath-posix ^>=0.13.2
, lzma-static ^>=5.2.5.2
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
@@ -128,62 +121,44 @@ library
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, split ^>=0.2.3.4
, streamly ^>=0.7.3
, streamly-bytestring ^>=0.1.2
, streamly-posix ^>=0.1.0.0
, strict-base ^>=0.4
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, temporary ^>=1.3
, template-haskell >=2.7 && <2.17
, text ^>=1.2.4.0
, time ^>=1.9.3
, transformers ^>=0.5
, unix ^>=2.7
, unix-bytestring ^>=0.3
, unliftio-core ^>=0.2.0.1
, unordered-containers ^>=0.2.10.0
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, vector ^>=0.12
, versions >=4.0.1 && <5.1
, versions ^>=4.0.1
, vty >=5.28.2 && <5.34
, word8 ^>=0.1.3
, yaml ^>=0.11.4.0
, zip ^>=1.7.1
, zlib ^>=0.6.2.2
if (flag(internal-downloader) && !os(windows))
if flag(internal-downloader)
exposed-modules: GHCup.Download.IOStreams
cpp-options: -DINTERNAL_DOWNLOADER
build-depends:
, HsOpenSSL >=0.11.4.18
, http-io-streams >=0.1.2.0
, io-streams >=1.5.2.1
, io-streams >=1.5
, terminal-progress-bar >=0.4.1
if flag(tar)
cpp-options: -DTAR
build-depends: tar
build-depends: tar-bytestring ^>=0.6.3.1
else
build-depends: libarchive ^>=3.0.0.0
if os(windows)
cpp-options: -DIS_WINDOWS
other-modules: GHCup.Utils.File.Windows
build-depends:
, bzlib
, process ^>=1.6.11.0
, retry ^>=0.8.1.2
, Win32 ^>=2.10
else
other-modules: GHCup.Utils.File.Posix
build-depends:
, bz2 >=0.5.0.5 && <1.1
, hpath-posix ^>=0.13.3
, process ^>=1.6.9
, unix ^>=2.7
, unix-bytestring ^>=0.3.7.3
if (flag(tui) && !os(windows))
cpp-options: -DBRICK
build-depends: vty >=5.28.2 && <5.34
executable ghcup
main-is: Main.hs
hs-source-dirs: app/ghcup
@@ -191,7 +166,6 @@ executable ghcup
default-extensions:
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
RecordWildCards
ScopedTypeVariables
@@ -204,12 +178,14 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson >=1.4 && <1.6
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, filepath ^>=1.4.2.1
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, hpath >=0.11 && <0.13
, hpath-io ^>=0.14.1
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
@@ -220,26 +196,22 @@ executable ghcup
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, template-haskell >=2.7 && <2.17
, text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions >=4.0.1 && <5.1
, versions ^>=4.0.1
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if (flag(tui) && !os(windows))
if flag(tui)
cpp-options: -DBRICK
other-modules: BrickMain
build-depends:
, brick >=0.5 && <0.62
, transformers ^>=0.5
, vector ^>=0.12
, vty >=5.28.2 && <5.34
if os(windows)
cpp-options: -DIS_WINDOWS
, brick >=0.5 && <0.62
, vector ^>=0.12
, vty >=5.28.2 && <5.34
if flag(tar)
cpp-options: -DTAR
@@ -253,32 +225,27 @@ executable ghcup-gen
other-modules: Validate
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson >=1.4 && <1.6
, aeson-pretty ^>=0.8.8
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, filepath ^>=1.4.2.1
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, hpath >=0.11 && <0.13
, hpath-filepath ^>=0.10.3
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics >=0.2 && <0.5
@@ -292,12 +259,13 @@ executable ghcup-gen
, text ^>=1.2.4.0
, transformers ^>=0.5
, uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1
, utf8-string ^>=1.0
, versions ^>=4.0.1
, yaml ^>=0.11.4.0
if flag(tar)
cpp-options: -DTAR
build-depends: tar
build-depends: tar-bytestring ^>=0.6.3.1
else
build-depends: libarchive ^>=3.0.0.0
@@ -330,10 +298,11 @@ test-suite ghcup-test
, containers ^>=0.6
, generic-arbitrary ^>=0.1.0
, ghcup
, hspec ^>=2.7.10
, hspec-golden-aeson ^>=0.9
, hpath >=0.11 && <0.13
, hspec ^>=2.7.4
, hspec-golden-aeson >=0.7 && <0.10
, QuickCheck ^>=2.14.1
, quickcheck-arbitrary-adt ^>=0.3.1.0
, text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1
, versions ^>=4.0.1

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -16,7 +16,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
Module for handling all download related functions.
@@ -36,7 +36,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.Dirs
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
@@ -57,7 +57,7 @@ import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
#endif
import Data.List.Extra
import Data.List ( find )
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
@@ -68,29 +68,32 @@ import Data.Time.Format
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Error
import System.Posix.Env.ByteString ( getEnv )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI
#endif
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
@@ -112,26 +115,26 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> Settings
-> Dirs
=> URLSource
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF settings@Settings{ urlSource } dirs = do
getDownloadsF urlSource = do
case urlSource of
GHCupURL -> liftE $ getBase dirs settings
GHCupURL -> liftE getBase
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE $ getBase dirs settings
base <- liftE getBase
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE $ getBase dirs settings
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
@@ -140,39 +143,36 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
-> GHCupInfo
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
let new = M.mapWithKey (\k a -> case M.lookup k ext of
Just a' -> M.union a' a
Nothing -> a
) base
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
) base
in GHCupInfo tr new
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache Dirs {..} = do
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
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)
yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError yaml_file)
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO
$ L.readFile yaml_file
$ readFile yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Settings
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } =
handleIO (\_ -> readFromCache dirs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache dirs)
(\(DownloadFailed _) -> readFromCache)
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where
@@ -190,6 +190,7 @@ getBase dirs@Dirs{..} Settings{ downloader } =
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, MonadReader AppState m1
)
=> URI
-> Excepts
@@ -204,29 +205,33 @@ getBase dirs@Dirs{..} Settings{ downloader } =
m1
L.ByteString
smartDl uri' = do
AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file
if e
then do
accessTime <- liftIO $ getAccessTime json_file
currentTime <- liftIO getCurrentTime
accessTime <-
PF.accessTimeHiRes
<$> liftIO (PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO getPOSIXTime
-- access time won't work on most linuxes, but we can try regardless
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
if (currentTime - accessTime) > 300
then do -- no access in last 5 minutes, re-check upstream mod time
getModTime >>= \case
Just modTime -> do
fileMod <- liftIO $ getModificationTime json_file
if modTime > fileMod
then dlWithMod modTime json_file
else liftIO $ L.readFile json_file
else liftIO $ readFile json_file
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
dlWithoutMod json_file
else -- access in less than 5 minutes, re-use file
liftIO $ L.readFile json_file
liftIO $ readFile json_file
else do
liftIO $ createDirRecursive' cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Nothing -> do
@@ -237,14 +242,14 @@ 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'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
liftIO $ writeFileL json_file (Just newFilePerms) bs
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
pure bs
@@ -273,10 +278,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
#endif
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
writeFileWithModTime utctime path content = do
L.writeFile path content
setModificationTime path utctime
let mod_time = utcTimeToPOSIXSeconds utctime
writeFileL path (Just newFilePerms) content
setModificationTimeHiRes path mod_time
getDownloadInfo :: Tool
@@ -322,16 +328,16 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
--
-- The file must not exist.
download :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Settings
-> DownloadInfo
-> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
download settings@Settings{ downloader } dli dest mfn
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = cp
@@ -342,9 +348,9 @@ download settings@Settings{ downloader } dli dest mfn
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
let destFile = getDestFile
let fromFile = T.unpack . decUTF8Safe $ path
liftIO $ copyFile fromFile destFile
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
pure destFile
dl = do
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
@@ -352,37 +358,37 @@ download settings@Settings{ downloader } dli dest mfn
-- destination dir must exist
liftIO $ createDirRecursive' dest
let destFile = getDestFile
destFile <- getDestFile
-- download
flip onException
(liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
case downloader of
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
Wget -> do
o' <- liftIO getWgetOpts
liftE $ lEM @_ @'[ProcessError] $ exec "wget"
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
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 :: MonadThrow m => m (Path Abs)
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
path = view (dlUri % pathL') dli
@@ -395,40 +401,27 @@ downloadCached :: ( MonadMask m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadReader AppState m
)
=> Settings
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached settings@Settings{ cache } dirs dli mfn = do
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> downloadCached' settings dirs dli mfn
True -> do
AppState {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure cachfile
| otherwise -> liftE $ download dli cacheDir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download settings dli tmp mfn
downloadCached' :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
)
=> Settings
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' settings Dirs{..} dli mfn = do
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest settings dli cachfile
pure cachfile
| otherwise -> liftE $ download settings dli cacheDir mfn
liftE $ download dli tmp mfn
@@ -441,9 +434,8 @@ downloadCached' settings Dirs{..} dli mfn = do
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
=> Downloader
-> URI
downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
@@ -455,14 +447,14 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
]
m
L.ByteString
downloadBS downloader uri'
downloadBS uri'
| scheme == "https"
= dl True
| scheme == "http"
= dl False
| scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
(liftIO $ RD.readFile path)
| otherwise
= throwE UnsupportedScheme
@@ -475,23 +467,23 @@ downloadBS downloader uri'
dl _ = do
#endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
case downloader of
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
let exe = "curl"
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
let exe = [rel|curl|]
args = o' ++ ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
Wget -> do
o' <- liftIO getWgetOpts
let exe = "wget"
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
let exe = [rel|wget|]
args = o' ++ ["-qO-", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
@@ -499,39 +491,33 @@ downloadBS downloader uri'
#endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Settings
-> DownloadInfo
-> FilePath
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo
-> Path Abs
-> Excepts '[DigestError] m ()
checkDigest Settings{ noVerify } dli file = do
let verify = not noVerify
checkDigest dli file = do
verify <- lift ask <&> (not . noVerify . settings)
when verify $ do
let p' = takeFileName file
p' <- toFilePath <$> basename file
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
c <- liftIO $ L.readFile file
c <- liftIO $ readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
let eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [String]
getCurlOpts :: IO [ByteString]
getCurlOpts =
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
getEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ BS.split _space r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [String]
getWgetOpts :: IO [ByteString]
getWgetOpts =
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
getEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ BS.split _space r
Nothing -> pure []
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False

View File

@@ -24,6 +24,8 @@ import Data.CaseInsensitive ( CI )
import Data.IORef
import Data.Maybe
import Data.Text.Read
import HPath
import HPath.IO as HIO
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import Optics
@@ -31,8 +33,11 @@ import Prelude hiding ( abs
, readFile
, writeFile
)
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import System.ProgressBar
import System.IO
import URI.ByteString
import qualified Data.ByteString as BS
@@ -76,12 +81,12 @@ downloadToFile :: (MonadMask m, MonadIO m)
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000)
-> FilePath -- ^ destination file to create and write to
-> Path Abs -- ^ destination file to create and write to
-> Excepts '[DownloadFailed] m ()
downloadToFile https host fullPath port destFile = do
fd <- liftIO $ openFile destFile WriteMode
let stepper = BS.hPut fd
flip finally (liftIO $ hClose fd)
fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd
flip finally (liftIO $ closeFd fd)
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper

View File

@@ -15,11 +15,12 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Errors where
import GHCup.Types
import GHCup.Utils.Prelude
#if !defined(TAR)
import Codec.Archive
@@ -27,9 +28,11 @@ import Codec.Archive
import qualified Codec.Archive.Tar as Tar
#endif
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import Haskus.Utils.Variant
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
@@ -83,12 +86,12 @@ instance Pretty DistroNotFound where
text "Unable to figure out the distribution of the host."
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive FilePath
data UnknownArchive = UnknownArchive ByteString
deriving Show
instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
text [i|The archive format is unknown. We don't know how to extract the file "#{decUTF8Safe file}"|]
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
@@ -140,12 +143,12 @@ instance Pretty NotInstalled where
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath
data NotFoundInPATH = NotFoundInPATH (Path Rel)
deriving Show
instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text [i|The exe "#{exe}" was not found in PATH.|]
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
@@ -157,12 +160,12 @@ instance Pretty JSONError where
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError FilePath
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text [i|File "#{file}" does not exist.|]
text [i|File "#{decUTF8Safe file}" does not exist.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@@ -249,11 +252,11 @@ deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{path}": #{reason}|]
text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
deriving instance Show BuildFailed

View File

@@ -13,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Platform where
@@ -36,21 +36,18 @@ import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Info
import System.Directory
import System.OsRelease
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.Text as T
import qualified Data.Text.IO as T
--------------------------
--[ Platform detection ]--
@@ -58,7 +55,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -83,7 +80,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -98,34 +95,36 @@ getPlatform = do
either (const Nothing) Just
. versioning
-- TODO: maybe do this somewhere else
. decUTF8Safe'
. getMajorVersion
. decUTF8Safe
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
"freebsd" -> do
ver <-
either (const Nothing) Just . versioning . decUTF8Safe'
either (const Nothing) Just . versioning . decUTF8Safe
<$> getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{prettyShow pfr}|]
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
getFreeBSDVersion =
liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
["-productVersion"]
Nothing
getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
[ liftIO try_os_release
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, liftIO try_redhat_release
, liftIO try_debian_version
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
@@ -148,12 +147,12 @@ getLinuxDistro = do
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
lsb_release_cmd :: FilePath
lsb_release_cmd = "lsb-release"
redhat_release :: FilePath
redhat_release = "/etc/redhat-release"
debian_version :: FilePath
debian_version = "/etc/debian_version"
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
@@ -161,17 +160,16 @@ getLinuxDistro = do
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
try_lsb_release_cmd :: (MonadFail m, MonadIO m)
=> m (Text, Maybe Text)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- liftIO $ findExecutable lsb_release_cmd
(Just _) <- findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- T.readFile redhat_release
t <- fmap decUTF8Safe' $ readFile redhat_release
let nameRegex n =
makeRegexOpts compIgnoreCase
execBlank
@@ -193,5 +191,5 @@ getLinuxDistro = do
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
ver <- T.readFile debian_version
pure (T.pack "debian", Just ver)
ver <- readFile debian_version
pure (T.pack "debian", Just . decUTF8Safe' $ ver)

View File

@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Requirements where

View File

@@ -2,6 +2,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : GHCup.Types
@@ -10,43 +14,28 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Types
( module GHCup.Types
#if defined(BRICK)
, Key(..)
#endif
)
where
module GHCup.Types where
import Control.Applicative
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import HPath
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
#if !defined(BRICK)
data Key = KEsc | KChar Char | KBS | KEnter
| KLeft | KRight | KUp | KDown
| KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
| KFun Int | KBackTab | KPrtScr | KPause | KIns
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
deriving (Eq,Show,Read,Ord,GHC.Generic)
#endif
--------------------
--[ GHCInfo Tree ]--
@@ -56,7 +45,6 @@ data Key = KEsc | KChar Char | KBS | KEnter
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
}
deriving (Show, GHC.Generic)
@@ -102,10 +90,6 @@ data Tool = GHC
| Cabal
| GHCup
| HLS
| Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
@@ -177,15 +161,12 @@ data Platform = Linux LinuxDistro
| Darwin
-- ^ must exit
| FreeBSD
| Windows
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
platformToString :: Platform -> String
platformToString (Linux distro) = "linux-" ++ distroToString distro
platformToString Darwin = "darwin"
platformToString FreeBSD = "freebsd"
platformToString Windows = "windows"
instance Pretty Platform where
pPrint = text . platformToString
@@ -241,12 +222,12 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data TarDir = RealDir FilePath
data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Ord, GHC.Generic, Show)
instance Pretty TarDir where
pPrint (RealDir path) = text path
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
pPrint (RegexDir regex) = text regex
@@ -273,50 +254,45 @@ defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Key
, kDown :: Maybe Key
, kQuit :: Maybe Key
, kInstall :: Maybe Key
, kUninstall :: Maybe Key
, kSet :: Maybe Key
, kChangelog :: Maybe Key
, kShowAll :: Maybe Key
, kShowAllTools :: Maybe Key
{ kUp :: Maybe Vty.Key
, kDown :: Maybe Vty.Key
, kQuit :: Maybe Vty.Key
, kInstall :: Maybe Vty.Key
, kUninstall :: Maybe Vty.Key
, kSet :: Maybe Vty.Key
, kChangelog :: Maybe Vty.Key
, kShowAll :: Maybe Vty.Key
}
deriving (Show, GHC.Generic)
data KeyBindings = KeyBindings
{ bUp :: Key
, bDown :: Key
, bQuit :: Key
, bInstall :: Key
, bUninstall :: Key
, bSet :: Key
, bChangelog :: Key
, bShowAllVersions :: Key
, bShowAllTools :: Key
{ bUp :: Vty.Key
, bDown :: Vty.Key
, bQuit :: Vty.Key
, bInstall :: Vty.Key
, bUninstall :: Vty.Key
, bSet :: Vty.Key
, bChangelog :: Vty.Key
, bShowAll :: Vty.Key
}
deriving (Show, GHC.Generic)
defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings
{ bUp = KUp
, bDown = KDown
, bQuit = KChar 'q'
, bInstall = KChar 'i'
, bUninstall = KChar 'u'
, bSet = KChar 's'
, bChangelog = KChar 'c'
, bShowAllVersions = KChar 'a'
, bShowAllTools = KChar 't'
{ bUp = Vty.KUp
, bDown = Vty.KDown
, bQuit = Vty.KChar 'q'
, bInstall = Vty.KChar 'i'
, bUninstall = Vty.KChar 'u'
, bSet = Vty.KChar 's'
, bChangelog = Vty.KChar 'c'
, bShowAll = Vty.KChar 'a'
}
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
} deriving (Show)
data Settings = Settings
@@ -330,11 +306,11 @@ data Settings = Settings
deriving (Show, GHC.Generic)
data Dirs = Dirs
{ baseDir :: FilePath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
, confDir :: Path Abs
}
deriving Show
@@ -351,10 +327,10 @@ data Downloader = Curl
deriving (Eq, Show, Ord)
data DebugInfo = DebugInfo
{ diBaseDir :: FilePath
, diBinDir :: FilePath
, diGHCDir :: FilePath
, diCacheDir :: FilePath
{ diBaseDir :: Path Abs
, diBinDir :: Path Abs
, diGHCDir :: Path Abs
, diCacheDir :: Path Abs
, diArch :: Architecture
, diPlatform :: PlatformResult
}
@@ -449,14 +425,11 @@ instance Pretty Version where
pPrint = text . T.unpack . prettyVer
instance (Monad m, Alternative m) => Alternative (LoggingT m) where
empty = Trans.lift empty
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
-----------------
--[ Instances ]--
-----------------
instance MonadReader r' m => MonadReader r' (Excepts es m) where
ask = lift ask
local = mapExcepts . local
reader = lift . reader

View File

@@ -17,7 +17,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Types.JSON where
@@ -33,27 +33,38 @@ import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Text.Encoding as E
import Data.Versions
import Data.Void
import Data.Word8
import HPath
import URI.ByteString
import Text.Casing
import qualified Data.ByteString as BS
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
instance ToJSON Tag where
toJSON Latest = String "Latest"
@@ -117,13 +128,11 @@ instance ToJSONKey Platform where
Darwin -> T.pack "Darwin"
FreeBSD -> T.pack "FreeBSD"
Linux d -> T.pack ("Linux_" <> show d)
Windows -> T.pack "Windows"
instance FromJSONKey Platform where
fromJSONKey = FromJSONKeyTextParser $ \t -> if
| T.pack "Darwin" == t -> pure Darwin
| T.pack "FreeBSD" == t -> pure FreeBSD
| T.pack "Windows" == t -> pure Windows
| T.pack "Linux_" `T.isPrefixOf` t -> case
T.stripPrefix (T.pack "Linux_") t
of
@@ -190,11 +199,19 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey GlobalTool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . decUTF8Safe $ fp
False -> String "/not/a/valid/path"
where fp = toFilePath p
instance FromJSON (Path Rel) where
parseJSON = withText "HPath Rel" $ \t -> do
let d = encodeUtf8 t
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
instance FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p
@@ -305,14 +322,3 @@ instance FromJSONKey (Maybe VersionRange) where
just t = case MP.parse versionRangeP "" t of
Right x -> pure $ Just x
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings

View File

@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Types.Optics where

File diff suppressed because it is too large Load Diff

View File

@@ -1,4 +0,0 @@
module GHCup.Utils where
getLinkTarget :: FilePath -> IO FilePath
pathIsLink :: FilePath -> IO Bool

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -13,11 +12,10 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
, ghcupGHCBaseDir
@@ -26,10 +24,6 @@ module GHCup.Utils.Dirs
, parseGHCupGHCDir
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
#if !defined(IS_WINDOWS)
, useXDG
#endif
)
where
@@ -40,6 +34,7 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
@@ -47,22 +42,32 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Optics
#if !defined(IS_WINDOWS)
import System.Directory
#endif
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.DiskSpace
import System.Environment
import System.FilePath
import System.IO.Temp
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -77,117 +82,96 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
#if defined(IS_WINDOWS)
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
bdir <- getEnv "XDG_DATA_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
pure (home </> [rel|.local/share|])
pure (bdir </> [rel|ghcup|])
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
pure (bdir </> [rel|.ghcup|])
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO FilePath
ghcupConfigDir :: IO (Path Abs)
ghcupConfigDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
pure (home </> [rel|.config|])
pure (bdir </> [rel|ghcup|])
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
pure (bdir </> [rel|.ghcup|])
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO FilePath
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "bin")
#else
xdg <- useXDG
if xdg
then do
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
getEnv "XDG_BIN_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
pure (home </> [rel|.local/bin|])
else ghcupBaseDir <&> (</> [rel|bin|])
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO FilePath
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "cache")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup|])
else ghcupBaseDir <&> (</> [rel|cache|])
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO FilePath
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "logs")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup/logs|])
else ghcupBaseDir <&> (</> [rel|logs|])
getDirs :: IO Dirs
@@ -205,19 +189,16 @@ getDirs = do
--[ GHCup files ]--
-------------------
getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath = do
confDir <- liftIO ghcupConfigDir
pure $ confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
filepath <- getConfigFilePath
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
case contents of
confDir <- liftIO ghcupConfigDir
let file = confDir </> [rel|config.yaml|]
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of
Nothing -> pure defaultUserSettings
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
-------------------------
@@ -226,10 +207,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
pure (baseDir </> "ghc")
pure (baseDir </> [rel|ghc|])
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -238,32 +219,35 @@ ghcupGHCBaseDir = do
-- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
-> m (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
pure (ghcbasedir </> verdir)
-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
parseGHCupGHCDir (toFilePath -> f) = do
fp <- throwEither $ E.decodeUtf8' f
throwEither $ MP.parse ghcTargetVerP "" fp
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO getCanonicalTemporaryDirectory
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
let fp = T.unpack $ decUTF8Safe tmpdir
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(logWarn) [i|Possibly insufficient disk space on #{fp}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(logWarn)
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
liftIO $ createTempDirectory tmpdir "ghcup"
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
parseAbs tmp
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
@@ -272,8 +256,8 @@ mkGhcupTmpDir = do
where t = 10^n
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
@@ -283,21 +267,29 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
--------------
#if !defined(IS_WINDOWS)
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv "HOME"
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
#endif
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination
-> FilePath
relativeSymlink p1 p2 =
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
-> Path Abs -- ^ the symlink destination
-> ByteString
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
let d1 = splitDirectories p1
d2 = splitDirectories p2
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ([pathSeparator] : drop (length common) d2)
<> joinPath ("/" : drop (length common) d2)

View File

@@ -1,17 +1,482 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils.File (
module GHCup.Utils.File.Common,
#if IS_WINDOWS
module GHCup.Utils.File.Windows
#else
module GHCup.Utils.File.Posix
#endif
) where
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Void
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import Optics hiding ((<|), (|>))
import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
import System.IO.Error
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl, oAppend )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process.ByteString
as SPPB
import Streamly.External.Posix.DirStream
import qualified Streamly.Prelude as S
import qualified Text.Megaparsec as MP
import qualified Data.ByteString as BS
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args}.|]
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
, _stdErr :: ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
-- This shouldn't throw IO exceptions, unless getting the environment variable
-- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap
(handleIO (\_ -> pure Nothing)
-- asum for short-circuiting behavior
. (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
)
sPaths
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO CapturedProcess
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename (opened in append mode)
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> MVar Bool
-> Seq ConsoleRegion
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env pState rs = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
closeFd
(action verbose)
where
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
void $ tryTakeMVar pState
done <- newEmptyMVar
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6
)
(putMVar done ())
-- fork the subprocess
pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
putMVar pState (either (const False) (const True) e)
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> IO ()
printToRegion fileFd fdIn size = do
void $
flip runStateT mempty $ readTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs' = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs') $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = go
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else void (action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action = do
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- start thread that writes the output
refOut <- newIORef BS.empty
refErr <- newIORef BS.empty
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPPB.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
case status of
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds pout perr rout rerr = do
doneOut <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
takeMVar doneOut
takeMVar doneErr
readTilEOF ~action' fd' = do
bs <- SPIB.fdRead fd' 512
void $ action' bs
readTilEOF action' fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> Path b -> IO Fd
createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
-- | Thin wrapper around `executeFile`.
exec :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
exec exe spath args chdir env = do
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
$ do
dirStream <- openDirStream (toFilePath x)
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
>>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == toFilePath needle
then isExecutable (basedir </> needle)
else pure False
-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: Path Abs -> IO (Maybe (Path Abs))
isShadowed p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
searchPath shadowPaths fn
else pure Nothing
-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: Path Abs -> IO Bool
isInPath p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
findFiles :: Path Abs -> Regex -> IO [Path Rel]
findFiles path regex = do
dirStream <- openDirStream (toFilePath path)
f <-
(fmap . fmap) snd
. S.toList
. S.filter (\(_, p) -> match regex p)
$ dirContentsStream dirStream
pure $ parseRel =<< f
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
findFiles' path parser = do
dirStream <- openDirStream (toFilePath path)
f <-
(fmap . fmap) snd
. S.toList
. S.filter (\(_, p) -> case E.decodeUtf8' p of
Left _ -> False
Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream
pure $ parseRel =<< f
isBrokenSymlink :: Path Abs -> IO Bool
isBrokenSymlink p =
handleIO
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
$ do
_ <- canonicalizePath p
pure False
chmod_755 :: (MonadLogger m, MonadIO m) => Path a -> m ()
chmod_755 (toFilePath -> fp) = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
liftIO $ setFileMode fp exe_mode

View File

@@ -1,106 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils.File.Common where
import GHCup.Utils.Prelude
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory
import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Data.ByteString.Lazy as BL
data ProcessError = NonZeroExit Int FilePath [String]
| PTerminated FilePath [String]
| PStopped FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{exe}" with arguments #{args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{exe}" with arguments #{args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString
, _stdErr :: BL.ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
$ do
contents <- listDirectory x
findM (isMatch x) contents >>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == needle
then isExecutable (basedir </> needle)
else pure False
isExecutable :: FilePath -> IO Bool
isExecutable file = executable <$> getPermissions file
-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: FilePath -> IO (Maybe FilePath)
isShadowed p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
searchPath shadowPaths fn
else pure Nothing
-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: FilePath -> IO Bool
isInPath p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
findFiles :: FilePath -> Regex -> IO [FilePath]
findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents

View File

@@ -1,386 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.IORef
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.List
import Data.Word8
import GHC.IO.Exception
import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
import System.IO.Error
import System.FilePath
import System.Directory
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process as SPP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
executeOut path args chdir = liftIO $ captureOutStreams $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile path True args Nothing
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd
(action verbose)
where
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
(putMVar done ())
-- fork the subprocess
pid <- SPP.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
-- execute the action
maybe (pure ()) changeWorkingDirectory chdir
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
putMVar pState (either (const False) (const True) e)
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
printToRegion fileFd fdIn size pState = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState
when ps (forM_ rs (liftIO . closeConsoleRegion))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = go
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else void (action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action = do
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPP.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- start thread that writes the output
refOut <- newIORef BL.empty
refErr <- newIORef BL.empty
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPP.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
case status of
-- readFd will take care of closing the fd
Just (SPP.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
writeStds pout perr rout rerr = do
doneOut <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
takeMVar doneOut
takeMVar doneErr
readTilEOF ~action' fd' = do
bs <- SPIB.fdRead fd' 512
void $ action' bs
readTilEOF action' fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> FilePath -> IO Fd
createRegularFileFd fm dest =
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> String -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
exec exe args chdir env = liftIO $ do
pid <- SPP.forkProcess $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
toProcessError :: FilePath
-> [String]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPP.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e

View File

@@ -1,247 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
Module : GHCup.Utils.File.Windows
Description : File and windows APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : Windows
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Windows where
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
import GHCup.Types
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import System.Process
import qualified Control.Exception as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
toProcessError :: FilePath
-> [FilePath]
-> ExitCode
-> Either ProcessError ()
toProcessError exe args exitcode = case exitcode of
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
ExitSuccess -> Right ()
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
-- lets you pass 'CreateProcess' giving better flexibility.
--
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
-- record will be ignored.
--
-- @since 1.2.3.0
readCreateProcessWithExitCodeBS
:: CreateProcess
-> BL.ByteString
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
readCreateProcessWithExitCodeBS cp input = do
let cp_opts = cp {
std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe
}
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
\mb_inh mb_outh mb_errh ph ->
case (mb_inh, mb_outh, mb_errh) of
(Just inh, Just outh, Just errh) -> do
out <- BS.hGetContents outh
err <- BS.hGetContents errh
-- fork off threads to start consuming stdout & stderr
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
-- now write any input
unless (BL.null input) $
ignoreSigPipe $ BL.hPut inh input
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
ignoreSigPipe $ hClose inh
-- wait on the output
waitOut
waitErr
hClose outh
hClose errh
-- wait on the process
ex <- waitForProcess ph
return (ex, BL.fromStrict out, BL.fromStrict err)
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
where
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = EX.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
-- wrapper so we can get exceptions with the appropriate function name.
withCreateProcess_
:: String
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess_ fun c action =
EX.bracketOnError (createProcess_ fun c) cleanupProcess
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async' body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async') >>= putMVar waitVar
let wait' = takeMVar waitVar >>= either throwIO return
restore (body wait') `EX.onException` killThread tid
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
executeOut path args chdir = do
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
pure $ CapturedProcess exit out err
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args)
{ cwd = chdir
, env = env
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
})
fmap (toProcessError exe args)
$ liftIO
$ withCreateProcess cp
$ \_ mout merr ph ->
case (mout, merr) of
(Just cStdout, Just cStderr) -> do
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
waitOut
waitErr
waitForProcess ph
_ -> fail "Could not acquire out/err handle"
where
tee :: FilePath -> Handle -> IO ()
tee logFile handle' = go
where
go = do
some <- BS.hGetSome handle' 512
if BS.null some
then pure ()
else do
void $ BS.appendFile logFile some
void $ BS.hPut stdout some
go
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
exec exe args chdir env = do
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code
chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp =
let perm = setOwnerWritable True emptyPermissions
in liftIO $ setPermissions fp perm
createProcessWithMingwPath :: MonadIO m
=> CreateProcess
-> m CreateProcess
createProcessWithMingwPath cp = do
msys2Dir <- liftIO ghcupMsys2Dir
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
let mingWPaths = [msys2Dir </> "usr" </> "bin"
,msys2Dir </> "mingw64" </> "bin"]
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
envWithNewPath = Map.insert "Path" newPath envWithoutPath
liftIO $ setEnv "Path" newPath
pure $ cp { env = Just $ Map.toList envWithNewPath }
ghcupMsys2Dir :: IO FilePath
ghcupMsys2Dir =
lookupEnv "GHCUP_MSYS2" >>= \case
Just fp -> pure fp
Nothing -> do
baseDir <- liftIO ghcupBaseDir
pure (baseDir </> "msys64")
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
b <- pathIsLink fp
if b
then do
tfp <- getLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp)
else pure False

View File

@@ -8,26 +8,29 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.String.QQ
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import qualified Data.ByteString as B
import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
@@ -65,17 +68,20 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
initGHCupFileLogging logsDir = do
let logfile = logsDir </> "ghcup.log"
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
initGHCupFileLogging = do
AppState {dirs = Dirs {..}} <- ask
let logfile = logsDir </> [rel|ghcup.log|]
liftIO $ do
createDirRecursive' logsDir
logFiles <- findFiles
logsDir
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
writeFile logfile ""
createRegularFile newFilePerms logfile
pure logfile

View File

@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Utils.MegaParsec where
@@ -23,7 +23,6 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Versions
import Data.Void
import System.FilePath
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
@@ -118,7 +117,3 @@ verP suffix = do
v <- versioning'
MP.setInput rest
pure v
pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -13,7 +12,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
GHCup specific prelude. Lots of Excepts functionality.
-}
@@ -26,8 +25,6 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate )
import Data.Foldable
import Data.String
import Data.Text ( Text )
import Data.Versions
@@ -35,19 +32,11 @@ import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.IO.Unsafe
import System.Directory
import System.FilePath
#if defined(IS_WINDOWS)
import Control.Retry
import GHC.IO.Exception
#endif
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.List.Split as Split
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
@@ -191,14 +180,14 @@ hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
hideErrorDef errs def =
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
hideErrorDefM :: [IOErrorType] -> IO a -> IO a -> IO a
hideErrorDefM errs def =
handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
handleIO (\e -> if ioeGetErrorType e `elem` errs then def else ioError e)
-- TODO: does this work?
@@ -253,8 +242,6 @@ throwEither' e eth = case eth of
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
verToS :: Version -> String
verToS = T.unpack . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
@@ -265,6 +252,14 @@ removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO getEnvironment
pure (adds ++ cEnv)
pvpToVersion :: PVP -> Version
pvpToVersion =
either (\_ -> error "Couldn't convert PVP to Version") id
@@ -289,156 +284,3 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- pathIsSymbolicLink p
case ft of
True -> do
rp <- canonicalizePath p
rft <- doesDirectoryExist rp
case rft of
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
where
collect files dirs' [] = return (reverse files
,reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
rmPath :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmPath fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
]
(\_ -> liftIO $ removePathForcibly fp)
#else
liftIO $ removeDirectoryRecursive fp
#endif
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
rmFile :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmFile fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | Strip @\\r@ and @\\n@ from 'ByteString's
stripNewline :: String -> String
stripNewline s
| null s = []
| head s `elem` "\n\r" = stripNewline (tail s)
| otherwise = head s : stripNewline (tail s)
isNewLine :: Word8 -> Bool
isNewLine w
| w == _lf = True
| w == _cr = True
| otherwise = False
-- | Split on a PVP suffix.
--
-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706" == ("ghc-iserv-dyn", "9.3.20210706")
-- >>> splitOnPVP "-" "ghc-iserv-dyn" == ("ghc-iserv-dyn", "")
splitOnPVP :: String -> String -> (String, String)
splitOnPVP c s = case Split.splitOn c s of
[] -> def
[_] -> def
xs
| let l = last xs
, (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
| otherwise -> def
where
def = (s, "")

View File

@@ -7,7 +7,7 @@ Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufel
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
QuasiQuoter for non-interpolated strings, texts and bytestrings.

View File

@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Utils.Version.QQ where

View File

@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Portability : POSIX
-}
module GHCup.Version where
@@ -25,7 +25,7 @@ import qualified Data.Text as T
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.5.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.4.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP

View File

@@ -1,4 +1,4 @@
resolver: lts-17.11
resolver: lts-17.4
packages:
- .
@@ -7,9 +7,6 @@ extra-deps:
- git: https://github.com/hasufell/text-conversions.git
commit: 9abf0e5e5664a3178367597c32db19880477a53c
- git: https://github.com/Bodigrim/tar
commit: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
@@ -20,24 +17,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-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
- hpath-directory-0.14.1@sha256:548ac1321222c34caa843a41a2379a77d961141082a4695bb37cc4731e91b2c7,5312
- 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
- hpath-io-0.14.1@sha256:d91373cd81483eb370a1c683e4add6182250dccce32f9b682bb1104f7765c750,1522
- hpath-posix-0.13.2@sha256:eec4ff2b00dc86be847aca0f409fc8f6212ffd2170ec36a17dc9a52b46562392,1615
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- lzma-static-5.2.5.2@sha256:ac38dcad9ab423342a72ba48415bd75f62234e9c9e11831495b75603b5a060f6,7184
- 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
- regex-posix-clib-2.7
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
- streamly-bytestring-0.1.2@sha256:cc828f41d1c714c711d38fb213b4ed186febabba598ab080e13255f69c20b13c,2469
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- zip-1.7.1@sha256:0ce03d0fbffba47c1ab6fbb9166f8ba5373d828d78587df21b7e9d7bb150f929,3918
flags:
http-io-streams:
@@ -46,8 +40,13 @@ flags:
libarchive:
system-libarchive: false
regex-posix:
_regex-posix-clib: true
ghcup:
tui: true
internal-downloader: true
system-ghc: true
compiler: ghc-8.10.4
compiler-check: match-exact
ghc-options:
"$locals": -O2

View File

@@ -11,6 +11,7 @@ import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import HPath
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
@@ -163,6 +164,11 @@ instance Arbitrary VersionCmp where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (Path Rel) where
arbitrary =
either (error . show) id . parseRel . E.encodeUtf8 . T.pack
<$> listOf1 (elements ['a' .. 'z'])
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink
@@ -171,10 +177,6 @@ instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GlobalTool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink

View File

@@ -132,17 +132,13 @@ hr {
margin-bottom: 2em;
}
span.code {
font-family: 'Lucida Console', monospace;
}
#platform-instructions-linux div > pre,
#platform-instructions-mac div > pre,
#platform-instructions-freebsd div > pre,
#platform-instructions-win32 div > pre,
#platform-instructions-win64 div > pre,
#platform-instructions-default div > div > pre,
#platform-instructions-unknown div > div > pre {
#platform-instructions-linux > div > pre,
#platform-instructions-mac > div > pre,
#platform-instructions-freebsd > div > pre,
#platform-instructions-win32 > div > pre,
#platform-instructions-win64 > div > pre,
#platform-instructions-default > div > div > pre,
#platform-instructions-unknown > div > div > pre {
background-color: #515151;
color: white;
margin-left: auto;

View File

@@ -158,8 +158,8 @@ function copyToClipboard() {
document.body.removeChild(el);
}
function copyToClipboardPowershell() {
const text = document.getElementById("ghcup-command-powershell").innerText;
function copyToClipboardSilicon() {
const text = document.getElementById("ghcup-command-silicon").innerText;
const el = document.createElement('textarea');
el.value = text;
document.body.appendChild(el);

View File

@@ -14,6 +14,7 @@
<body id="idx">
<script id='html-content' type="text/html">
<a id="platform-button" style="display: none;" href="#">
click or press "n" to cycle platforms
</a>
@@ -31,7 +32,10 @@
<div id="platform-instructions-mac" class="instructions" style="display: none;">
<p>Run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<p>On Intel:</p>
<div class="command-button"><pre><span class='ghcup-command' id="ghcup-command-normal">curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p>On Apple Silicon:</p>
<div class="command-button"><pre><span class='ghcup-command' id="ghcup-command-silicon">curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | arch -x86_64 /bin/bash</span></pre><button class="tooltip" onclick="copyToClipboardSilicon()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.<br/>You appear to be running macOS. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -43,41 +47,24 @@
<div id="platform-instructions-win32" class="instructions">
<p>
To install Haskell,<br/>run the following in a powershell session (as a non-admin user).
<div>
<div class="command-button"><pre><span class='ghcup-command' id="ghcup-command-powershell">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 $false</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'>$false</span> to <span class='code'>$true</span> at the end of the script.</p>
</div>
<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.
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
</div>
<p class="other-help">WSL1 does not work with ghcup, follow <a href="https://docs.microsoft.com/en-us/windows/wsl/install-win10">the instructions here</a> to upgrade to WSL2 if needed.</p>
</div>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
</p>
<hr/>
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
<div id="platform-instructions-win64" class="instructions" style="display: none;">
<p>
To install Haskell,<br/>run the following in a powershell session (as a non-admin user).
<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 $false</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'>$false</span> to <span class='code'>$true</span> at the end of the script.</p>
</div>
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
<p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
</div>
<p class="other-help">WSL1 does not work with ghcup, follow <a href="https://docs.microsoft.com/en-us/windows/wsl/install-win10">the instructions here</a> to upgrade to WSL2 if needed.</p>
</div>
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
<div id="platform-instructions-unknown" class="instructions" style="display: none;">
@@ -99,7 +86,7 @@
<!-- duplicate the default cross-platform instructions -->
<div>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem 2 for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
@@ -108,8 +95,8 @@
<div>
<p>
If you are running Windows,<br/>run the following in a powershell session (as a non-admin user).
<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 $false</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
If you are running Windows,<br/>follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
</div>
@@ -117,9 +104,11 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem 2 for Linux, run the following
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p>For macOS on Apple Silicon, run this instead:</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | arch -x86_64 /bin/bash</span></pre><button class="tooltip" onclick="copyToClipboardSilicon()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
@@ -127,15 +116,15 @@
<div>
<p>
If you are running Windows,<br/>run the following in a powershell session (as a non-admin user).
<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 $false</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
If you are running Windows,<br/>follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
</div>
</div>
<p>
Need help? Ask on <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell-ghcup">#haskell-ghcup</a>, <a href="https://kiwiirc.com/nextclient/irc.libera.chat/#haskell">#haskell</a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug</a>.
Need help? <a href="http://webchat.freenode.net/?randomnick=1&channels=%23haskell&uio=d4">Ask on #haskell</a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug</a>.
</p>
<p id="about">
@@ -148,7 +137,54 @@
&nbsp;&middot;&nbsp;
<a href="https://github.com/rust-lang/rustup.rs/tree/master/www">web design from rustup</a>
</p>
</script>
<script>
document.write(document.getElementById("html-content").innerHTML);
</script>
<script type="text/javascript" src="ghcup.js"></script>
<noscript>
<p id="pitch">
<em>ghcup</em> is an installer for<br/>
the general purpose language <a href="https://www.haskell.org/">Haskell</a>
</p>
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS (on Intel), FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
<p>For macOS on Apple Silicon, run this instead:</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | arch -x86_64 /bin/bash</span></pre><button class="tooltip" onclick="copyToClipboardSilicon()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
<hr/>
<div>
<p>
If you are running Windows,<br/>follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
</div>
</div>
<p>
Need help? <a href="http://webchat.freenode.net/?randomnick=1&amp;channels=%23haskell&amp;uio=d4">Ask on #haskell</a>.
</p>
<p id="about">
<img src="haskell-logo.svg" alt="" />
ghcup is a haskell.org hosted project.
<br/>
<a href="https://www.haskell.org/downloads/">other installation options</a>
&nbsp;&middot;&nbsp;
<a href="https://gitlab.haskell.org/haskell/ghcup-hs">about ghcup</a>
&nbsp;&middot;&nbsp;
<a href="https://github.com/rust-lang/rustup.rs/tree/master/www">web design from rustup</a>
</p>
</noscript>
</body>
</html>