Compare commits

..

1 Commits

Author SHA1 Message Date
bc0cd22433 First cross try 2020-04-27 07:49:08 +02:00
88 changed files with 9562 additions and 33325 deletions

13
.gitignore vendored
View File

@@ -1,15 +1,2 @@
.ghci
.vim
codex.tags
dist-newstyle/
cabal.project.local
.stack-work/
bin/
/*.prof
/*.ps
/*.hp
tags
TAGS
/tmp/
.entangled
release/

View File

@@ -1,13 +1,8 @@
stages:
- hlint
- test
- release
variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: 8d0224e6b2a08157649651e69302380b2bd24e11
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
############################################################
# CI Step
@@ -19,91 +14,50 @@ variables:
- x86_64-linux
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.alpine:64bit:
image: "alpine:3.12"
image: "alpine:edge"
tags:
- x86_64-linux
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
BIT: "64"
.alpine:32bit:
image: "i386/alpine:3.12"
image: "i386/alpine:edge"
tags:
- x86_64-linux
variables:
OS: "LINUX"
ARCH: "32"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:armv7:
image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb10:$DOCKER_REV"
tags:
- armv7-linux
variables:
OS: "LINUX"
ARCH: "ARM"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.linux:aarch64:
image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV"
tags:
- aarch64-linux
variables:
OS: "LINUX"
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
BIT: "32"
.darwin:
tags:
- x86_64-darwin
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:
- x86_64-freebsd
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"
artifacts:
expire_in: 2 week
paths:
- golden
when: on_failure
JSON_VERSION: "0.0.2"
.test_ghcup_version:linux:
extends:
@@ -112,27 +66,6 @@ variables:
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
.test_ghcup_version:linux32:
extends:
- .test_ghcup_version
- .alpine:32bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
.test_ghcup_version:armv7:
extends:
- .test_ghcup_version
- .linux:armv7
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
.test_ghcup_version:aarch64:
extends:
- .test_ghcup_version
- .linux:aarch64
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
.test_ghcup_version:darwin:
extends:
- .test_ghcup_version
@@ -141,32 +74,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,174 +82,67 @@ 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:
- out
only:
- tags
variables:
JSON_VERSION: "0.0.5"
######## stack test ########
test:linux:stack:
stage: test
before_script:
- ./.gitlab/before_script/linux/install_deps_minimal.sh
script:
- ./.gitlab/script/ghcup_stack.sh
extends:
- .debian
needs: []
######## bootstrap test ########
test:linux:bootstrap_script:
stage: test
before_script:
- ./.gitlab/before_script/linux/install_deps_minimal.sh
script:
- ./.gitlab/script/ghcup_bootstrap.sh
variables:
GHC_VERSION: "8.10.5"
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 ########
test:linux:recommended:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
needs: []
GHC_VERSION: "8.6.5"
CABAL_VERSION: "3.2.0.0"
test:linux:latest:
stage: test
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "9.0.1"
CABAL_VERSION: "3.4.0.0"
needs: []
######## linux 32bit test ########
test:linux:recommended:32bit:
stage: test
extends: .test_ghcup_version:linux32
variables:
GHC_VERSION: "8.10.5"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
needs: []
allow_failure: true
######## arm tests ########
test:linux:recommended:armv7:
stage: test
extends: .test_ghcup_version:armv7
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
when: manual
needs: []
test:linux:recommended:aarch64:
stage: test
extends: .test_ghcup_version:aarch64
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
when: manual
needs: []
######## darwin test ########
test:mac:recommended:
stage: test
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
GHC_VERSION: "8.6.5"
CABAL_VERSION: "3.2.0.0"
test:mac:latest:
stage: test
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "9.0.1"
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: []
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
######## freebsd test ########
test:freebsd:recommended:
stage: test
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
GHC_VERSION: "8.6.5"
CABAL_VERSION: "3.2.0.0"
######## windows test ########
test:windows:recommended:
stage: test
extends: .test_ghcup_version:windows
test:freebsd:latest:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
needs: []
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
######## linux release ########
release:linux:64bit:
stage: release
needs: ["test:linux:recommended", "test:linux:latest"]
extends:
- .alpine:64bit
- .release_ghcup
@@ -350,54 +150,25 @@ release:linux:64bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
release:linux:32bit:
stage: release
needs: ["test:linux:recommended:32bit"]
extends:
- .alpine:32bit
- .release_ghcup
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "i386-linux-ghcup"
GHC_VERSION: "8.10.5"
ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
release:linux:armv7:
stage: release
needs: ["test:linux:recommended:armv7"]
extends:
- .linux:armv7
- .release_ghcup
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
variables:
ARTIFACT: "armv7-linux-ghcup"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
release:linux:aarch64:
stage: release
needs: ["test:linux:recommended:aarch64"]
extends:
- .linux:aarch64
- .release_ghcup
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
variables:
ARTIFACT: "aarch64-linux-ghcup"
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
######## darwin release ########
release:darwin:
stage: release
needs: ["test:mac:recommended", "test:mac:latest"]
extends:
- .darwin
- .release_ghcup
@@ -406,44 +177,14 @@ release:darwin:
- ./.gitlab/before_script/darwin/install_deps.sh
variables:
ARTIFACT: "x86_64-apple-darwin-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.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"]
extends:
- .freebsd
- .release_ghcup
@@ -452,43 +193,5 @@ release:freebsd:
- ./.gitlab/before_script/freebsd/install_deps.sh
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
allow_failure: true
GHC_VERSION: "8.6.5"
######## 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 ########
hlint:
stage: hlint
extends:
- .alpine:64bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
allow_failure: true
artifacts:
expire_in: 2 week
paths:
- report.html
when: on_failure

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

@@ -4,29 +4,11 @@ set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
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
exit 0

View File

@@ -6,14 +6,18 @@ set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
mkdir -p "${TMPDIR}"
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-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}
mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
# ./ghcup-bin install ${GHC_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION}
# ./ghcup-bin set ${GHC_VERSION}
# install cabal-3.2.0.0
curl -sSfL -o cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
cp cabal "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
exit 0

View File

@@ -4,15 +4,10 @@ set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../../ghcup_env"
mkdir -p "${TMPDIR}"
apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
bsd-compat-headers \
gmp-dev \
ncurses-dev \
libffi-dev \
@@ -21,34 +16,45 @@ apk add --no-cache \
tar \
perl
if [ "${ARCH}" = "32" ] ; then
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
ln -s libncurses.so /usr/lib/libtinfo.so
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
if [ "${BIT}" = "32" ] ; then
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
else
curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
fi
chmod +x ghcup-bin
./ghcup-bin upgrade -i -f
./ghcup-bin upgrade
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION}
# install cabal-3.2.0.0
if [ "${BIT}" = "32" ] ; then
curl -sSfL -o cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-i386-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
else
curl -sSfL -o cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-x86_64-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
fi
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
# utils
apk add --no-cache \
bash \
git
bash
## Package specific
apk add --no-cache \
zlib \
zlib-dev \
zlib-static \
bzip2 \
bzip2-dev \
bzip2-static \
gmp \
gmp-dev \
openssl-dev \
openssl-libs-static \
xz \
xz-dev \
ncurses-static
xz-dev

View File

@@ -2,65 +2,15 @@
set -eux
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
mkdir -p "${TMPDIR}"
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
chmod +x ghcup-bin
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https
case "${ARCH}" in
ARM*)
case "${ARCH}" in
"ARM")
ghc_url=https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-armv7-deb10-linux.tar.xz
cabal_url=home.smart-cactus.org/~ben/cabal-install-${CABAL_VERSION}-armv7-linux-bootstrapped.tar.xz
;;
"ARM64")
ghc_url=https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-aarch64-deb10-linux.tar.xz
cabal_url=https://downloads.haskell.org/~cabal/cabal-install-${CABAL_VERSION}/cabal-install-${CABAL_VERSION}-aarch64-ubuntu-18.04.tar.xz
;;
*)
exit 1 ;;
esac
mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
curl -O "${ghc_url}"
tar -xf ghc-*.tar.*
cd ghc-${GHC_VERSION}
./configure --prefix="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/ghc/${GHC_VERSION}
make install
for i in "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/ghc/${GHC_VERSION}/bin/*-${GHC_VERSION} ; do
ln -s "${i}" "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/${i##*/}
done
for x in "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/*-${GHC_VERSION} ; do
ln -s ${x##*/} ${x%-${GHC_VERSION}}
done
cd ..
rm -rf ghc-${GHC_VERSION} ghc-*.tar.*
unset x i
mkdir cabal-install
cd cabal-install
curl -O "${cabal_url}"
tar -xf cabal-install-*
mv cabal "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/cabal
cd ..
rm -rf cabal-install
;;
*)
url=https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup
curl -sSfL "${url}" > ./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}
;;
esac
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}

View File

@@ -1,10 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
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

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:/opt/llvm/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"

View File

@@ -1,30 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
### build
ecabal update
export BOOTSTRAP_HASKELL_NONINTERACTIVE=yes
export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION
export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION
./bootstrap-haskell
[ "$(ghc --numeric-version)" = "${GHC_VERSION}" ]

View File

@@ -7,42 +7,20 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
# build
ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "LINUX" ] ; then
if [ "${ARCH}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
elif [ "${ARCH}" = "64" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
else
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} -fcurl --ghc-options='-split-sections -optl-static'
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
ecabal build -w ghc-${GHC_VERSION} -fcurl
fi
mkdir out
binary=$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')
ver=$("${binary}" --numeric-version)
if [ "${OS}" = "DARWIN" ] ; then
strip "${binary}"
else
strip -s "${binary}"
fi
cp "${binary}" out/${ARTIFACT}-${ver}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version)
cp ghcup out/${ARTIFACT}-${ver}

View File

@@ -1,21 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
git describe --always
### build
curl -L -O https://get.haskellstack.org/stable/linux-x86_64.tar.gz
tar xf linux-x86_64.tar.gz
cp stack-*-linux-*/stack "$CI_PROJECT_DIR"/.local/bin/stack
chmod +x "$CI_PROJECT_DIR"/.local/bin/stack
mkdir -p "$CI_PROJECT_DIR"/.stack_root
export TAR_OPTIONS=--no-same-owner
stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root build
stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root test

View File

@@ -6,83 +6,49 @@ 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}.json "$@"
}
git describe --always
### build
ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
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} -fcurl
else
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
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
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 ./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
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
ghcup-gen check -f ghcup-${JSON_VERSION}.json
eghcup --numeric-version
# TODO: rm once we have tarballs
if [ "${OS}" = "FREEBSD" ] ; then
GHC_VERSION=8.6.3
CABAL_VERSION=2.4.1.0
fi
eghcup install ${GHC_VERSION}
eghcup set ${GHC_VERSION}
eghcup install-cabal ${CABAL_VERSION}
@@ -97,68 +63,25 @@ 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
fi
ghci --version
ghc-$(ghc --numeric-version) --version
ghci-$(ghc --numeric-version) --version
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
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
# test installing new ghc doesn't mess with currently set GHC
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
eghcup install 8.4.4
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup set 8.4.4
eghcup set 8.4.4
[ "$(ghc --numeric-version)" = "8.4.4" ]
eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup rm 8.4.4
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
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 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,19 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
hlint -r lib/ test/

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,83 +0,0 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Warnings currently triggered by your code
- ignore: {name: "Redundant bang pattern"}
- ignore: {name: "Use camelCase"}
- ignore: {name: "Use if"}
- ignore: {name: "Use newtype instead of data"}
- ignore: {name: "Use <$>"}
- ignore: {name: "Use mapMaybe"}
- ignore: {name: "Use const"}
- ignore: {name: "Use list comprehension"}
- ignore: {name: "Redundant multi-way if"}
- ignore: {name: "Redundant lambda"}
- ignore: {name: "Avoid lambda"}
- ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"}
- ignore: {name: "Redundant irrefutable pattern"}
# Specify additional command line arguments
#
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
# Control which extensions/flags/modules/functions can be used
#
# - extensions:
# - default: false # all extension are banned by default
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
#
# - flags:
# - {name: -w, within: []} # -w is allowed nowhere
#
# - modules:
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
#
# - functions:
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
# Add custom hints for this project
#
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
# The hints are named by the string they display in warning messages.
# For example, if you see a warning starting like
#
# Main.hs:116:51: Warning: Redundant ==
#
# You can refer to that hint with `{name: Redundant ==}` (see below).
# Turn on hints that are off by default
#
# Ban "module X(module X) where", to require a real export list
# - warn: {name: Use explicit module export list}
#
# Replace a $ b $ c with a . b $ c
# - group: {name: dollar, enabled: true}
#
# Generalise map to fmap, ++ to <>
# - group: {name: generalise, enabled: true}
# Ignore some builtin hints
# - ignore: {name: Use let}
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
# Define some custom infix operators
# - fixity: infixr 3 ~^#^~
# To generate a suitable file for HLint do:
# $ hlint --default > .hlint.yaml

View File

@@ -1,10 +1,5 @@
jobs:
include:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
- os: osx
osx_image: xcode10.1
language: generic
@@ -15,13 +10,6 @@ jobs:
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
allow_failures:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
script: ".travis/build.sh"
deploy:

View File

@@ -1,28 +1,22 @@
#!/bin/sh
#/bin/sh
set -ex
## install ghc via old ghcup
mkdir -p ~/.ghcup/bin
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ~/.ghcup/bin/ghcup
curl https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > ~/.ghcup/bin/ghcup
chmod +x ~/.ghcup/bin/ghcup
export PATH="$HOME/.ghcup/bin:$PATH"
ghcup install 8.10.4
ghcup install-cabal 3.4.0.0
ghcup set 8.10.4
ghcup install 8.8.3
ghcup install-cabal 3.2.0.0
ghcup set 8.8.3
## install ghcup
cabal update
(
cd /tmp
cabal install --installdir="$HOME"/.ghcup/bin hspec-discover
)
cabal build --constraint="zlib +static" --constraint="lzma +static" -ftui
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
strip ./ghcup
cp ghcup "./${ARTIFACT}"
cabal build -fcurl
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" "./${ARTIFACT}"

View File

@@ -1,137 +1,5 @@
# Revision history for ghcup
## 0.1.16 -- ????-??-??
* 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
* 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
* Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119)
* Prepare for hackage release
## 0.1.14 -- 2021-03-07
* Major bugfix: fix handling of stray versions wrt [#116](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116)
* Fix error messages and overhaul pretty printing wrt [#115](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/115)
## 0.1.13 -- 2021-02-26
* Support ARMv7/AARCH64
* Add command line completions for installed and available versions wrt [MR #70](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/70)
* Allow to cycle through set tools wrt [#114](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/114)
* Fix item selection with unavailable versions wrt [#107](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/107)
* Allow for dynamic post-install, post-remove and pre-compile msgs wrt [MR #68](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/68)
* Alert user if upgraded ghcup is shadowed by old ghcup wrt [#111](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/111)
* Fix to `ghcup` directory creation and placement for the XDG install mode ([MR #49](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/49))
* Do 755 permissions on executables, wrt #97
* Add [NO_COLOR](https://no-color.org/) support wrt [MR #47](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/47)
## 0.1.12 -- 2020-11-21
* Fix disappearing HLS symlinks wrt #91
* improve TUI:
- separators between tools sections
- reverse list order so latest is on top
- expand the blues selected bar
- show new latest versions in bright white
* allow configuration file and setting TUI hotkeys wrt #41
- see https://gitlab.haskell.org/haskell/ghcup-hs#configuration for a more in-depth explanation
* add a `--set` switch to `ghcup install ghc` to automatically set as default after install
* emit warnings when CC/LD is set wrt #82
* add support for version ranges in distro specifiers wrt #84
- e.g. `"(>= 19 && <= 20) || ==0.2.2"` is a valid version key for distro
## 0.1.11 -- 2020-09-23
* Add support for installing haskell-language-server, wrt #65
* When compiling GHC from source create a bindist first, store that bindist in `~/.ghcup/cache` and install it, wrt #51
* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
* simplify installing from custom bindist wrt #60
- `ghcup install ghc -u <url> <version>`
* fix bug when cabal isn't marked executable in bindist
* fix bug when `~/.ghcup` is a valid symlink wrt #49
* Drop support for compiling cabal from source (the old bootstrap script is discontinued)
## 0.1.10 -- 2020-08-14
* Show stray Cabals (useful for pre-releases or compiled ones)
## 0.1.9 -- 2020-08-14
* Fix bug when uninstalling all cabal versions
* Fix bug when setting a non-installed ghc version as current default
* Use yaml instead of generated json for download info for ease of adding new GHC versions #44
* Allow pre-release versions of GHC/cabal
* Add XDG dirs support (set `GHCUP_USE_XDG_DIRS`) wrt #39
* Allow to specify regex for tarball subdir (e.g. `ghc-.*`)
* Allow installing arbitrary bindists more seamlessly:
- e.g. installing GHC HEAD: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head`
* Avoid duplicate edits to .bashrc/.zshrc wrt #43
## 0.1.8 -- 2020-07-21
* Fix bug in logging thread dying on newlines
* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
## 0.1.7 -- 2020-07-20
* Fix a bug in libarchive not unpacking some uncleanly packed bindists
* Improved fish support in bootstrap-haskell
* Only check for upgrades when not upgrading
* Fix platform detection for i386 docker images
* Improve alpine support
- more/proper bindists
- don't fall back to glibc based bindists
- install bindists with `--disable-ld-override` to avoid ld.gold bugs
## 0.1.6 -- 2020-07-13
* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
* Support multiple installed versions of cabal #23
* Improvements to `ghcup list` (show unavailable bindists for platform)
* Fix redhat downloads #29
* Support for hadrian bindists (fixes alpine-8.10.1) #31
* Add FreeBSD bindists 8.6.5 and 8.8.3
* Fix memory leak during unpack
## 0.1.5 -- 2020-04-30
* Fix errors when PATH variable contains path components that are actually files
* Add `--version` and `--numeric-version` options
* Add `changelog` command
* Also check for available GHC and Cabal updates on start
* Add base versions as tags for every GHC version (these are "installable" tags and the latest GHC version matching the tag will be picked)
* Added `--format-raw` to list subcommand
* Allow to install X.Y versions (e.g.: ghcup install 8.8)
* Implement `--keep=<always|errors|never>` to control temporary build directories cleanup
* Add proper shell completions to the repo
* Fix building of documentation
* Allow to work in offline mode and use cached files if possible
* Allow to set the downloader via `--downloader=<curl|wget>`
* Support for compiling and installing a cross GHC (see README). This is experimental.
## 0.1.4 -- 2020-04-16
* build on all platforms with curl (as a binary), wrt https://gitlab.haskell.org/haskell/ghcup-hs/issues/6

42
Dockerfile Normal file
View File

@@ -0,0 +1,42 @@
FROM alpine:edge
# ghc and cabal
RUN apk add --no-cache \
curl \
gcc \
g++ \
gmp-dev \
ncurses-dev \
libffi-dev \
make \
xz \
tar \
perl \
\
cabal \
ghc
# utils
RUN apk add --no-cache \
bash
## Package specific
RUN apk add --no-cache \
zlib \
zlib-dev \
zlib-static \
gmp \
gmp-dev \
openssl-dev \
openssl-libs-static \
xz \
xz-dev
RUN cabal v2-update
COPY . /app
WORKDIR /app
RUN chmod +x /app/docker/build.sh

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.
@@ -39,37 +43,3 @@ Kazu Yamamoto [explained it in his PR](https://github.com/yesodweb/wai/pull/752#
1. Brittany
2. mtl-style preferred
3. no overly pointfree style
## Code structure
Main functionality is in `GHCup` module. Utility functions are
organised tree-ish in `GHCup.Utils` and `GHCup.Utils.*`.
Anything dealing with ghcup specific directories is in
`GHCup.Utils.Dirs`.
Download information on where to fetch bindists from is in the appropriate
yaml files: `ghcup-<yaml-ver>.yaml`.
## Common Tasks
### Adding a new GHC version
1. open the latest `ghcup-<yaml-ver>.yaml`
2. find the latest ghc version (in yaml tree e.g. `ghcupDownloads -> GHC -> 8.10.3`)
3. copy-paste it
4. adjust the version, tags, changelog, source url
5. adjust the various bindist urls (make sure to also change the yaml anchors)
6. run `cabal run exe:ghcup-gen -- check-tarballs -f ghcup-<yaml-ver>.yaml -u 'ghc-8\.10\.4'`
## Major refactors
1. First major refactor included adding cross support. This added
`GHCTargetVersion`, which includes the target in addition to the version.
Most of the `Version` parameters to functions had to be replaced with
that and ensured the logic is consistent for cross and non-cross
installs.
2. This refactor added windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130).
The major changes here were switching `hpath` library out for `filepath`/`directory` (sadly) and
introducing a non-unix way of handling processes via the `process` library. It also introduced considerable
amounts of CPP wrt file handling, installation etc.

122
README.md
View File

@@ -1,23 +1,16 @@
`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)
* [Simple bootstrap](#simple-bootstrap)
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Configuration](#configuration)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Env variables](#env-variables)
* [Installing custom bindists](#installing-custom-bindists)
* [Design goals](#design-goals)
* [How](#how)
* [Known users](#known-users)
@@ -41,118 +34,45 @@ Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) lik
export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
```
### Vim integration
See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## Usage
See `ghcup --help`.
For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
Common use cases are:
```sh
# list available ghc/cabal versions
ghcup list
# install the recommended GHC version
ghcup install ghc
ghcup install
# install a specific GHC version
ghcup install ghc 8.2.2
ghcup install 8.2.2
# set the currently "active" GHC version
ghcup set ghc 8.4.4
ghcup set 8.4.4
# install cabal-install
ghcup install cabal
ghcup install-cabal
# update ghcup itself
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
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.
### Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
`MANPATH` may be required to be unset.
### Shell-completion
### Bash-completion
Shell completions are in `shell-completions`.
For bash: install `shell-completions/bash`
as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros).
### Cross support
ghcup can compile and install a cross GHC for any target. However, this
requires that the build host has a complete cross toolchain and various
libraries installed for the target platform.
Consult the GHC documentation on the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#tools-to-install).
For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information.
### XDG support
To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
Then you can control the locations via XDG environment variables as such:
* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
* `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:
* `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
* `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
There are a couple of good use cases to install custom bindists:
1. manually built bindists (e.g. with patches)
- example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
2. GHC head CI bindists
- example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
3. DWARF bindists
- example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected).
Depending on your distro and setup, install `.bash-completion` from this repo
as e.g. `/etc/bash_completion.d/ghcup` and make sure your bashrc sources the
startup script (`/usr/share/bash-completion/bash_completion` on some distros).
## Design goals
@@ -182,22 +102,10 @@ In addition this script can also install `cabal-install`.
## Known users
* Github action [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
* [vabal](https://github.com/Franciman/vabal)
## Known problems
### Custom ghc version names
When installing ghc bindists with custom version names as outlined in
[installing custom bindists](#installing-custom-bindists), then cabal might
be unable to find the correct `ghc-pkg` (also see [#73](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/73))
if you use `cabal build --with-compiler=ghc-foo`. Instead, point it to the full path, such as:
`cabal build --with-compiler=$HOME/.ghcup/ghc/<version-name>/bin/ghc` or set that GHC version
as the current one via: `ghcup set ghc <version-name>`.
This problem doesn't exist for regularly installed GHC versions.
### Limited distributions supported
Currently only GNU/Linux distributions compatible with the [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries) binaries are supported.
@@ -238,8 +146,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

@@ -1,19 +1,11 @@
# RELEASING
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version.
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the JSON representation of it. The version of the json represents the change increments. `ghcUpVer` is the current application version.
2. Update version in ghcup.cabal
2. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
3. Add ChangeLog entry
3. Commit and git push with tag. Wait for tests to succeed.
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
4. Upload the new `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
6. Download release artifacts and upload them `downloads.haskell.org/ghcup`
7. Add release artifacts to yaml file (see point 4.)
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`
5. Build ghcup releases for Linux (fully static), mac (with `-fcurl`) and FreeBSD (with `-fcurl`). Upload to `webhost.haskell.org/ghcup/bin/` and update symlinks.

19
TODO.md
View File

@@ -2,19 +2,20 @@
## Now
* ghcup init?
* merge two download files
* fetch/unpack functionality
* try to run exe before upgrade (backup to ~/.ghcup/bin/ghcup.old)
* allow to build 8.8
* curl DL does not cache json
* explain environment variables
* add --keep=<always|error> option
* allow to switch to curl/wget at runtime
* cross support
* installing multiple versions of the same
* post-install
* proper test suite
* add more logging
* !! update of 0.1.5 must go in ghcup-0.0.1.json !!
* try to run exe before upgrade (backup to ~/.ghcup/bin/ghcup.old)
* stdout flushing?
* resume support (for make-install only)
## Maybe

View File

@@ -10,11 +10,13 @@
module Main where
import GHCup.Data.GHCupInfo
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Data.Char ( toLower )
import Data.Aeson ( eitherDecode, encode )
import Data.Aeson.Encode.Pretty
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
@@ -22,19 +24,51 @@ import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import Text.Regex.Posix
import Validate
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
import qualified Data.ByteString.Lazy as L
data Options = Options
{ optCommand :: Command
}
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
data Command = GenJSON GenJSONOpts
| ValidateJSON ValidateJSONOpts
| ValidateTarballs ValidateJSONOpts
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdOutput
fileOutput :: Parser Output
fileOutput =
FileOutput
<$> (strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Output to a file"
)
)
stdOutput :: Parser Output
stdOutput = flag'
StdOutput
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
outputP :: Parser Output
outputP = fileOutput <|> stdOutput
data GenJSONOpts = GenJSONOpts
{ output :: Maybe Output
, pretty :: Bool
}
genJSONOpts :: Parser GenJSONOpts
genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
(short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
)
data Input
@@ -44,10 +78,11 @@ data Input
fileInput :: Parser Input
fileInput =
FileInput
<$> strOption
<$> (strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
)
stdInput :: Parser Input
stdInput = flag'
@@ -57,71 +92,82 @@ stdInput = flag'
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateYAMLOpts = ValidateYAMLOpts
{ vInput :: Maybe Input
data ValidateJSONOpts = ValidateJSONOpts
{ input :: Maybe Input
}
validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
tarballFilterP :: Parser TarballFilter
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))
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)
_ -> fail "invalid tool"
low = fmap toLower
validateJSONOpts :: Parser ValidateJSONOpts
validateJSONOpts = ValidateJSONOpts <$> optional inputP
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
( command
( (command
"gen"
( GenJSON
<$> (info (genJSONOpts <**> helper)
(progDesc "Generate the json downloads file")
)
)
)
<> (command
"check"
( ValidateYAML
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
( ValidateJSON
<$> (info (validateJSONOpts <**> helper)
(progDesc "Validate the JSON")
)
)
<> command
)
<> (command
"check-tarballs"
(info
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
( ValidateTarballs
<$> (info
(validateJSONOpts <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
)
)
main :: IO ()
main = do
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
GenJSON gopts -> do
let bs True =
encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
bs False = encode ghcupInfo
case gopts of
GenJSONOpts { output = Nothing, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just StdOutput, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just (FileOutput file), pretty } ->
L.writeFile file (bs pretty)
ValidateJSON vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validate
ValidateTarballs vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validateTarballs
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 eitherDecode 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

@@ -1,29 +1,14 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
#if defined(TAR)
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
@@ -34,19 +19,15 @@ import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.Containers.ListUtils ( nubOrd )
import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
@@ -68,12 +49,11 @@ 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 --
-- * verify binary downloads * --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
@@ -82,7 +62,7 @@ validate dls _ = do
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)
checkHasRequiredPlatforms t v arch (M.keys pspecs)
checkGHCVerIsValid
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
@@ -96,34 +76,17 @@ validate dls _ = do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
checkHasRequiredPlatforms t v arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do
when (not $ any (== Linux UnknownLinux) pspecs) $ do
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
addError
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
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
-- (although it could be static)
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
@@ -134,7 +97,7 @@ validate dls _ = do
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) (not (isUniqueTag t) || null ts)
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
)
. group
. sort
@@ -148,8 +111,6 @@ validate dls _ = do
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
@@ -183,34 +144,30 @@ validate dls _ = do
isBase (Base _) = True
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
, tfVersion :: Regex
}
validateTarballs :: ( Monad m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, Alternative m
, MonadFail m
)
=> TarballFilter
-> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
=> GHCupDownloads
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
validateTarballs 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
-- download/verify all binary tarballs
let
dlbis = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs ->
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
forM_ dlbis $ downloadAll
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
forM_ dlsrc $ downloadAll
-- exit
e <- liftIO $ readIORef ref
@@ -221,77 +178,22 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
pure ExitSuccess
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = \_ -> pure ()
}
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 = Settings True False Never
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
}
r <-
runLogger
. flip runReaderT appstate
. flip runReaderT settings
. runResourceT
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
pure Nothing
Right _ -> do
p <- liftE $ downloadCached (settings appstate) dirs 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
. runE
$ downloadCached dli Nothing
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
lift $ $(logInfo)
[i|verifying subdir: #{prel}|]
when (basePath /= prel) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected "#{prel}", got "#{basePath}"|]
addError
Just (RegexDir regexString) -> do
lift $ $(logInfo)
[i|verifying subdir (regex): #{regexString}|]
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected regex "#{regexString}", got "#{basePath}"|]
addError
Nothing -> pure ()
VRight Nothing -> pure ()
VRight _ -> pure ()
VLeft e -> do
lift $ $(logError)
[i|Could not download (or verify hash) of #{dli}, Error was: #{prettyShow e}|]
[i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
addError

View File

@@ -1,643 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
module BrickMain where
import GHCup
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
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr
, listAttr
)
#if !defined(TAR)
import Codec.Archive
#endif
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
import Data.List
import Data.Maybe
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector
, (!?)
)
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Environment
import System.Exit
import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified GHCup.Types as GT
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
hiddenTools :: [Tool]
hiddenTools = [Stack]
data BrickData = BrickData
{ lr :: [ListResult]
}
deriving Show
data BrickSettings = BrickSettings
{ showAllVersions :: Bool
, showAllTools :: Bool
}
deriving Show
data BrickInternalState = BrickInternalState
{ clr :: Vector ListResult
, ix :: Int
}
deriving Show
data BrickState = BrickState
{ appData :: BrickData
, appSettings :: BrickSettings
, appState :: BrickInternalState
, appKeys :: KeyBindings
}
deriving Show
keyHandlers :: KeyBindings
-> [ ( Vty.Key
, BrickSettings -> String
, BrickState -> EventM n (Next BrickState)
)
]
keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction ((liftIO .) . set'))
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions
, \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)
)
, (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 }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
showKey :: Vty.Key -> String
showKey (Vty.KChar c) = [c]
showKey Vty.KUp = ""
showKey Vty.KDown = ""
showKey key = tail (show key)
ui :: AttrMap -> BrickState -> Widget String
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
= padBottom Max
( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
(center (header <=> hBorder <=> renderList' appState))
)
<=> footer
where
footer =
withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. fmap (\(key, s, _) -> showKey key <> ":" <> s as)
$ keyHandlers appKeys
header =
minHSize 2 emptyWidget
<+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
<+> minHSize 15 (str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderItem _ b listResult@ListResult{..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
| otherwise -> (withAttr "not-installed" $ str "")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim
| lNoBindist && not lInstalled
&& not b -- TODO: overloading dim and active ignores active
-- so we hack around it here
= updateAttrMap (const dimAttrs) . withAttr "no-bindist"
| otherwise = id
hooray
| elem Latest lTag && not lInstalled =
withAttr "hooray"
| otherwise = id
active = if b then forceAttr "active" else id
in hooray $ active $ dim
( marks
<+> padLeft (Pad 2)
( minHSize 6
(printTool lTool)
)
<+> minHSize 15 (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag
in padLeft (Pad 1) $ minHSize 25 $ if null l
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l
)
<+> padLeft (Pad 5)
( let notes = printNotes listResult
in if null notes
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) notes
)
<+> vLimit 1 (fill ' ')
)
printTag Recommended = Just $ withAttr "recommended" $ str "recommended"
printTag Latest = Just $ withAttr "latest" $ str "latest"
printTag Prerelease = Just $ withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal"
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
)
++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
-- | Draws the list elements.
--
-- Evaluates the underlying container up to, and a bit beyond, the
-- selected element. The exact amount depends on available height
-- for drawing and 'listItemHeight'. At most, it will evaluate up to
-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
-- available height.
drawListElements :: (Int -> Bool -> ListResult -> Widget String)
-> Bool
-> BrickInternalState
-> Widget String
drawListElements drawElem foc is@(BrickInternalState clr _) =
Widget Greedy Greedy $
let
es = clr
listSelected = fmap fst $ listSelectedElement' is
drawnElements = flip V.imap es $ \i' e ->
let addSeparator w = case es !? (i' - 1) of
Just e' | lTool e' /= lTool e ->
hBorder <=> w
_ -> w
isSelected = Just i' == listSelected
elemWidget = drawElem i' isSelected e
selItemAttr = if foc
then withDefAttr listSelectedFocusedAttr
else withDefAttr listSelectedAttr
makeVisible = if isSelected then visible . selItemAttr else id
in addSeparator $ makeVisible elemWidget
in render
$ viewport "GHCup" Vertical
$ vBox
$ V.toList drawnElements
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: AttrMap -> AttrMap -> App BrickState e String
app attrs dimAttrs =
App { appDraw = \st -> [ui dimAttrs st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const attrs
, appChooseCursor = neverShowCursor
}
defaultAttributes :: Bool -> AttrMap
defaultAttributes no_color = attrMap
Vty.defAttr
[ ("active" , Vty.defAttr `withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `withForeColor` Vty.red)
, ("set" , Vty.defAttr `withForeColor` Vty.green)
, ("installed" , Vty.defAttr `withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `withForeColor` Vty.green)
, ("hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, ("latest" , Vty.defAttr `withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `withForeColor` Vty.red)
, ("compiled" , Vty.defAttr `withForeColor` Vty.blue)
, ("stray" , Vty.defAttr `withForeColor` Vty.blue)
, ("help" , Vty.defAttr `withStyle` Vty.italic)
, ("hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
]
where
withForeColor | no_color = const
| otherwise = Vty.withForeColor
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
withStyle = Vty.withStyle
dimAttributes :: Bool -> AttrMap
dimAttributes no_color = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ ("active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
where
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st@BrickState{..} ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of
(MouseDown _ Vty.BScrollUp _ _) ->
continue (BrickState { appState = moveCursor 1 appState Up, .. })
(MouseDown _ Vty.BScrollDown _ _) ->
continue (BrickState { appState = moveCursor 1 appState Down, .. })
(VtyEvent (Vty.EvResize _ _)) -> continue st
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
continue BrickState{ appState = moveCursor 1 appState Up, .. }
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
continue BrickState{ appState = moveCursor 1 appState Down, .. }
(VtyEvent (Vty.EvKey key _)) ->
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
Nothing -> continue st
Just (_, _, handler) -> handler st
_ -> continue st
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
moveCursor steps ais@BrickInternalState{..} direction =
let newIx = if direction == Down then ix + steps else ix - steps
in case clr !? newIx of
Just _ -> BrickInternalState { ix = newIx, .. }
Nothing -> ais
-- | 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))
-> 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
-- | Update app data and list internal state based on new evidence.
-- This synchronises @BrickInternalState@ with @BrickData@
-- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState
updateList appD BrickState{..} =
let newInternalState = constructList appD appSettings (Just appState)
in BrickState { appState = newInternalState
, appData = appD
, appSettings = appSettings
, appKeys = appKeys
}
constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int
selectLatest v =
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
Just ix -> ix
Nothing -> 0
-- | Replace the @appState@ or construct it based on a filter function
-- and a new @[ListResult]@ evidence.
-- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool)
-> [ListResult]
-> Maybe BrickInternalState
-> BrickInternalState
replaceLR filterF lr s =
let oldElem = s >>= listSelectedElement'
newVec = V.fromList . filter filterF $ lr
newSelected =
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
Just ix -> ix
Nothing -> selectLatest newVec
in BrickInternalState newVec newSelected
where
toolEqual e1 e2 =
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)
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'
let runLogger = myLoggerT l
let run =
runLogger
. runResourceT
. runE
@'[ AlreadyInstalled
#if !defined(TAR)
, ArchiveResult
#endif
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate
, TarDirDoesNotExist
]
run (do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> 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
)
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{prettyShow e}
Also check the logs in ~/.ghcup/logs|]
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
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'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
case lTool of
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
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
pure $ Right ()
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
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e
settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getDirs
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, urlSource = GHCupURL
, ..
})
dirs
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState
-> LoggerConfig
-> GHCupInfo
-> IO ()
brickMain s l gi = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just gi)
case eAppData of
Right ad ->
defaultMain
(app (defaultAttributes no_color) (dimAttributes no_color))
(BrickState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings s)
)
$> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF (GT.settings settings) (GT.dirs settings)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
runLogger . flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)

File diff suppressed because it is too large Load Diff

View File

@@ -1,353 +1,124 @@
#!/bin/sh
# Main settings:
# * BOOTSTRAP_HASKELL_NONINTERACTIVE - any nonzero value for noninteractive installation
# * BOOTSTRAP_HASKELL_NO_UPGRADE - any nonzero value to not trigger the upgrade
# * GHCUP_USE_XDG_DIRS - any nonzero value to respect The XDG Base Directory Specification
# * BOOTSTRAP_HASKELL_VERBOSE - any nonzero value for more verbose installation
# * BOOTSTRAP_HASKELL_GHC_VERSION
# * BOOTSTRAP_HASKELL_CABAL_VERSION
# License: LGPL-3.0
# 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"
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
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
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
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() {
edo()
{
"$@" || die "\"$*\" failed!"
}
eghcup() {
edo _eghcup "$@"
}
_eghcup() {
if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then
args="-s ${BOOTSTRAP_HASKELL_YAML}"
fi
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
"${GHCUP_BIN}/ghcup" ${args} "$@"
edo ghcup "$@"
else
"${GHCUP_BIN}/ghcup" ${args} --verbose "$@"
edo 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
exit 0
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
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}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${base_url}/${ghver}/x86_64-linux-ghcup-${ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
_url=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4
;;
i*86)
_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
_url=https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4
;;
armv7*)
_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
;;
aarch64|arm64|armv8l)
_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=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-portbld-freebsd-ghcup-0.1.4
;;
"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=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-apple-darwin-ghcup-0.1.4 ;;
*) 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 mkdir -p "${GHCUP_DIR}"
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_DIR}"/env
eghcup upgrade
}
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
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
}
echo
echo "Welcome to Haskell!"
echo
echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer"
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 "This will download and install the Glasgow Haskell Compiler (GHC)"
echo "and 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
else
echo "ghcup installs into XDG directories as long as"
echo "'GHCUP_USE_XDG_DIRS' is set."
fi
echo "ghcup installs only into the following directory, which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
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"
printf "\\033[0;35m%s\\033[0m\\n" "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
read -r answer </dev/tty
fi
edo mkdir -p "${GHCUP_BIN}"
edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
if command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
_eghcup upgrade || download_ghcup
eghcup upgrade
fi
else
download_ghcup
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
eghcup upgrade
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"
printf "\\033[0;35m%s\\033[0m\\n" "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.
@@ -355,129 +126,76 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
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
eghcup --cache install
eghcup set
eghcup --cache install-cabal
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 ""
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
while true; do
read -r hls_answer </dev/tty
case $SHELL in
*/zsh) # login shell is zsh
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh" ;;
*/bash) # login shell is bash
if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
GHCUP_PROFILE_FILE="$HOME/.bashrc"
else
GHCUP_PROFILE_FILE="$HOME/.bash_profile"
fi
case $hls_answer in
[Yy]*)
_eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
break ;;
[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."
;;
esac
done
MY_SHELL="bash" ;;
*/sh) # login shell is sh, but might be a symlink to bash or zsh
if [ -n "${BASH}" ] ; then
if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
GHCUP_PROFILE_FILE="$HOME/.bashrc"
else
GHCUP_PROFILE_FILE="$HOME/.bash_profile"
fi
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 ""
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
MY_SHELL="bash"
elif [ -n "${ZSH_VERSION}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh"
else
exit 0
fi
;;
esac
*) exit 0 ;;
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]*)
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
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_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
exit 0;;
[Nn]*)
exit 0;;
*)
echo "Please type YES or NO and press enter.";;
esac
done
fi
)
# vim: tabstop=4 shiftwidth=4 expandtab

View File

@@ -1,431 +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'
$elevated = ([Security.Principal.WindowsPrincipal] `
[Security.Principal.WindowsIdentity]::GetCurrent()
).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)
if ($elevated) {
Print-Msg -color Yellow -msg ('This script should not be run as administrator/elevated. Waiting 10s before continuing anyway...')
Start-Sleep -s 10
}
$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,20 +0,0 @@
packages: ./ghcup.cabal
with-compiler: ghc-8.10.4
optional-packages: ./3rdparty/*/*.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
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1,261 +0,0 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.2.1.0,
any.HUnit ==1.6.2.0,
any.IfElse ==0.85,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.1,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.ascii-string ==1.0.1.4,
any.assoc ==1.0.2,
any.async ==2.2.3,
async -bench,
any.atomic-primops ==0.8.4,
atomic-primops -debug,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.14.1.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
any.base-orphans ==0.8.4,
any.base16-bytestring ==1.0.1.0,
any.base64-bytestring ==1.2.0.1,
any.bifunctors ==5.5.10,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.blaze-builder ==0.4.2.1,
any.bytestring ==0.10.12.0,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.c2hs ==0.28.7,
c2hs +base3 -regression,
any.call-stack ==0.3.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.5,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.containers ==0.6.2.1,
any.contravariant ==1.5.3,
contravariant +semigroups +statevar +tagged,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.deepseq ==1.4.4.0,
any.deferred-folds ==0.9.17,
any.directory ==1.3.6.0,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
any.fast-logger ==3.0.3,
any.filepath ==1.4.2.1,
any.focus ==1.0.2,
any.foldl ==1.4.11,
any.free ==5.1.6,
any.fusion-plugin-types ==0.1.0,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-boot-th ==8.10.4,
any.ghc-prim ==0.6.1,
ghcup -internal-downloader -tar -tui,
any.happy ==1.20.0,
any.hashable ==1.3.1.0,
hashable +integer-gmp,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.heaps ==0.3.6.1,
any.hpath ==0.11.0,
any.hpath-directory ==0.14.1,
any.hpath-filepath ==0.10.4,
any.hpath-io ==0.14.1,
any.hpath-posix ==0.13.2,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.8,
any.hspec-core ==2.7.8,
any.hspec-discover ==2.7.8,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.7.0.0,
any.indexed-profunctors ==0.1,
any.indexed-traversable ==0.1.1,
any.indexed-traversable-instances ==0.1,
any.integer-gmp ==1.0.3.0,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.language-c ==0.8.3,
language-c -allwarnings +iecfpextension +separatesyb +usebytestrings,
any.libarchive ==3.0.2.1,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.list-t ==1.0.4,
any.lockfree-queue ==0.2.3.1,
lzma -static,
any.math-functions ==0.3.4.1,
math-functions +system-erf +system-expm1,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.9,
any.mmorph ==1.1.5,
any.monad-control ==1.0.2.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.mwc-random ==0.15.0.1,
any.network ==3.1.2.1,
network -devel,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
os-release -devel,
any.parallel ==3.2.2.0,
any.parsec ==3.1.14.0,
any.parser-combinators ==1.3.0,
parser-combinators -dev,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.primitive-extras ==0.8.2,
any.primitive-unlifted ==0.1.3.0,
any.process ==1.6.9.0,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0,
any.random ==1.2.0,
any.recursion-schemes ==5.2.2,
recursion-schemes +template-haskell,
any.regex-posix ==0.96.0.0,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.rts ==1.0,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.1,
any.scientific ==0.3.6.2,
scientific -bytestring-builder -integer-simple,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.streamly ==0.7.3,
streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-fusion -streamk,
any.streamly-bytestring ==0.1.2,
any.streamly-posix ==0.1.0.1,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.0,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.3.1,
tasty +clock,
any.tasty-hunit ==0.10.0.3,
any.tasty-quickcheck ==0.10.1.2,
any.template-haskell ==2.16.0.0,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-conversions ==0.3.1,
any.text-short ==0.1.3,
text-short -asserts,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.1,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.5,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
transformers-base +orphaninstances,
any.transformers-compat ==0.6.6,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.13.0,
unordered-containers -debug,
any.uri-bytestring ==0.3.3.0,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.2,
any.uuid-types ==1.0.4,
any.vector ==0.12.2.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==4.0.3,
any.vty ==5.33,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.word8 ==0.1.3,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
zlib -non-blocking-ffi -pkg-config -static
index-state: hackage.haskell.org 2021-03-07T18:36:25Z

View File

@@ -1,20 +0,0 @@
packages: ./ghcup.cabal
with-compiler: ghc-8.8.4
optional-packages: ./3rdparty/*/*.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
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1,262 +0,0 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.0.1.0,
any.HUnit ==1.6.2.0,
any.IfElse ==0.85,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.1,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.ascii-string ==1.0.1.4,
any.assoc ==1.0.2,
any.async ==2.2.3,
async -bench,
any.atomic-primops ==0.8.4,
atomic-primops -debug,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.13.0.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
any.base-orphans ==0.8.4,
any.base16-bytestring ==1.0.1.0,
any.base64-bytestring ==1.2.0.1,
any.bifunctors ==5.5.10,
bifunctors +semigroups +tagged,
any.binary ==0.8.7.0,
any.blaze-builder ==0.4.2.1,
any.bytestring ==0.10.10.1,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.c2hs ==0.28.7,
c2hs +base3 -regression,
any.call-stack ==0.3.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.5,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.containers ==0.6.2.1,
any.contravariant ==1.5.3,
contravariant +semigroups +statevar +tagged,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.deepseq ==1.4.4.0,
any.deferred-folds ==0.9.17,
any.directory ==1.3.6.0,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
exceptions +transformers-0-4,
any.fast-logger ==3.0.3,
any.filepath ==1.4.2.1,
any.focus ==1.0.2,
any.foldl ==1.4.11,
any.free ==5.1.6,
any.fusion-plugin-types ==0.1.0,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-boot-th ==8.8.4,
any.ghc-prim ==0.5.3,
ghcup -internal-downloader -tar -tui,
any.happy ==1.20.0,
any.hashable ==1.3.1.0,
hashable +integer-gmp,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.heaps ==0.3.6.1,
any.hpath ==0.11.0,
any.hpath-directory ==0.14.1,
any.hpath-filepath ==0.10.4,
any.hpath-io ==0.14.1,
any.hpath-posix ==0.13.2,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.8,
any.hspec-core ==2.7.8,
any.hspec-discover ==2.7.8,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.7.0.0,
any.indexed-profunctors ==0.1,
any.indexed-traversable ==0.1.1,
any.indexed-traversable-instances ==0.1,
any.integer-gmp ==1.0.2.0,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.language-c ==0.8.3,
language-c -allwarnings +iecfpextension +separatesyb +usebytestrings,
any.libarchive ==3.0.2.1,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.list-t ==1.0.4,
any.lockfree-queue ==0.2.3.1,
lzma -static,
any.math-functions ==0.3.4.1,
math-functions +system-erf +system-expm1,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.9,
any.mmorph ==1.1.5,
any.monad-control ==1.0.2.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.mwc-random ==0.15.0.1,
any.network ==3.1.2.1,
network -devel,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
os-release -devel,
any.parallel ==3.2.2.0,
any.parsec ==3.1.14.0,
any.parser-combinators ==1.3.0,
parser-combinators -dev,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.primitive-extras ==0.8.2,
any.primitive-unlifted ==0.1.3.0,
any.process ==1.6.9.0,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0,
any.random ==1.2.0,
any.recursion-schemes ==5.2.2,
recursion-schemes +template-haskell,
any.regex-posix ==0.96.0.0,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.rts ==1.0,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.1,
any.scientific ==0.3.6.2,
scientific -bytestring-builder -integer-simple,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.streamly ==0.7.3,
streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-fusion -streamk,
any.streamly-bytestring ==0.1.2,
any.streamly-posix ==0.1.0.1,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.0,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.3.1,
tasty +clock,
any.tasty-hunit ==0.10.0.3,
any.tasty-quickcheck ==0.10.1.2,
any.template-haskell ==2.15.0.0,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.0,
any.text-conversions ==0.3.1,
any.text-short ==0.1.3,
text-short -asserts,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.1,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.5,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
transformers-base +orphaninstances,
any.transformers-compat ==0.6.6,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.13.0,
unordered-containers -debug,
any.uri-bytestring ==0.3.3.0,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.2,
any.uuid-types ==1.0.4,
any.vector ==0.12.2.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==4.0.3,
any.vty ==5.33,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.word8 ==0.1.3,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
zlib -non-blocking-ffi -pkg-config -static
index-state: hackage.haskell.org 2021-03-07T18:36:25Z

View File

@@ -1,26 +1,16 @@
packages: ./ghcup.cabal
optional-packages: ./vendored/*/*.cabal
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
tests: True
flags: +tui
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
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
package tar-bytestring
ghc-options: -O2
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell, language-c
allow-newer: base

View File

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

View File

@@ -1,63 +0,0 @@
# Cache downloads in ~/.ghcup/cache
cache: False
# Skip tarball checksum verification
no-verify: False
# enable verbosity
verbose: False
# When to keep build directories
keep-dirs: Errors # Always | Never | Errors
# Which downloader to use
downloader: Curl # Curl | Wget | Internal
# TUI key bindings,
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
# for possible values.
key-bindings:
up:
KUp: []
down:
KDown: []
quit:
KChar: 'q'
install:
KChar: 'i'
uninstall:
KChar: 'u'
set:
KChar: 's'
changelog:
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.
url-source:
## Use the internal download uri, this is the default
GHCupURL: []
## Example 1: Read download info from this location instead
## Accepts file/http/https scheme
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
# AddSource:
# Left:
# toolRequirements: {} # this is ignored
# ghcupDownloads:
# GHC:
# 9.10.2:
# viTags: []
# viArch:
# A_64:
# Linux_UnknownLinux:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
# dlSubdir: ghc-7.10.3
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
# AddSource:
# Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

14
docker/build.sh Normal file
View File

@@ -0,0 +1,14 @@
#!/bin/sh
set -ex
cd /app
cabal v2-update
cabal v2-install \
--install-method=copy \
--overwrite-policy=always \
--installdir="/bin" \
--ghc-options='-optl-static'

2179
ghcup-0.0.1.json Normal file

File diff suppressed because it is too large Load Diff

2251
ghcup-0.0.2.json Normal file

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,55 +1,284 @@
cabal-version: 3.0
name: ghcup
version: 0.1.15.2
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
maintainer: hasufell@posteo.de
author: Julian Ospald
homepage: https://gitlab.haskell.org/haskell/ghcup-hs
bug-reports: https://gitlab.haskell.org/haskell/ghcup-hs/issues
synopsis: ghc toolchain installer
cabal-version: 3.0
name: ghcup
version: 0.1.4
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
a more stable user experience and exposing an API.
category: System
build-type: Simple
extra-doc-files:
CHANGELOG.md
config.yaml
ghcup-0.0.4.yaml
ghcup-0.0.5.yaml
HACKING.md
README.md
RELEASING.md
homepage: https://gitlab.haskell.org/haskell/ghcup-hs
bug-reports: https://gitlab.haskell.org/haskell/ghcup-hs/issues
license: LGPL-3.0-only
license-file: LICENSE
author: Julian Ospald
maintainer: hasufell@posteo.de
copyright: Julian Ospald 2020
category: System
build-type: Simple
extra-source-files: CHANGELOG.md
source-repository head
type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui
description:
Build the brick powered tui (ghcup tui). This is disabled on windows.
flag Curl
description: Use curl instead of http-io-streams for download
default: False
manual: True
flag internal-downloader
description:
Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
common HsOpenSSL
build-depends: HsOpenSSL >=0.11.4.18
default: False
manual: True
common aeson
build-depends: aeson >=1.4
flag tar
description: Use tar-bytestring instead of libarchive.
default: False
manual: True
common aeson-pretty
build-depends: aeson-pretty >=0.8.8
common ascii-string
build-depends: ascii-string >=1.0
common async
build-depends: async >=0.8
common base
build-depends: base >=4.12 && <5
common base16-bytestring
build-depends: base16-bytestring >= 0.1.1.6
common binary
build-depends: binary >=0.8.6.0
common bytestring
build-depends: bytestring >=0.10
common bz2
build-depends: bz2 >=0.5.0.5
common case-insensitive
build-depends: case-insensitive >=1.2.1.0
common concurrent-output
build-depends: concurrent-output >=1.10.11
common containers
build-depends: containers >=0.6
common cryptohash-sha256
build-depends: cryptohash-sha256 >= 0.11.101.0
common generics-sop
build-depends: generics-sop >=0.5
common haskus-utils-types
build-depends: haskus-utils-types >=1.5
common haskus-utils-variant
build-depends: haskus-utils-variant >=3.0
common hpath
build-depends: hpath >=0.11
common hpath-directory
build-depends: hpath-directory >=0.13.3
common hpath-filepath
build-depends: hpath-filepath >=0.10.3
common hpath-io
build-depends: hpath-io >=0.13.1
common hpath-posix
build-depends: hpath-posix >=0.13.2
common http-io-streams
build-depends: http-io-streams >=0.1.2.0
common io-streams
build-depends: io-streams >=1.5
common language-bash
build-depends: language-bash >=0.9
common lzma
build-depends: lzma >=0.0.0.3
common megaparsec
build-depends: megaparsec >=8.0.0
common monad-logger
build-depends: monad-logger >=0.3.31
common mtl
build-depends: mtl >=2.2
common optics
build-depends: optics >=0.2
common optics-vl
build-depends: optics-vl >=0.2
common optparse-applicative
build-depends: optparse-applicative >=0.15.1.0
common parsec
build-depends: parsec >=3.1
common pretty-terminal
build-depends: pretty-terminal >=0.1.0.0
common regex-posix
build-depends: regex-posix >=0.96
common resourcet
build-depends: resourcet >=1.2.2
common safe
build-depends: safe >=0.3.18
common safe-exceptions
build-depends: safe-exceptions >=0.1
common streamly
build-depends: streamly >=0.7.1
common streamly-posix
build-depends: streamly-posix >=0.1.0.0
common streamly-bytestring
build-depends: streamly-bytestring >=0.1.2
common strict-base
build-depends: strict-base >=0.4
common string-interpolate
build-depends: string-interpolate >=0.2.0.0
common table-layout
build-depends: table-layout >=0.8
common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1
common template-haskell
build-depends: template-haskell >=2.7
common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1
common text
build-depends: text >=1.2
common time
build-depends: time >=1.9.3
common transformers
build-depends: transformers >=0.5
common unix
build-depends: unix >=2.7
common unix-bytestring
build-depends: unix-bytestring >=0.3
common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2
common utf8-string
build-depends: utf8-string >=1.0
common vector
build-depends: vector >=0.12
common versions
build-depends: versions >=3.5
common waargonaut
build-depends: waargonaut >=0.8
common word8
build-depends: word8 >=0.1.3
common zlib
build-depends: zlib >=0.6.2.1
common config
default-language: Haskell2010
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
default-extensions:
LambdaCase
MultiWayIf
PackageImports
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
library
import:
config
, base
, base16-bytestring
, aeson
, ascii-string
, async
, binary
, bytestring
, bz2
, case-insensitive
, concurrent-output
, containers
, cryptohash-sha256
, generics-sop
, haskus-utils-types
, haskus-utils-variant
, hpath
, hpath-directory
, hpath-filepath
, hpath-io
, hpath-posix
, language-bash
, lzma
, megaparsec
, monad-logger
, mtl
, optics
, optics-vl
, parsec
, pretty-terminal
, regex-posix
, resourcet
, safe
, safe-exceptions
, streamly
, streamly-posix
, streamly-bytestring
, strict-base
, string-interpolate
, tar-bytestring
, template-haskell
, text
, time
, transformers
, unix
, unix-bytestring
, uri-bytestring
, utf8-string
, vector
, versions
, word8
, zlib
exposed-modules:
GHCup
GHCup.Data.GHCupDownloads
GHCup.Data.GHCupInfo
GHCup.Data.ToolRequirements
GHCup.Download
GHCup.Download.Utils
GHCup.Errors
@@ -59,9 +288,9 @@ library
GHCup.Types.JSON
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.File.Common
GHCup.Utils.Logger
GHCup.Utils.MegaParsec
GHCup.Utils.Prelude
@@ -69,271 +298,91 @@ library
GHCup.Utils.Version.QQ
GHCup.Version
hs-source-dirs: lib
other-modules: Paths_ghcup
autogen-modules: Paths_ghcup
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
-- other-modules:
-- other-extensions:
hs-source-dirs: lib
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates
build-depends:
, aeson >=1.4 && <1.6
, 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
, 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
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics >=0.2 && <0.5
, optics-vl ^>=0.2
, os-release ^>=1.0.0
, parsec ^>=3.1
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, split ^>=0.2.3.4
, strict-base ^>=0.4
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, temporary ^>=1.3
, text ^>=1.2.4.0
, time ^>=1.9.3
, transformers ^>=0.5
, 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
, 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(curl)
import:
, HsOpenSSL
, http-io-streams
, io-streams
, terminal-progress-bar
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
, terminal-progress-bar >=0.4.1
if flag(tar)
cpp-options: -DTAR
build-depends: tar
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
cpp-options: -DCURL
executable ghcup
main-is: Main.hs
hs-source-dirs: app/ghcup
default-language: Haskell2010
default-extensions:
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
import:
config
, base
, bytestring
, containers
, haskus-utils-variant
, hpath
, hpath-io
, megaparsec
, monad-logger
, mtl
, optparse-applicative
, pretty-terminal
, resourcet
, safe
, string-interpolate
, table-layout
, template-haskell
, text
, uri-bytestring
, utf8-string
, versions
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
--
main-is: Main.hs
build-depends:
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, filepath ^>=1.4.2.1
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, string-interpolate >=0.2.0.0 && <0.4
, template-haskell >=2.7 && <2.18
, text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions >=4.0.1 && <5.1
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if (flag(tui) && !os(windows))
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
if flag(tar)
cpp-options: -DTAR
else
build-depends: libarchive ^>=3.0.0.0
-- other-modules:
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app/ghcup
default-language: Haskell2010
executable ghcup-gen
main-is: Main.hs
hs-source-dirs: app/ghcup-gen
other-modules: Validate
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
import:
config
, base
, aeson
, aeson-pretty
, bytestring
, containers
, haskus-utils-variant
, hpath
, monad-logger
, mtl
, optics
, optparse-applicative
, pretty-terminal
, resourcet
, safe-exceptions
, string-interpolate
, table-layout
, text
, transformers
, uri-bytestring
, utf8-string
, versions
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
--
main-is: Main.hs
other-modules:
Validate
build-depends:
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, filepath ^>=1.4.2.1
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics >=0.2 && <0.5
, optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, safe-exceptions ^>=0.1
, string-interpolate >=0.2.0.0 && <0.4
, text ^>=1.2.4.0
, transformers ^>=0.5
, uri-bytestring ^>=0.3.2.2
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
if flag(tar)
cpp-options: -DTAR
build-depends: tar
else
build-depends: libarchive ^>=3.0.0.0
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app/ghcup-gen
default-language: Haskell2010
test-suite ghcup-test
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs: test
other-modules:
GHCup.ArbitraryTypes
GHCup.Types.JSONSpec
Spec
default-language: Haskell2010
default-extensions:
LambdaCase
MultiWayIf
PackageImports
RecordWildCards
ScopedTypeVariables
TupleSections
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates
build-depends:
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, generic-arbitrary ^>=0.1.0
, ghcup
, hspec ^>=2.7.10
, hspec-golden-aeson ^>=0.9
, 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
default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: MyLibTest.hs
build-depends: base >=4.12.0.0

File diff suppressed because it is too large Load Diff

View File

@@ -1,10 +0,0 @@
cradle:
cabal:
- component: "ghcup:lib:ghcup"
path: ./lib
- component: "ghcup:exe:ghcup"
path: ./app/ghcup
- component: "ghcup:exe:ghcup-gen"
path: "./app/ghcup-gen"
- component: "ghcup:test:ghcup-test"
path: ./test

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,11 @@
module GHCup.Data.GHCupInfo where
import GHCup.Data.GHCupDownloads
import GHCup.Data.ToolRequirements
import GHCup.Types
ghcupInfo :: GHCupInfo
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
, _ghcupDownloads = ghcupDownloads
}

View File

@@ -0,0 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Data.ToolRequirements where
import GHCup.Types
import GHCup.Utils.String.QQ
import qualified Data.Map as M
-- | Currently 'GHC' is used for both GHC and cabal to simplify
-- this, until we need actual separation.
toolRequirements :: ToolRequirements
toolRequirements = M.fromList
[ ( GHC
, M.fromList
[ ( Nothing
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, Requirements
[]
[s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
)
]
)
, ( Linux Alpine
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "g++"
, "gmp-dev"
, "ncurses-dev"
, "libffi-dev"
, "make"
, "xz"
, "tar"
, "perl"
]
""
)
]
)
, ( Linux Ubuntu
, M.fromList
[ ( Nothing
, Requirements
[ "build-essential"
, "curl"
, "libgmp-dev"
, "libffi-dev"
, "libncurses-dev"
, "libtinfo5"
]
""
)
]
)
, ( Darwin
, M.fromList
[ ( Nothing
, Requirements
[]
"On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
)
]
)
, ( FreeBSD
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "gmp"
, "gmake"
, "ncurses"
, "perl5"
, "libffi"
, "libiconv"
]
""
)
]
)
]
)
]
)
]

View File

@@ -9,26 +9,9 @@
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Module for handling all download related functions.
Generally we support downloading via:
- curl (default)
- wget
- internal downloader (only when compiled)
-}
module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER)
#if !defined(CURL)
import GHCup.Download.IOStreams
import GHCup.Download.Utils
#endif
@@ -36,7 +19,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
@@ -52,45 +35,42 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
#if !defined(CURL)
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
#endif
import Data.List.Extra
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
import Data.Time.Clock.POSIX
#if defined(INTERNAL_DOWNLOADER)
#if !defined(CURL)
import Data.Time.Format
#endif
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO
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 URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as B
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)
#if !defined(CURL)
import qualified Data.CaseInsensitive as CI
#endif
import qualified Data.Map.Strict as M
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
@@ -102,80 +82,30 @@ import qualified Data.Yaml as Y
------------------
-- | Downloads the download information! But only if we need to ;P
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
)
=> Settings
-> Dirs
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF settings@Settings{ urlSource } dirs = do
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
)
=> URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
getDownloads urlSource = do
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
GHCupURL -> liftE $ getBase dirs settings
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE $ getBase dirs settings
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE $ getBase dirs settings
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
where
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
Just a' -> M.union a' a
Nothing -> a
) base
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache Dirs {..} = do
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError yaml_file)
$ liftIO
$ L.readFile yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Settings
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } =
handleIO (\_ -> readFromCache dirs)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache dirs)
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where
where
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it.
@@ -186,11 +116,7 @@ getBase dirs@Dirs{..} Settings{ downloader } =
--
-- Always save the local file with the mod time of the remote file.
smartDl :: forall m1
. ( MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
)
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
=> URI
-> Excepts
'[ FileDoesNotExistError
@@ -205,51 +131,48 @@ getBase dirs@Dirs{..} Settings{ downloader } =
L.ByteString
smartDl uri' = do
let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
cacheDir <- liftIO $ ghcupCacheDir
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
then do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
else liftIO $ readFile json_file
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
dlWithoutMod json_file
liftIO $ deleteFile json_file
liftE $ downloadBS uri'
else -- access in less than 5 minutes, re-use file
liftIO $ L.readFile json_file
liftIO $ readFile json_file
else do
liftIO $ createDirIfMissing newDirPerms cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Just modTime -> do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
Nothing -> do
-- although we don't know last-modified, we still save
-- it to a file, so we might use it in offline mode
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
dlWithoutMod json_file
liftE $ downloadBS uri'
where
dlWithMod modTime json_file = do
bs <- liftE $ downloadBS downloader 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))
pure bs
getModTime = do
#if !defined(INTERNAL_DOWNLOADER)
#if defined(CURL)
pure Nothing
#else
headers <-
@@ -273,10 +196,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
@@ -288,11 +212,7 @@ getDownloadInfo :: Tool
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
(Left NoDownload)
Right
(case p of
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro
)
(with_distro <|> without_distro_ver <|> without_distro)
where
with_distro = distro_preview id id
@@ -300,18 +220,7 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
distro_preview f g =
let platformVersionSpec =
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
mv' = g mv
in fmap snd
. find
(\(mverRange, _) -> maybe
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
=<< platformVersionSpec
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
-- | Tries to download from the given http or https url
@@ -322,16 +231,16 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
--
-- The file must not exist.
download :: ( MonadMask m
, MonadReader Settings 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
@@ -341,48 +250,41 @@ download settings@Settings{ downloader } dli dest mfn
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
let destFile = getDestFile
let fromFile = T.unpack . decUTF8Safe $ path
liftIO $ copyFile fromFile destFile
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
pure destFile
dl = do
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
-- destination dir must exist
liftIO $ createDirRecursive' dest
let destFile = getDestFile
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
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
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ 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
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
liftE $ downloadToFile https host fullPath port destFile
#if defined(CURL)
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
["-fL", "-o", toFilePath destFile , serializeURIRef' $ view dlUri dli] Nothing Nothing
#else
(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
@@ -394,41 +296,27 @@ downloadCached :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadReader Settings 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
cachedir <- liftIO $ ghcupCacheDir
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 +329,8 @@ downloadCached' settings Dirs{..} dli mfn = do
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
=> Downloader
-> URI
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
@@ -455,83 +342,46 @@ 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
where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
#if defined(INTERNAL_DOWNLOADER)
dl https = do
#else
#if defined(CURL)
dl _ = do
#endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
case downloader of
Curl -> do
o' <- liftIO getCurlOpts
let exe = "curl"
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
Wget -> do
o' <- liftIO getWgetOpts
let exe = "wget"
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
let exe = [rel|curl|]
args = ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
#else
dl https = do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
#endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Settings
-> DownloadInfo
-> FilePath
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings 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)
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 =
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [String]
getWgetOpts =
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False

View File

@@ -1,6 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -24,6 +28,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 +37,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
@@ -63,7 +72,7 @@ downloadBS' :: MonadIO m
, TooManyRedirs
]
m
L.ByteString
(L.ByteString)
downloadBS' https host path port = do
bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
@@ -76,12 +85,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
@@ -123,7 +132,7 @@ downloadInternal = go (5 :: Int)
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Just r'
Just r' -> pure $ Just $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
@@ -142,7 +151,7 @@ downloadInternal = go (5 :: Int)
Nothing -> 0
mpb <- if progressBar
then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream
@@ -215,9 +224,9 @@ headInternal = go (5 :: Int)
if
| scode >= 200 && scode < 300 -> do
let headers = getHeaderMap r
pure $ Right headers
pure $ Right $ headers
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Left r'
Just r' -> pure $ Left $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
@@ -234,7 +243,7 @@ withConnection' :: Bool
-> Maybe Int
-> (Connection -> IO a)
-> IO a
withConnection' https host port = bracket acquire closeConnection
withConnection' https host port action = bracket acquire closeConnection action
where
acquire = case https of

View File

@@ -1,6 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -51,7 +55,7 @@ uriToQuadruple URI {..} = do
let queryBS =
BS.intercalate "&"
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
$ queryPairs uriQuery
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS

View File

@@ -1,39 +1,18 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-|
Module : GHCup.Errors
Description : GHCup error types
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Errors where
import GHCup.Types
#if !defined(TAR)
import Codec.Archive
#else
import qualified Codec.Archive.Tar as Tar
#endif
import Control.Exception.Safe
import Data.String.Interpolate
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
import URI.ByteString
import HPath
@@ -47,213 +26,100 @@ import URI.ByteString
data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
deriving Show
instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
-- | Unable to find a download for the requested versio/distro.
data NoDownload = NoDownload
deriving Show
instance Pretty NoDownload where
pPrint NoDownload =
text "Unable to find a download for the requested version/distro."
-- | No update available or necessary.
data NoUpdate = NoUpdate
deriving Show
instance Pretty NoUpdate where
pPrint NoUpdate = text "No update available or necessary."
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String
deriving Show
instance Pretty NoCompatibleArch where
pPrint (NoCompatibleArch arch) =
text ("The Architecture is unknown or unsupported. Got: " ++ arch)
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound
deriving Show
instance Pretty DistroNotFound where
pPrint DistroNotFound =
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}"|]
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show
instance Pretty UnsupportedScheme where
pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
-- | Unable to copy a file.
data CopyError = CopyError String
deriving Show
instance Pretty CopyError where
pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason)
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|]
-- | Unable to find the next version of a tool (the one after the currently
-- set one).
data NextVerNotFound = NextVerNotFound Tool
deriving Show
instance Pretty NextVerNotFound where
pPrint (NextVerNotFound tool) =
text [i|Unable to find next (the one after the currently set one) version of tool "#{tool}"|]
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show
instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') =
text [i|#{tool}-#{prettyShow ver'} is already installed|]
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool GHCTargetVersion
data NotInstalled = NotInstalled Tool Text
deriving Show
instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
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.|]
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
instance Pretty JSONError where
pPrint (JSONDecodeError err) =
text [i|JSON decoding failed with: #{err}|]
-- | 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.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
instance Pretty TarDirDoesNotExist where
pPrint (TarDirDoesNotExist dir) =
text "Tar directory does not exist:" <+> pPrint dir
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show
instance Pretty DigestError where
pPrint (DigestError currentDigest expectedDigest) =
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int
deriving Show
instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status) =
text [i|Unexpected HTTP status: #{status}|]
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text [i|The 'Location' header was expected during a 3xx redirect, but not found.|]
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text [i|Too many redirections.|]
-- | A patch could not be applied.
data PatchFailed = PatchFailed
deriving Show
instance Pretty PatchFailed where
pPrint PatchFailed =
text [i|A patch could not be applied.|]
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
deriving Show
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text [i|The Tool requirements could not be found.|]
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text [i|The build config is invalid. Reason was: #{reason}|]
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text [i|No version is set for tool "#{tool}".|]
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall x xs . (Show x, Show (V xs), Pretty x, Pretty (V xs)) => DownloadFailed (V (x ': xs))
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
text "Download failed:" <+> pPrint reason
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{path}": #{reason}|]
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
deriving instance Show BuildFailed
@@ -261,10 +127,6 @@ deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
text [i|Setting the current GHC version failed: #{reason}|]
deriving instance Show GHCupSetError
@@ -277,75 +139,4 @@ deriving instance Show GHCupSetError
data ParseError = ParseError String
deriving Show
instance Pretty ParseError where
pPrint (ParseError reason) =
text [i|Parsing failed: #{reason}|]
instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String
deriving Show
instance Pretty UnexpectedListLength where
pPrint (UnexpectedListLength reason) =
text [i|List length unexpected: #{reason}|]
instance Exception UnexpectedListLength
------------------------
--[ orphan instances ]--
------------------------
instance Pretty (V '[]) where
{-# INLINABLE pPrint #-}
pPrint _ = undefined
instance
( Pretty x
, Pretty (V xs)
) => Pretty (V (x ': xs))
where
pPrint v = case popVariantHead v of
Right x -> pPrint x
Left xs -> pPrint xs
instance Pretty URIParseError where
pPrint (MalformedScheme reason) =
text [i|Failed to parse URI. Malformed scheme: #{reason}|]
pPrint MalformedUserInfo =
text [i|Failed to parse URI. Malformed user info.|]
pPrint MalformedQuery =
text [i|Failed to parse URI. Malformed query.|]
pPrint MalformedFragment =
text [i|Failed to parse URI. Malformed fragment.|]
pPrint MalformedHost =
text [i|Failed to parse URI. Malformed host.|]
pPrint MalformedPort =
text [i|Failed to parse URI. Malformed port.|]
pPrint MalformedPath =
text [i|Failed to parse URI. Malformed path.|]
pPrint (OtherError err) =
text [i|Failed to parse URI: #{err}|]
#if !defined(TAR)
instance Pretty ArchiveResult where
pPrint ArchiveFatal = text "Archive result: fatal"
pPrint ArchiveFailed = text "Archive result: failed"
pPrint ArchiveWarn = text "Archive result: warning"
pPrint ArchiveRetry = text "Archive result: retry"
pPrint ArchiveOk = text "Archive result: Ok"
pPrint ArchiveEOF = text "Archive result: EOF"
#else
instance Pretty Tar.FormatError where
pPrint Tar.TruncatedArchive = text "Truncated archive"
pPrint Tar.ShortTrailer = text "Short trailer"
pPrint Tar.BadTrailer = text "Bad trailer"
pPrint Tar.TrailingJunk = text "Trailing junk"
pPrint Tar.ChecksumIncorrect = text "Checksum incorrect"
pPrint Tar.NotTarFormat = text "Not a tar format"
pPrint Tar.UnrecognisedTarFormat = text "Unrecognised tar format"
pPrint Tar.HeaderBadNumericEncoding = text "Header has bad numeric encoding"
#endif

View File

@@ -6,21 +6,13 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Plaform
Description : Retrieving platform information
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
@@ -36,21 +28,17 @@ 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,9 +46,12 @@ 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]
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
PlatformRequest
platformRequest = do
@@ -71,21 +62,15 @@ platformRequest = do
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
"powerpc" -> Right A_PowerPC
"powerpc64" -> Right A_PowerPC64
"powerpc64le" -> Right A_PowerPC64
"sparc" -> Right A_Sparc
"sparc64" -> Right A_Sparc64
"arm" -> Right A_ARM
"aarch64" -> Right A_ARM64
what -> Left (NoCompatibleArch what)
"x86_64" -> Right A_64
"i386" -> Right A_32
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]
'[NoCompatiblePlatform , DistroNotFound]
m
PlatformResult
getPlatform = do
@@ -95,37 +80,40 @@ getPlatform = do
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do
ver <-
either (const Nothing) Just
( either (const Nothing) Just
. versioning
-- TODO: maybe do this somewhere else
. decUTF8Safe'
<$> getDarwinVersion
. 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_lsb_release
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
@@ -148,34 +136,43 @@ 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"
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
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
Just OsRelease{ name = name, version_id = version_id } <-
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
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_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack 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
([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
let verRegex =
makeRegexOpts compIgnoreCase
execBlank
@@ -193,5 +190,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

@@ -1,23 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Requirements
Description : Requirements utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Requirements where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Version
import Control.Applicative
import Data.List ( find )
import Data.Maybe
import Optics
import Prelude hiding ( abs
@@ -25,7 +14,6 @@ import Prelude hiding ( abs
, writeFile
)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
@@ -36,32 +24,22 @@ getCommonRequirements :: PlatformResult
-> ToolRequirements
-> Maybe Requirements
getCommonRequirements pr tr =
with_distro <|> without_distro_ver <|> without_distro
where
with_distro = distro_preview _platform _distroVersion
without_distro_ver = distro_preview _platform (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux . _platform) (const Nothing)
distro_preview f g =
let platformVersionSpec =
preview (ix GHC % ix Nothing % ix (f pr)) tr
mv' = g pr
in fmap snd
. find
(\(mverRange, _) -> maybe
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
=<< platformVersionSpec
preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
<|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
<|> preview
( ix GHC
% ix Nothing
% ix (set _Linux UnknownLinux $ _platform pr)
% ix Nothing
)
tr
prettyRequirements :: Requirements -> T.Text
prettyRequirements Requirements {..} =
let d = if not . null $ _distroPKGs
then
"\n Please install the following distro packages: "
"\n Install the following distro packages: "
<> T.intercalate " " _distroPKGs
else ""
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""

View File

@@ -1,52 +1,17 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types
Description : GHCup types
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
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.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import HPath
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 GHC.Generics as GHC
#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 +21,6 @@ data Key = KEsc | KChar Char | KBS | KEnter
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
}
deriving (Show, GHC.Generic)
@@ -70,7 +34,7 @@ data GHCupInfo = GHCupInfo
type ToolRequirements = Map Tool ToolReqVersionSpec
type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
type PlatformReqSpec = Map Platform PlatformReqVersionSpec
type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements
type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
data Requirements = Requirements
@@ -94,102 +58,47 @@ type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map Version VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
-- | An installable tool.
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)
deriving (Eq, GHC.Generic, Ord, Show)
-- | All necessary information of a tool version, including
-- source download and per-architecture downloads.
data VersionInfo = VersionInfo
{ _viTags :: [Tag] -- ^ version specific tag
, _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
-- informative messages
, _viPostInstall :: Maybe Text
, _viPostRemove :: Maybe Text
, _viPreCompile :: Maybe Text
{ _viTags :: [Tag] -- ^ version specific tag
, _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, GHC.Generic, Show)
deriving (Eq, Show)
-- | A tag. These are currently attached to a version of a tool.
data Tag = Latest
| Recommended
| Prerelease
| Base PVP
| Old -- ^ old version are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
tagToString :: Tag -> String
tagToString Recommended = "recommended"
tagToString Latest = "latest"
tagToString Prerelease = "prerelease"
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
tagToString (UnknownTag t ) = t
tagToString Old = ""
instance Pretty Tag where
pPrint Recommended = text "recommended"
pPrint Latest = text "latest"
pPrint Prerelease = text "prerelease"
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t
pPrint Old = mempty
data Architecture = A_64
| A_32
| A_PowerPC
| A_PowerPC64
| A_Sparc
| A_Sparc64
| A_ARM
| A_ARM64
deriving (Eq, GHC.Generic, Ord, Show)
archToString :: Architecture -> String
archToString A_64 = "x86_64"
archToString A_32 = "i386"
archToString A_PowerPC = "powerpc"
archToString A_PowerPC64 = "powerpc64"
archToString A_Sparc = "sparc"
archToString A_Sparc64 = "sparc64"
archToString A_ARM = "arm"
archToString A_ARM64 = "aarch64"
instance Pretty Architecture where
pPrint = text . archToString
data Platform = Linux LinuxDistro
-- ^ must exit
| 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
data LinuxDistro = Debian
| Ubuntu
| Mint
@@ -206,31 +115,15 @@ data LinuxDistro = Debian
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
distroToString :: LinuxDistro -> String
distroToString Debian = "debian"
distroToString Ubuntu = "ubuntu"
distroToString Mint= "mint"
distroToString Fedora = "fedora"
distroToString CentOS = "centos"
distroToString RedHat = "redhat"
distroToString Alpine = "alpine"
distroToString AmazonLinux = "amazon"
distroToString Gentoo = "gentoo"
distroToString Exherbo = "exherbo"
distroToString UnknownLinux = "unknown"
instance Pretty LinuxDistro where
pPrint = text . distroToString
-- | An encapsulation of a download. This can be used
-- to download, extract and install a tool.
data DownloadInfo = DownloadInfo
{ _dlUri :: URI
, _dlSubdir :: Maybe TarDir
, _dlSubdir :: Maybe (Path Rel)
, _dlHash :: Text
}
deriving (Eq, Ord, GHC.Generic, Show)
deriving (Eq, Show)
@@ -240,121 +133,32 @@ data DownloadInfo = DownloadInfo
--------------
-- | How to descend into a tar archive.
data TarDir = RealDir FilePath
| 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 (RegexDir regex) = text regex
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupInfo
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
deriving (GHC.Generic, Show)
deriving Show
data UserSettings = UserSettings
{ uCache :: Maybe Bool
, uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs
, uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource
}
deriving (Show, GHC.Generic)
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
}
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
}
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'
}
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
} deriving (Show)
data Settings = Settings
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
, urlSource :: URLSource
}
deriving (Show, GHC.Generic)
data Dirs = Dirs
{ baseDir :: FilePath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
}
deriving Show
data KeepDirs = Always
| Errors
| Never
deriving (Eq, Show, Ord)
data Downloader = Curl
| Wget
#if defined(INTERNAL_DOWNLOADER)
| Internal
#endif
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
}
@@ -373,15 +177,6 @@ data PlatformResult = PlatformResult
}
deriving (Eq, Show)
platResToString :: PlatformResult -> String
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> T.unpack (prettyV v')
platResToString PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
instance Pretty PlatformResult where
pPrint = text . platResToString
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
@@ -389,16 +184,6 @@ data PlatformRequest = PlatformRequest
}
deriving (Eq, Show)
pfReqToString :: PlatformRequest -> String
pfReqToString (PlatformRequest arch plat ver) =
archToString arch ++ "-" ++ platformToString plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ T.unpack (prettyV v')
Nothing -> ""
instance Pretty PlatformRequest where
pPrint = text . pfReqToString
-- | A GHC identified by the target platform triple
-- and the version.
@@ -408,55 +193,13 @@ data GHCTargetVersion = GHCTargetVersion
}
deriving (Ord, Eq, Show)
data GitBranch = GitBranch
{ ref :: String
, repo :: Maybe String
}
deriving (Ord, Eq, Show)
mkTVer :: Version -> GHCTargetVersion
mkTVer = GHCTargetVersion Nothing
tVerToText :: GHCTargetVersion -> Text
tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
tVerToText (GHCTargetVersion Nothing v') = prettyVer v'
-- | Assembles a path of the form: <target-triple>-<version>
instance Pretty GHCTargetVersion where
pPrint = text . T.unpack . tVerToText
-- | A comparator and a version.
data VersionCmp = VR_gt Versioning
| VR_gteq Versioning
| VR_lt Versioning
| VR_lteq Versioning
| VR_eq Versioning
deriving (Eq, GHC.Generic, Ord, Show)
-- | A version range. Supports && and ||, but not arbitrary
-- combinations. This is a little simplified.
data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
| OrRange (NonEmpty VersionCmp) VersionRange
deriving (Eq, GHC.Generic, Ord, Show)
instance Pretty Versioning where
pPrint = text . T.unpack . prettyV
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
prettyTVer :: GHCTargetVersion -> Text
prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
prettyTVer (GHCTargetVersion Nothing v') = prettyVer v'

View File

@@ -10,56 +10,40 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Types.JSON
Description : GHCup JSON types/instances
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import Control.Applicative ( (<|>) )
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
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.List.NonEmpty as NE
import qualified Data.ByteString as BS
import qualified Data.Text as T
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 } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
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
instance ToJSON Tag where
toJSON Latest = String "Latest"
toJSON Recommended = String "Recommended"
toJSON Prerelease = String "Prerelease"
toJSON Old = String "old"
toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'')
toJSON (UnknownTag x ) = String (T.pack x)
@@ -67,8 +51,6 @@ instance FromJSON Tag where
parseJSON = withText "Tag" $ \t -> case T.unpack t of
"Latest" -> pure Latest
"Recommended" -> pure Recommended
"Prerelease" -> pure Prerelease
"old" -> pure Old
('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
Right x -> pure $ Base x
Left e -> fail . show $ e
@@ -106,10 +88,10 @@ instance ToJSONKey (Maybe Versioning) where
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_versioning" then pure Nothing else just t
if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
where
just t = case versioning t of
Right x -> pure $ Just x
Right x -> pure x
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
instance ToJSONKey Platform where
@@ -117,13 +99,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
@@ -139,7 +119,7 @@ instance FromJSONKey Platform where
$ "Unexpected failure in decoding LinuxDistro: "
<> show dstr
Nothing -> fail "Unexpected failure in Platform stripPrefix"
| otherwise -> fail "Failure in Platform (FromJSONKey)"
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
instance ToJSONKey Architecture where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
@@ -154,10 +134,10 @@ instance ToJSONKey (Maybe Version) where
instance FromJSONKey (Maybe Version) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_version" then pure Nothing else just t
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where
just t = case version t of
Right x -> pure $ Just x
Right x -> pure x
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
instance ToJSON Version where
@@ -190,129 +170,15 @@ 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 FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p
toJSON (RegexDir r) = object ["RegexDir" .= r]
instance FromJSON TarDir where
parseJSON v = realDir v <|> regexDir v
where
realDir = withText "TarDir" $ \t -> do
fp <- parseJSON (String t)
pure (RealDir fp)
regexDir = withObject "TarDir" $ \o -> do
r <- o .: "RegexDir"
pure $ RegexDir r
instance ToJSON VersionCmp where
toJSON = String . versionCmpToText
instance FromJSON VersionCmp where
parseJSON = withText "VersionCmp" $ \t -> do
case MP.parse versionCmpP "" t of
Right r -> pure r
Left e -> fail (MP.errorBundlePretty e)
versionCmpToText :: VersionCmp -> T.Text
versionCmpToText (VR_gt ver') = "> " <> prettyV ver'
versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
versionCmpToText (VR_lt ver') = "< " <> prettyV ver'
versionCmpToText (VR_lteq ver') = "<= " <> prettyV ver'
versionCmpToText (VR_eq ver') = "== " <> prettyV ver'
versionCmpP :: MP.Parsec Void T.Text VersionCmp
versionCmpP =
fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd)
<|> fmap
VR_gteq
(MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd)
<|> fmap
VR_lt
(MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd)
<|> fmap
VR_lteq
(MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd)
<|> fmap
VR_eq
(MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd)
<|> fmap
VR_eq
(MP.try $ MPC.space *> versioningEnd)
instance ToJSON VersionRange where
toJSON = String . verRangeToText
verRangeToText :: VersionRange -> T.Text
verRangeToText (SimpleRange cmps) =
let inner = foldr1 (\x y -> x <> " && " <> y)
(versionCmpToText <$> NE.toList cmps)
in "( " <> inner <> " )"
verRangeToText (OrRange cmps range) =
let left = verRangeToText (SimpleRange cmps)
right = verRangeToText range
in left <> " || " <> right
instance FromJSON VersionRange where
parseJSON = withText "VersionRange" $ \t -> do
case MP.parse versionRangeP "" t of
Right r -> pure r
Left e -> fail (MP.errorBundlePretty e)
versionRangeP :: MP.Parsec Void T.Text VersionRange
versionRangeP = go <* MP.eof
where
go =
MP.try orParse
<|> MP.try (fmap SimpleRange andParse)
<|> fmap (SimpleRange . pure) versionCmpP
orParse :: MP.Parsec Void T.Text VersionRange
orParse =
(\a o -> OrRange a o)
<$> (MP.try andParse <|> fmap pure versionCmpP)
<*> (MPC.space *> MP.chunk "||" *> MPC.space *> go)
andParse :: MP.Parsec Void T.Text (NonEmpty VersionCmp)
andParse =
fmap (\h t -> h :| t)
(MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
<*> MP.try (MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP))
<* MPC.space
<* MP.chunk ")"
<* MPC.space
versioningEnd :: MP.Parsec Void T.Text Versioning
versioningEnd =
MP.try (verP (MP.chunk " " <|> MP.chunk ")" <|> MP.chunk "&&") <* MPC.space)
<|> versioning'
instance ToJSONKey (Maybe VersionRange) where
toJSONKey = toJSONKeyText $ \case
Just x -> verRangeToText x
Nothing -> "unknown_versioning"
instance FromJSONKey (Maybe VersionRange) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_versioning" then pure Nothing else just t
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
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

View File

@@ -1,14 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Types.Optics
Description : GHCup optics
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Types.Optics where
import GHCup.Types

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

69
lib/GHCup/Utils/Bash.hs Normal file
View File

@@ -0,0 +1,69 @@
module GHCup.Utils.Bash
( findAssignment
, equalsAssignmentWith
, getRValue
, getAssignmentValueFor
)
where
import Control.Monad
import Data.ByteString.UTF8 ( toString )
import Data.List
import Data.Maybe
import HPath
import HPath.IO
import Language.Bash.Parse
import Language.Bash.Syntax
import Language.Bash.Word
import Prelude hiding ( readFile )
import qualified Data.ByteString.Lazy.UTF8 as UTF8
extractAssignments :: List -> [Assign]
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
where
getCommands :: [Statement] -> [Command]
getCommands = join . fmap commands . catMaybes . fmap findPipes
where
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
findPipes _ = Nothing
getAssign :: Command -> [Assign]
getAssign (Command (SimpleCommand ass _) _) = ass
getAssign _ = []
-- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
findAssignment p predicate = do
fileContents <- readFile p
-- TODO: this should accept bytestring:
-- https://github.com/knrafto/language-bash/issues/37
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
Left e -> fail $ show e
Right l -> pure $ find predicate (extractAssignments $ l)
-- | Check that the assignment is of the form Foo= ignoring the
-- right hand-side.
equalsAssignmentWith :: String -> Assign -> Bool
equalsAssignmentWith n ass = case ass of
(Assign (Parameter name' Nothing) Equals _) -> n == name'
_ -> False
-- | This pretty-prints the right hand of an Equals assignment, removing
-- quotations. No evaluation is performed.
getRValue :: Assign -> Maybe String
getRValue ass = case ass of
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
_ -> Nothing
-- | Given a bash assignment such as Foo="Bar" in the given file,
-- will return "Bar" (without quotations).
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
getAssignmentValueFor p n = do
mass <- findAssignment p (equalsAssignmentWith n)
pure (mass >>= getRValue)

View File

@@ -1,281 +1,97 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Dirs
Description : Definition of GHCup directories
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
, ghcupGHCBaseDir
, ghcupGHCDir
, mkGhcupTmpDir
, parseGHCupGHCDir
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
#if !defined(IS_WINDOWS)
, useXDG
#endif
)
where
module GHCup.Utils.Dirs where
import GHCup.Errors
import GHCup.Types
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
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Control.Monad.Trans.Resource
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 System.DiskSpace
import System.Environment
import System.FilePath
import System.IO.Temp
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Yaml as Y
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text.Encoding as E
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
------------------------------
--[ GHCup base directories ]--
------------------------------
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
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
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
-- | ~/.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 = do
#if defined(IS_WINDOWS)
ghcupBaseDir
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
-- | 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 = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "bin")
#else
xdg <- useXDG
if xdg
then do
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
-- | 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 = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "cache")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
-- | 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 = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "logs")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
getDirs :: IO Dirs
getDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
pure Dirs { .. }
-------------------
--[ 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
Nothing -> pure defaultUserSettings
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
-------------------------
--[ GHCup directories ]--
-------------------------
-- | ~/.ghcup by default
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
pure (baseDir </> "ghc")
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
verdir <- parseRel $ E.encodeUtf8 (prettyTVer 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
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> [rel|bin|])
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> [rel|cache|])
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
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)
"...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"
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
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)
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
@@ -283,21 +99,11 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
--------------
#if !defined(IS_WINDOWS)
useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
#endif
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination
-> FilePath
relativeSymlink p1 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)
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

View File

@@ -1,17 +1,411 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
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 where
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import Control.Concurrent
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Data.ByteString ( ByteString )
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Text ( Text )
import Data.Void
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
import HPath
import HPath.IO
import Optics
import Streamly
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.Console.Pretty
import System.Console.Regions
import System.IO
import System.IO.Error
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import Text.Regex.Posix
import qualified Control.Exception as EX
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.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Text.Megaparsec as MP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Bool signals whether the regions should be cleaned.
data StopThread = StopThread Bool
deriving Show
instance Exception StopThread
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
, _stdErr :: ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
-- | Read the lines of a file into a stream. The stream holds
-- a file handle as a resource and will close it once the stream
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream p
pure
. (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n')
. (fmap toArray)
$ stream
-- | 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 . 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)) $ fmap
-- 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 :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout in a region
done <- newEmptyMVar
tid <-
forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
-- fork our subprocess
pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutWrite
closeFd stdoutRead
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- make sure the logging thread stops
case e of
Left _ -> EX.throwTo tid (StopThread False)
Right _ -> EX.throwTo tid (StopThread True)
takeMVar done
closeFd stdoutRead
pure e
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do
ref <- newIORef ([] :: [ByteString])
displayConsoleRegions $ do
rs <- sequence . replicate size . openConsoleRegion $ Linear
flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
$ handle
(\(StopThread b) -> do
when b (forM_ rs closeConsoleRegion)
EX.throw (StopThread b)
)
$ do
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
-- wait for explicit stop from the parent to signal what cleanup to run
forever (threadDelay 5000)
where
-- action to perform line by line
lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs')
regs <- readIORef ref
void $ SPIB.fdWrite fileFd (bs' <> "\n")
forM (zip regs rs) $ \(bs, r) -> do
setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
swapRegs bs regs | length regs < size = regs ++ [bs]
| otherwise = tail regs ++ [bs]
-- trim output line to terminal width
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
-- | 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 (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPPB.getProcessStatus True True pid
takeMVar done
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 finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip 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 i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
unsafePathToString p = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
-- | 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
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 $ join $ fmap 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 $ join $ fmap parseRel f

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

@@ -1,33 +1,18 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Utils.Logger
Description : logger definition
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Utils.File
import GHCup.Utils.String.QQ
import GHCup.Utils
import Control.Monad
import Control.Monad.IO.Class
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
@@ -51,7 +36,7 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
$ colorOutter out
-- raw output
@@ -65,17 +50,11 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
initGHCupFileLogging logsDir = do
let logfile = logsDir </> "ghcup.log"
liftIO $ do
logFiles <- findFiles
logsDir
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
writeFile logfile ""
pure logfile
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

View File

@@ -1,20 +1,12 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Utils.MegaParsec
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Utils.MegaParsec where
import GHCup.Types
import Control.Applicative
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
@@ -23,9 +15,7 @@ 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
import qualified Text.Megaparsec as MP
@@ -61,64 +51,37 @@ ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP t =
(,)
<$> ( MP.try
(Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
(Just <$> (parseUntil1 (MP.chunk "-" *> MP.chunk t)) <* MP.chunk "-"
)
<|> ((\ _ x -> x) Nothing <$> mempty)
<|> (flip const Nothing <$> mempty)
)
<*> (MP.chunk t <* MP.eof)
-- | Extracts the version from @ProjectVersion="8.10.5"@.
ghcProjectVersion :: MP.Parsec Void Text Version
ghcProjectVersion = do
_ <- MP.chunk "ProjectVersion=\""
ver <- parseUntil1 $ MP.chunk "\""
MP.setInput ver
version'
-- | Extracts target triple and version from e.g.
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * armv7-unknown-linux-gnueabihf-8.8.3
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
ghcTargetVerP =
(\x y -> GHCTargetVersion x y)
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> ((\ _ x -> x) Nothing <$> mempty)
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP)) <* MP.chunk "-")
<|> (flip const Nothing <$> mempty)
)
<*> (version' <* MP.eof)
where
verP' :: MP.Parsec Void Text Text
verP' = do
verP :: MP.Parsec Void Text Text
verP = do
v <- version'
let startsWithDigists =
and
. take 3
. concatMap
(map
. join
. (fmap . fmap)
(\case
(Digits _) -> True
(Str _) -> False
) . NE.toList)
. NE.toList
$ _vChunks v
if startsWithDigists && isNothing (_vEpoch v)
)
$ (_vChunks v)
if startsWithDigists && not (isJust (_vEpoch v))
then pure $ prettyVer v
else fail "Oh"
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
verP suffix = do
ver <- parseUntil suffix
if T.null ver
then fail "empty version"
else do
rest <- MP.getInput
MP.setInput ver
v <- versioning'
MP.setInput rest
pure v
pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators

View File

@@ -1,22 +1,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module : GHCup.Utils.Prelude
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Utils.Prelude where
import Control.Applicative
@@ -26,25 +17,14 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub )
import Data.Foldable
import Data.String
import Data.Text ( Text )
import Data.Versions
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
import System.Posix.Env.ByteString ( getEnvironment )
#if defined(IS_WINDOWS)
import Control.Retry
import GHC.IO.Exception
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
@@ -138,7 +118,7 @@ lE' :: forall e' e es a m
=> (e' -> e)
-> Either e' a
-> Excepts es m a
lE' f = liftE . veitherToExcepts . fromEither . first f
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE
@@ -148,7 +128,7 @@ lEM' :: forall e' e es a m
=> (e' -> e)
-> m (Either e' a)
-> Excepts es m a
lEM' f em = lift em >>= lE . first f
lEM' f em = lift em >>= lE . bimap f id
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
@@ -185,19 +165,14 @@ liftIOException errType ex =
. lift
-- | Uses safe-exceptions.
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?
@@ -207,8 +182,8 @@ hideExcept :: forall e es es' a m
-> a
-> Excepts es m a
-> Excepts es' m a
hideExcept _ a =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
hideExcept' :: forall e es es' m
@@ -216,8 +191,8 @@ hideExcept' :: forall e es es' m
=> e
-> Excepts es m ()
-> Excepts es' m ()
hideExcept' _ =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
reThrowAll :: forall e es es' a m
@@ -252,8 +227,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
@@ -264,6 +237,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
@@ -278,150 +259,3 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
decUTF8Safe' :: L.ByteString -> Text
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-- | Escape a version for use in regex
escapeVerRex :: Version -> ByteString
escapeVerRex = B.pack . go . B.unpack . verToBS
where
go [] = []
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

View File

@@ -1,35 +1,25 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.String.QQ
Description : String quasi quoters
Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
QuasiQuoter for non-interpolated strings, texts and bytestrings.
The "s" quoter contains a multi-line string with no interpolation at all,
except that the leading newline is trimmed and carriage returns stripped.
@
{-\# LANGUAGE QuasiQuotes #-}
import Data.Text (Text)
import Data.String.QQ
foo :: Text -- "String", "ByteString" etc also works
foo = [s|
Well here is a
multi-line string!
|]
@
Any instance of the IsString type is permitted.
(For GHC versions 6, write "[$s||]" instead of "[s||]".)
-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
-- The "s" quoter contains a multi-line string with no interpolation at all,
-- except that the leading newline is trimmed and carriage returns stripped.
--
-- @
-- {-\# LANGUAGE QuasiQuotes #-}
-- import Data.Text (Text)
-- import Data.String.QQ
-- foo :: Text -- "String", "ByteString" etc also works
-- foo = [s|
-- Well here is a
-- multi-line string!
-- |]
-- @
--
-- Any instance of the IsString type is permitted.
--
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
--
module GHCup.Utils.String.QQ
( s
)

View File

@@ -7,15 +7,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Version.QQ
Description : Version quasi-quoters
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Utils.Version.QQ where
import Data.Data
@@ -42,8 +33,6 @@ deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data MChunk
deriving instance Lift MChunk
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift VSep
@@ -53,11 +42,12 @@ deriving instance Data VUnit
#if !MIN_VERSION_base(4,13,0)
deriving instance Lift (NonEmpty Word)
instance Lift Text
#endif
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = \s -> quoteExp' . T.pack $ s
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
@@ -101,4 +91,4 @@ liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (fmap liftText . cast)
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

View File

@@ -1,49 +1,22 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Version
Description : Version information and version handling.
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
-}
module GHCup.Version where
import GHCup.Types
import Paths_ghcup (version)
import GHCup.Utils.Version.QQ
import Data.Version (Version(versionBranch))
import Data.Versions hiding (version)
import Data.Versions
import URI.ByteString
import URI.ByteString.QQ
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
-- | This reflects the API version of the YAML.
-- | This reflects the API version of the JSON.
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.2.json|]
-- | The current ghcup version.
ghcUpVer :: PVP
ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version
ghcUpVer = [pver|0.1.4|]
-- | ghcup version as numeric string.
numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer
versionCmp :: Versioning -> VersionCmp -> Bool
versionCmp ver1 (VR_gt ver2) = ver1 > ver2
versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
versionCmp ver1 (VR_lt ver2) = ver1 < ver2
versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
versionCmp ver1 (VR_eq ver2) = ver1 == ver2
versionRange :: Versioning -> VersionRange -> Bool
versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
versionRange ver' (OrRange cmps range) =
versionRange ver' (SimpleRange cmps) || versionRange ver' range

View File

@@ -1,19 +0,0 @@
function _ghcup
set -l cl (commandline --tokenize --current-process)
# Hack around fish issue #3934
set -l cn (commandline --tokenize --cut-at-cursor --current-process)
set -l cn (count $cn)
set -l tmpline --bash-completion-enriched --bash-completion-index $cn
for arg in $cl
set tmpline $tmpline --bash-completion-word $arg
end
for opt in (ghcup $tmpline)
if test -d $opt
echo -E "$opt/"
else
echo -E "$opt"
end
end
end
complete --no-files --command ghcup --arguments '(_ghcup)'

View File

@@ -1,32 +0,0 @@
#compdef ghcup
local request
local completions
local word
local index=$((CURRENT - 1))
request=(--bash-completion-enriched --bash-completion-index $index)
for arg in ${words[@]}; do
request=(${request[@]} --bash-completion-word $arg)
done
IFS=$'\n' completions=($( ghcup "${request[@]}" ))
for word in $completions; do
local -a parts
# Split the line at a tab if there is one.
IFS=$'\t' parts=($( echo $word ))
if [[ -n $parts[2] ]]; then
if [[ $word[1] == "-" ]]; then
local desc=("$parts[1] ($parts[2])")
compadd -d desc -- $parts[1]
else
local desc=($(print -f "%-019s -- %s" $parts[1] $parts[2]))
compadd -l -d desc -- $parts[1]
fi
else
compadd -f -- $word
fi
done

View File

@@ -1,55 +0,0 @@
resolver: lts-17.11
packages:
- .
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
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
- chs-cabal-0.1.1.0@sha256:20ec6a9fb5ab6991f1a4adf157c537bd5d3b98d08d3c09c387c954c7c50bd011,1153
- chs-deps-0.1.0.0@sha256:0cdada6d2c682c41b20331b8c63c2ecfc7e806928585195fd544c9d41f3074fd,2496
- composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
- hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
- hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- 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:
brotli: false
libarchive:
system-libarchive: false
regex-posix:
_regex-posix-clib: true
ghc-options:
"$locals": -O2
streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
ghcup: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

View File

@@ -1,196 +0,0 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.ArbitraryTypes where
import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as T
( toStrict )
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
-----------------
--[ utilities ]--
-----------------
intToText :: Integral a => a -> T.Text
intToText = T.toStrict . B.toLazyText . B.decimal
genVer :: Gen (Int, Int, Int)
genVer =
(\x y z -> (getPositive x, getPositive y, getPositive z))
<$> arbitrary
<*> arbitrary
<*> arbitrary
instance ToADTArbitrary GHCupInfo
----------------------
--[ base arbitrary ]--
----------------------
instance Arbitrary T.Text where
arbitrary = fmap T.pack $ listOf $ elements ['a' .. 'z']
shrink xs = T.pack <$> shrink (T.unpack xs)
instance Arbitrary (NonEmpty Word) where
arbitrary = fmap fromList $ listOf1 arbitrary
-- utf8 encoded bytestring
instance Arbitrary ByteString where
arbitrary = fmap (E.encodeUtf8 . T.pack) $ listOf $ elements ['a' .. 'z']
---------------------
--[ uri arbitrary ]--
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ pure (Scheme "http"), pure (Scheme "https") ]
instance Arbitrary Host where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Port where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (URIRef Absolute) where
arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> pure (Query []) <*> pure Nothing
-------------------------
--[ version arbitrary ]--
-------------------------
instance Arbitrary Mess where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ mess (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Version where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ version (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary SemVer where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ semver (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary PVP where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ pvp (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Versioning where
arbitrary = Ideal <$> arbitrary
-----------------------
--[ ghcup arbitrary ]--
-----------------------
instance Arbitrary Requirements where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary DownloadInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary LinuxDistro where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Platform where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tag where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Architecture where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionRange where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (NonEmpty VersionCmp) where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionCmp where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GlobalTool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Tool v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Version) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Platform v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Versioning) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary

View File

@@ -1,16 +0,0 @@
{-# LANGUAGE TypeApplications #-}
module GHCup.Types.JSONSpec where
import GHCup.ArbitraryTypes ()
import GHCup.Types
import GHCup.Types.JSON ()
import Test.Aeson.GenericSpecs
import Test.Hspec
spec :: Spec
spec = do
roundtripAndGoldenSpecs (Proxy @GHCupInfo)

View File

@@ -1,10 +0,0 @@
import Test.Hspec.Runner
import Test.Hspec.Formatters
import qualified Spec
main :: IO ()
main =
hspecWith
defaultConfig { configFormatter = Just progress }
Spec.spec

4
test/MyLibTest.hs Normal file
View File

@@ -0,0 +1,4 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."

View File

@@ -1,2 +0,0 @@
-- file test/Spec.hs
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

66
update-index-state.sh Executable file
View File

@@ -0,0 +1,66 @@
#!/usr/bin/env bash
set -eu
status_message() {
printf "\\033[0;32m%s\\033[0m\\n" "$1"
}
error_message() {
printf "\\033[0;31m%s\\033[0m\\n" "$1"
}
SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
if [ ! -f "${CACHE_LOCATION}" ] ; then
error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
exit 1
fi
if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
exit 3
fi
cabal v2-update
arch=$(getconf LONG_BIT)
case "${arch}" in
32)
byte_size=4
magic_word="CABA1002"
;;
64)
byte_size=8
magic_word="00000000CABA1002"
;;
*)
error_message "Unknown architecture (long bit): ${arch}"
exit 2
;;
esac
# This is the logic to parse the binary format of 01-index.cache.
# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
# Better than copying the cabal-install source code.
if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
error_message "Magic word does not match!"
exit 4
fi
cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
# If we got junk from the binary file, this should fail.
cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
else
printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
fi

View File

@@ -101,7 +101,6 @@ body#idx p.other-help {
.instructions div.command-button {
display: flex;
align-items: center;
}
.instructions div.command-button button {
@@ -112,7 +111,7 @@ body#idx p.other-help {
border-style: solid;
border-radius: 3px;
margin-left: 0.5rem;
margin-left: 1rem;
margin-right: auto;
margin-top: 25px;
margin-bottom: 25px;
@@ -132,28 +131,23 @@ 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 > pre,
#platform-instructions-win64 > pre,
#platform-instructions-default > div > div > pre,
#platform-instructions-unknown > div > div > pre {
background-color: #515151;
color: white;
margin-left: auto;
margin-right: auto;
padding-top: 1rem;
padding-bottom: 1rem;
padding-right: 1rem;
text-align: center;
border-radius: 3px;
box-shadow: inset 0px 0px 20px 0px #333333;
font-size: 0.6em;
width: 40rem;
}
#platform-instructions-win32 a.windows-download,

View File

@@ -149,17 +149,7 @@ function fill_in_bug_report_values() {
}
function copyToClipboard() {
const text = document.getElementById("ghcup-command-normal").innerText;
const el = document.createElement('textarea');
el.value = text;
document.body.appendChild(el);
el.select();
document.execCommand('copy');
document.body.removeChild(el);
}
function copyToClipboardPowershell() {
const text = document.getElementById("ghcup-command-powershell").innerText;
const text = document.getElementsByClassName("ghcup-command").item(0).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,7 @@
<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>
<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>
<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>.<br/>You appear to be running macOS. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -43,41 +44,18 @@
<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.
</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>
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</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>
<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>
<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 +77,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 or FreeBSD,<br/>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 +86,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,7 +95,7 @@
<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 or FreeBSD,<br/>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>
@@ -127,15 +105,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 +126,52 @@
&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 or FreeBSD,<br/>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 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>