Compare commits

..

1 Commits

Author SHA1 Message Date
527d336f3a Also build 32bit release artifact 2020-04-19 22:03:20 +02:00
98 changed files with 7209 additions and 35895 deletions

109
.github/release.yaml vendored
View File

@@ -1,109 +0,0 @@
name: Create Release
on:
push:
tags:
- 'v*'
jobs:
draft_release:
name: Create Release
runs-on: ubuntu-latest
outputs:
upload_url: ${{ steps.create_release.outputs.upload_url }}
steps:
- name: Create Release
id: create_release
uses: actions/create-release@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
tag_name: ${{ github.ref }}
release_name: Release ${{ github.ref }}
body: |
Changes in this Release
- First Change
- Second Change
draft: true
prerelease: false
release-mac:
name: Create Release for macOS
needs: draft_release
runs-on: ${{ matrix.os }}
env:
MACOSX_DEPLOYMENT_TARGET: 10.13
strategy:
matrix:
os:
- macOS-10.15
steps:
- name: Checkout code
uses: actions/checkout@v2
- uses: haskell/actions/setup@v1.2
with:
ghc-version: 8.10.4
cabal-version: 3.4.0.0
- name: create ~/.local/bin
run: mkdir -p "$HOME/.local/bin"
shell: bash
- name: Add ~/.local/bin to PATH
run: echo "$HOME/.local/bin" >> $GITHUB_PATH
shell: bash
- name: Update cabal cache
run: cabal update
shell: bash
- name: Install cabal dependencies
run: cabal build --only-dependencies
shell: bash
- name: Build
run: cabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
shell: bash
- name: Install
run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
shell: bash
- name: Strip
run: strip ~/.local/bin/ghcup
shell: bash
- name: Run tests
run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
shell: bash
- name: Install git
run: brew install git
- name: set HOME
run: echo "HOME=$HOME" >> $GITHUB_ENV
shell: bash
- name: Set ASSET_PATH
run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
shell: bash
- name: Upload Release Asset
id: upload-release-asset
uses: actions/upload-release-asset@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
upload_url: ${{ needs.draft_release.outputs.upload_url }}
asset_path: ${{ env.ASSET_PATH }}
asset_name: ghcup-${{ matrix.os }}
asset_content_type: application/octet-stream
- if: always()
uses: actions/upload-artifact@v2
with:
name: plan.json
path: ./dist-newstyle/cache/plan.json

View File

@@ -1,109 +0,0 @@
name: Create Release
on:
push:
tags:
- 'v*'
jobs:
draft_release:
name: Draft Release
runs-on: ubuntu-latest
outputs:
upload_url: ${{ steps.create_release.outputs.upload_url }}
steps:
- name: Create Release
id: create_release
uses: actions/create-release@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
tag_name: ${{ github.ref }}
release_name: Release ${{ github.ref }}
body: |
Changes in this Release
- First Change
- Second Change
draft: true
prerelease: false
release-mac:
name: Create Release
needs: draft_release
runs-on: ${{ matrix.os }}
env:
MACOSX_DEPLOYMENT_TARGET: 10.13
strategy:
matrix:
os:
- macOS-10.15
steps:
- name: Checkout code
uses: actions/checkout@v2
- uses: haskell/actions/setup@v1.2
with:
ghc-version: 8.10.4
cabal-version: 3.4.0.0
- name: create ~/.local/bin
run: mkdir -p "$HOME/.local/bin"
shell: bash
- name: Add ~/.local/bin to PATH
run: echo "$HOME/.local/bin" >> $GITHUB_PATH
shell: bash
- name: Update cabal cache
run: cabal update
shell: bash
- name: Install cabal dependencies
run: cabal build --only-dependencies --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
shell: bash
- name: Build
run: cabal build --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
shell: bash
- name: Install
run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
shell: bash
- name: Strip
run: strip ~/.local/bin/ghcup
shell: bash
- name: Run tests
run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
shell: bash
- name: Install git
run: brew install git
- name: set HOME
run: echo "HOME=$HOME" >> $GITHUB_ENV
shell: bash
- name: Set ASSET_PATH
run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
shell: bash
- name: Upload Release Asset
id: upload-release-asset
uses: actions/upload-release-asset@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
upload_url: ${{ needs.draft_release.outputs.upload_url }}
asset_path: ${{ env.ASSET_PATH }}
asset_name: ghcup-${{ matrix.os }}
asset_content_type: application/octet-stream
- if: always()
uses: actions/upload-artifact@v2
with:
name: plan.json
path: ./dist-newstyle/cache/plan.json

View File

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

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,96 +14,50 @@ variables:
- x86_64-linux
variables:
OS: "LINUX"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
CROSS: ""
.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
# .test_ghcup_scoop:
# script:
# - cl /O1 scoop-better-shimexe/shim.c
JSON_VERSION: "0.0.1"
.test_ghcup_version:linux:
extends:
@@ -117,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
@@ -146,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
@@ -180,225 +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
# .test_ghcup_scoop:windows:
# extends:
# - .windows
# - .test_ghcup_scoop
# - .root_cleanup
.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: []
test:linux:cross-armv7:
stage: test
extends:
- .test_ghcup_version
- .debian
variables:
GHC_VERSION: "8.10.4"
GHC_TARGET_VERSION: "8.10.5"
CABAL_VERSION: "3.4.0.0"
CROSS: "arm-linux-gnueabihf"
needs: []
when: manual
allow_failure: true
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
script:
- ./.gitlab/script/ghcup_cross.sh
test:linux:git:hadrian:
stage: test
extends:
- .test_ghcup_version
- .debian
variables:
GHC_VERSION: "8.10.5"
GHC_GIT_TAG: "ghc-9.0.1-release"
GHC_GIT_VERSION: "9.0.1"
CABAL_VERSION: "3.4.0.0"
CROSS: ""
needs: []
when: manual
allow_failure: true
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
script:
- ./.gitlab/script/ghcup_git.sh
######## 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"
CROSS: ""
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"
CROSS: ""
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
# test:windows:scoop:
# stage: test
# extends: .test_ghcup_scoop:windows
# needs: []
######## linux release ########
release:linux:64bit:
stage: release
needs: ["test:linux:recommended", "test:linux:latest"]
extends:
- .alpine:64bit
- .release_ghcup
@@ -406,56 +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"
CROSS: ""
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"
CROSS: ""
######## darwin release ########
release:darwin:
stage: release
needs: ["test:mac:recommended", "test:mac:latest"]
extends:
- .darwin
- .release_ghcup
@@ -464,50 +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 $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_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
@@ -516,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,72 +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
if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then
sudo apt-get install -y autoconf build-essential gcc-arm-linux-gnueabihf
sudo dpkg --add-architecture armhf
sudo apt-get update -y
sudo apt-get install -y libncurses-dev:armhf
fi
case "${ARCH}" in
ARM*)
case "${ARCH}" in
"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 ${GHC_VERSION}
./ghcup-bin set ghc ${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

@@ -1,52 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd)
ecabal() {
cabal "$@"
}
eghcup() {
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
### build
ecabal update
ecabal build -w ghc-${GHC_VERSION}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
### cleanup
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
eghcup --numeric-version
eghcup install ghc ${GHC_VERSION}
eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION}
cabal --version
eghcup debug-info
eghcup compile ghc -j $(nproc) -v ${GHC_TARGET_VERSION} -b ${GHC_VERSION} -x ${CROSS} -- --enable-unregisterised
eghcup set ghc ${CROSS}-${GHC_TARGET_VERSION}
[ `$(eghcup whereis ghc ${CROSS}-${GHC_TARGET_VERSION}) --numeric-version` = "${GHC_TARGET_VERSION}" ]
# nuke
eghcup nuke
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]

View File

@@ -1,52 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
CI_PROJECT_DIR=$(pwd)
ecabal() {
cabal "$@"
}
eghcup() {
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
### build
ecabal update
ecabal build -w ghc-${GHC_VERSION}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
### cleanup
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
eghcup --numeric-version
eghcup install ghc ${GHC_VERSION}
eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION}
cabal --version
eghcup debug-info
eghcup compile ghc -j $(nproc) -g ${GHC_GIT_TAG} -b ${GHC_VERSION} -- --enable-unregisterised
eghcup set ghc ${GHC_GIT_VERSION}
[ `$(eghcup whereis ghc ${GHC_GIT_VERSION}) --numeric-version` = "${GHC_GIT_VERSION}" ]
# nuke
eghcup nuke
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]

View File

@@ -7,38 +7,20 @@ set -eux
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal "$@"
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
# build
ecabal update
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,52 @@ 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
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
eghcup install ghc ${GHC_VERSION}
[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_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}
cabal --version
@@ -94,76 +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 prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
else # test wget a bit
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup --offline set 8.10.3
eghcup set 8.10.3
[ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
$(eghcup whereis hls) --version
eghcup install stack
$(eghcup whereis 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
# check that lazy loading works for 'whereis'
cp "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak"
echo '**' > "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
eghcup whereis ghc $(ghc --numeric-version)
mv -f "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
# 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

25
.travis.yml Normal file
View File

@@ -0,0 +1,25 @@
jobs:
include:
- os: osx
osx_image: xcode10.1
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.13-ghcup
- os: osx
osx_image: xcode11.3
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
script: ".travis/build.sh"
deploy:
provider: releases
api_key:
secure: GQESg4TcYf3PQJRRaZV/kWS0hsF+OFnH2+EcwpgnIcfx4+aogMyprdh745KtBXe1FlFN1luKHksFjqceqhcg/xcNyeCJiSnLWMn4D/i4WUperEHseRBi5yZZCB1AvOjIlHrE4DS3a8pyEm1GV3G7CKY5Fu8jBjof2SnyENfd7fofhjtNHWmeFS+jBn8HRDf1YaSRYxzTw6uHLrPLsybfgQZVl7babMu/38Ghin0f5pz5OlNokzDxaubIYQHOZ7st7YndHJtBWWql/KualBWbMILy88dUVQBnbqQLP2P8d1ME8ILUjJVqz33HiRU0JzlEJyWfbvEjcJ6iD8M6n4nXTaxfu3i2UhhGsQ6SSBNKssMP4tji8nkNpMqG59wLQ/zhcetEm71fKkgJNrIMNllkqlWSo5K74IqqP9kiLg/qm8ipOJjui0gPk8tZXKcV+ztX1d1OVCapoLfiDM5l/0LLQXaTOXOV1x3e5LLQ/w2doNiH3eh5CV4II9dRu7owpaiiMBHMssmT0pH99jEeF6giHLKtt3y7l2GWoRLPdhsZZ54gxsaBxZt9GuypmkbNcr97CEnAVaWij5v0CF3w4rAWqy/tAxQpIDJOIOQBgmwG5WrBAKyKrFvEpBL5a8BPcRWJDvqKC83QeWpvPrEVdgJevC6ZN1MKzrb2SiPOwC2Kerc=
file: $ARTIFACT
on:
repo: haskell/ghcup-hs
tags: true
skip_cleanup: true
draft: true

22
.travis/build.sh Executable file
View File

@@ -0,0 +1,22 @@
#/bin/sh
set -ex
## install ghc via old ghcup
mkdir -p ~/.ghcup/bin
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.8.3
ghcup install-cabal 3.2.0.0
ghcup set 8.8.3
## install ghcup
cabal update
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.

120
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,119 +34,40 @@ 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
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).
## Design goals
1. simplicity
@@ -182,22 +96,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 +140,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,38 +2,27 @@
## Now
* ghcup init?
* merge two download files
* fetch/unpack functionality
* installing multiple versions of the same
* post-install
* proper test suite
* !! 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)
* move out GHCup.Version module, bc it's not library-ish
## Maybe
* version ranges in json
* maybe: changelog Show the changelog of a GHC release (online)
* sign the JSON? (Or check gpg keys?)
* testing (especially distro detection -> unit tests)
## Later
* i386 support
* add support for RC/alpha/HEAD versions
## Cleanups
* too many decodeutf8
* avoid alternative for IO
* use plucky or oops instead of Excepts
## Questions
* move out GHCup.Version module, bc it's not library-ish?
* mirror support
* interactive handling when distro doesn't exist and we know the tarball is incompatible?
* ghcup-with wrapper to execute a command with a given ghc in PATH?

File diff suppressed because it is too large Load Diff

View File

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

View File

@@ -13,8 +13,10 @@ module Main where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import GHCupInfo
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

@@ -0,0 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module 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

@@ -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 hiding ( LeanAppState (..) )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Types
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,24 +19,17 @@ 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
import qualified Data.Text as T
import qualified Data.Version as V
data ValidationError = InternalError String
@@ -68,12 +46,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,11 +59,10 @@ 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
checkGHCisSemver
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
_ <- checkGHCHasBaseVersion
-- exit
e <- liftIO $ readIORef ref
@@ -96,37 +72,20 @@ 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
let allTags = join $ fmap snd $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
@@ -134,7 +93,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
@@ -146,47 +105,26 @@ validate dls _ = do
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
isUniqueTag Latest = True
isUniqueTag Recommended = True
checkGHCVerIsValid = do
checkGHCisSemver = do
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) [i|GHC version #{v} is not valid |]
addError
forM_ ghcVers $ \v -> case semver (prettyVer v) of
Left _ -> do
lift $ $(logError) [i|GHC version #{v} is not valid semver|]
addError
Right _ -> pure ()
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
let allTags = join $ fmap snd $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, tags) -> case any isBase tags of
False -> do
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
addError
True -> pure ()
isBase (Base _) = True
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
, tfVersion :: Regex
}
validateTarballs :: ( Monad m
, MonadLogger m
@@ -194,23 +132,24 @@ validateTarballs :: ( Monad 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 +160,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 getAllDirs
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 False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
let settings = Settings True False
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 dli tmpUnpack Nothing
pure Nothing
Right _ -> do
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download 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,641 +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 hiding ( LeanAppState(..) )
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 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 <- getAllDirs
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, urlSource = GHCupURL
, noNetwork = False
, ..
})
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
-> IO ()
brickMain s l = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of
Right ad ->
defaultMain
(app (defaultAttributes no_color) (dimAttributes no_color))
(BrickState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings (s :: AppState))
)
$> ()
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
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,589 +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 - the ghc version to install
# * BOOTSTRAP_HASKELL_CABAL_VERSION - the cabal version to install
# * BOOTSTRAP_HASKELL_INSTALL_STACK - whether to install latest stack
# * BOOTSTRAP_HASKELL_INSTALL_HLS - whether to install latest hls
# * BOOTSTRAP_HASKELL_ADJUST_BASHRC - whether to adjust PATH in bashrc (prepend)
# * BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG - whether to adjust mingw paths in cabal.config on windows
# 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"
export GHCUP_SKIP_UPDATE_CHECK=yes
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
}
yellow() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;33m$1\\033[0m"
;;
*)
printf "\\033[0;33m%s\\033[0m\\n" "$1"
;;
esac
}
green() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;32m$1\\033[0m"
;;
*)
printf "\\033[0;32m%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() {
echo
echo "==============================================================================="
case "${plat}" in
MSYS*|MINGW*)
green
green "All done!"
green
green "In a new powershell or cmd.exe session, now you can..."
green
green "Start a simple repl via:"
green " ghci"
green
green "Start a new haskell project in the current directory via:"
green " cabal init --interactive"
green
green "Install other GHC versions and tools via:"
green " ghcup list"
green " ghcup install <tool> <version>"
green
green "To install system libraries and update msys2/mingw64,"
green "open the \"Mingw haskell shell\""
green "and the \"Mingw package management docs\""
green "desktop shortcuts."
;;
*)
green
green "All done!"
green
green "To start a simple repl, run:"
green " ghci"
green
green "To start a new haskell project in the current directory, run:"
green " cabal init --interactive"
green
green "To install other GHC versions and tools, run:"
green " 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}"
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
# we may overwrite this in adjust_bashrc
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
unset _plat _arch _url
}
# Figures out the users login shell and sets
# GHCUP_PROFILE_FILE and MY_SHELL variables.
find_shell() {
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
}
# Ask user if they want to adjust the bashrc.
ask_bashrc() {
if [ -n "${BOOTSTRAP_HASKELL_ADJUST_BASHRC}" ] ; then
return 1
fi
while true; do
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "-------------------------------------------------------------------------------"
warn ""
warn "Detected ${MY_SHELL} shell on your system..."
warn "Do you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\"?"
warn ""
warn "[P] Yes, prepend [A] Yes, append [N] No [?] Help (default is \"P\")."
warn ""
read -r bashrc_answer </dev/tty
else
return 1
fi
case $bashrc_answer in
[Pp]* | "")
return 1
;;
[Aa]*)
return 2
;;
[Nn]*)
return 0;;
*)
echo "Possible choices are:"
echo
echo "P - Yes, prepend to PATH, taking precedence (default)"
echo "A - Yes, append to PATH"
echo "N - No, don't mess with my configuration"
echo
echo "Please make your choice and press ENTER."
;;
esac
done
unset bashrc_answer
}
# Needs 'find_shell' to be called beforehand.
adjust_bashrc() {
case $1 in
1)
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
EOF
;;
2)
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:\$PATH:${GHCUP_BIN}"
EOF
;;
*) ;;
esac
case $1 in
1 | 2)
case $MY_SHELL in
"") break ;;
fish)
mkdir -p "${GHCUP_PROFILE_FILE%/*}"
sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
case $1 in
1)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
;;
2)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin \$PATH $GHCUP_BIN # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
;;
esac
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
;;
*)
;;
esac
}
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
}
ask_cabal_config_init() {
case "${plat}" in
MSYS*|MINGW*)
if [ -n "${BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG}" ] ; then
return 1
fi
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "-------------------------------------------------------------------------------"
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]* | "")
return 1 ;;
[Nn]*)
return 0 ;;
*)
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
return 1
fi
;;
esac
unset mingw_answer
return 0
}
do_cabal_config_init() {
case "${plat}" in
MSYS*|MINGW*)
case $1 in
1)
adjust_cabal_config
;;
0)
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
return ;;
*) ;;
esac
esac
}
ask_hls() {
if [ -n "${BOOTSTRAP_HASKELL_INSTALL_HLS}" ] ; then
return 1
fi
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "-------------------------------------------------------------------------------"
warn "Do you want to install haskell-language-server (HLS)?"
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 ""
while true; do
read -r hls_answer </dev/tty
case $hls_answer in
[Yy]*)
return 1
;;
[Nn]* | "")
return 0
;;
*)
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
else
return 0
fi
unset hls_answer
}
ask_stack() {
if [ -n "${BOOTSTRAP_HASKELL_INSTALL_STACK}" ] ; then
return 1
fi
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "-------------------------------------------------------------------------------"
warn "Do you want to install stack?"
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]*)
return 1 ;;
[Nn]* | "")
return 0 ;;
*)
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
else
return 0
fi
unset stack_answer
}
find_shell
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
ask_bashrc
ask_bashrc_answer=$?
ask_cabal_config_init
ask_cabal_config_init_answer=$?
ask_hls
ask_hls_answer=$?
ask_stack
ask_stack_answer=$?
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.
@@ -591,63 +126,76 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
do_cabal_config_init $ask_cabal_config_init_answer
eghcup set
eghcup --cache install-cabal
edo cabal new-update
case $ask_hls_answer in
1)
_eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
;;
*) ;;
esac
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" ""
case $ask_stack_answer in
1)
_eghcup --cache install stack || warn "Stack installation failed, continuing anyway"
;;
*) ;;
esac
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_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
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
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
# short-circuit script based on platform
case "${plat}" in
MSYS*|MINGW*)
# For windows we always adjust bashrc, since it's inside msys2
adjust_bashrc $adjust_bashrc_answer
;;
*)
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
case $ask_bashrc_answer in
1 | 2)
echo
echo "==============================================================================="
echo
yellow "In order to run ghc and cabal, start a new shell or"
yellow "run 'source $GHCUP_DIR/env' in your current shell session."
adjust_bashrc $adjust_bashrc_answer
;;
*)
echo
echo "==============================================================================="
echo
yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
yellow "You may want to source '$GHCUP_DIR/env' in your shell"
yellow "configuration to do so (e.g. ~/.bashrc)."
;;
esac
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,485 +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,
# Whether to install stack as well
[switch]$InstallStack,
# Whether to install hls as well
[switch]$InstallHLS,
# Skip adjusting cabal.config with mingw paths
[switch]$NoAdjustCabalConfig
)
$Silent = !$Interactive
function Print-Msg {
param ( [Parameter(Mandatory=$true, HelpMessage='String to output')][string]$msg, [string]$color = "Green" )
Write-Host ('{0}' -f $msg) -ForegroundColor $color
}
function Create-Shortcut {
param ( [Parameter(Mandatory=$true,HelpMessage='Target path')][string]$SourceExe, [Parameter(Mandatory=$true,HelpMessage='Arguments to the path/exe')][AllowEmptyString()]$ArgumentsToSourceExe, [Parameter(Mandatory=$true,HelpMessage='The destination of the desktop link')][string]$DestinationPath )
$WshShell = New-Object -comObject WScript.Shell
$Shortcut = $WshShell.CreateShortcut($DestinationPath)
$Shortcut.TargetPath = $SourceExe
if($ArgumentsToSourceExe) {
$Shortcut.Arguments = $ArgumentsToSourceExe
}
$Shortcut.Save()
}
function Add-EnvPath {
param(
[Parameter(Mandatory=$true,HelpMessage='The Path to add to Users environment')]
[string] $Path,
[ValidateSet('Machine', 'User', 'Session')]
[string] $Container = 'Session'
)
if ($Container -eq 'Session') {
$envPaths = [Collections.Generic.List[String]]($env:Path -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$env:PATH = $envPaths -join ([IO.Path]::PathSeparator)
}
}
else {
[Microsoft.Win32.RegistryHive]$hive, $keyPath = switch ($Container) {
'Machine' { 'LocalMachine', 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment' }
'User' { 'CurrentUser', 'Environment' }
}
$hiveKey = $envKey = $null
try {
$hiveKey = [Microsoft.Win32.RegistryKey]::OpenRemoteBaseKey($hive, '')
$envKey = $hiveKey.OpenSubKey($keyPath, $true)
$rawPath = $envKey.GetValue('PATH', '', 'DoNotExpandEnvironmentNames')
$envPaths = [Collections.Generic.List[String]]($rawPath -split ([IO.Path]::PathSeparator))
if ($envPaths -notcontains $Path) {
$envPaths.Add($Path)
$envKey.SetValue('PATH', ($envPaths -join ([IO.Path]::PathSeparator)), 'ExpandString')
}
}
finally {
if ($envKey) { $envKey.Close() }
if ($hiveKey) { $hiveKey.Close() }
}
}
}
filter Get-FileSize {
'{0:N2} {1}' -f $(
if ($_ -lt 1kb) { $_, 'Bytes' }
elseif ($_ -lt 1mb) { ($_/1kb), 'KB' }
elseif ($_ -lt 1gb) { ($_/1mb), 'MB' }
elseif ($_ -lt 1tb) { ($_/1gb), 'GB' }
elseif ($_ -lt 1pb) { ($_/1tb), 'TB' }
else { ($_/1pb), 'PB' }
)
}
function Get-FileWCSynchronous{
param(
[Parameter(Mandatory=$true)]
[string]$url,
[string]$destinationFolder="$env:USERPROFILE\Downloads",
[switch]$includeStats
)
$wc = New-Object -TypeName Net.WebClient
$wc.UseDefaultCredentials = $true
$destination = Join-Path -Path $destinationFolder -ChildPath ($url | Split-Path -Leaf)
$start = Get-Date
$wc.DownloadFile($url, $destination)
$elapsed = ((Get-Date) - $start).ToString('hh\:mm\:ss')
$totalSize = (Get-Item -Path $destination).Length | Get-FileSize
if ($includeStats.IsPresent){
[PSCustomObject]@{Name=$MyInvocation.MyCommand;TotalSize=$totalSize;Time=$elapsed}
}
Get-Item -Path $destination | Unblock-File
}
function Test-AbsolutePath {
Param (
[Parameter(Mandatory=$True)]
[ValidateScript({[System.IO.Path]::IsPathRooted($_)})]
[String]$Path
)
}
function Exec
{
[CmdletBinding()]
param(
[Parameter(Position = 0, Mandatory = 1)][string]$cmd,
[Parameter()][string]$errorMessage,
[parameter(ValueFromRemainingArguments = $true)]
[string[]]$Passthrough
)
& $cmd @Passthrough
if ($lastexitcode -ne 0) {
if (!($errorMessage)) {
throw ('Exec: Error executing command {0} with arguments ''{1}''' -f $cmd, "$Passthrough")
} else {
throw ('Exec: ' + $errorMessage)
}
}
}
$ErrorActionPreference = 'Stop'
$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
if ($GhcupBasePrefixEnv) {
$defaultGhcupBasePrefix = $GhcupBasePrefixEnv
} else {
$partitions = Get-CimInstance win32_logicaldisk
$defaultGhcupBasePrefix = $null
foreach ($p in $partitions){
try {
if ($p."FreeSpace" -lt 5368709120) { # at least 5 GB are needed
throw ("Not enough free space on {0}" -f $p."DeviceId")
}
$null = New-Item -Path ('{0}\' -f $p."DeviceId") -Name "ghcup.test" -ItemType "directory" -Force
$defaultGhcupBasePrefix = ('{0}\' -f $p."DeviceId")
Remove-Item -LiteralPath ('{0}\ghcup.test' -f $p."DeviceId")
break
} catch {
Print-Msg -color Yellow -msg ("{0} not writable or not enough disk space, trying next device" -f $p."DeviceId")
}
}
if ($defaultGhcupBasePrefix) {
Print-Msg -color Green -msg ("Picked {0} as default Install prefix!" -f $defaultGhcupBasePrefix)
} else {
Print-Msg -color Red -msg "Couldn't find a writable partition with at least 5GB free disk space!"
Exit 1
}
}
# ask for base install prefix
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...'
# ask what to do in case ghcup is already installed
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
# ask for cabal dir destination
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)
}
# ask whether to install HLS
if (!($InstallHLS)) {
if (!($Silent)) {
$HLSdecision = $Host.UI.PromptForChoice('Install HLS'
, 'Do you want to install the haskell-language-server (HLS) for development purposes as well?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'
'&Abort'), 1)
if ($HLSdecision -eq 0) {
$InstallHLS = $true
} elseif ($HLSdecision -eq 2) {
Exit 0
}
}
}
# ask whether to install stack
if (!($InstallStack)) {
if (!($Silent)) {
$StackDecision = $Host.UI.PromptForChoice('Install stack'
, 'Do you want to install stack as well?'
, [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
'&No'
'&Abort'), 1)
if ($StackDecision -eq 0) {
$InstallStack = $true
} elseif ($StackDecision -eq 2) {
Exit 0
}
}
}
# mingw foo
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}' -f $MsysDir)
Print-Msg -msg 'Starting installation in 5 seconds, this may take a while...'
Start-Sleep -s 5
# 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 'Starting installation in 5 seconds, this may take a while...'
Start-Sleep -s 5
}
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'
$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)
# The bootstrap script is always silent, since we ask relevant questions here
$SilentExport = 'export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 ;'
if ($InstallStack) {
$StackInstallExport = 'export BOOTSTRAP_HASKELL_INSTALL_STACK=1 ;'
}
if ($InstallHLS) {
$HLSInstallExport = 'export BOOTSTRAP_HASKELL_INSTALL_HLS=1 ;'
}
if (!($NoAdjustCabalConfig)) {
$AdjustCabalConfigExport = 'export BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG=1 ;'
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} {6} {7} {8} [ -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, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} [ -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, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
}
# 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,28 +0,0 @@
packages: ./ghcup.cabal
optional-packages: ./vendored/*/*.cabal
optimization: 2
package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-8.10.5

View File

@@ -1,264 +0,0 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.2.1.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.1,
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.assoc ==1.0.2,
any.async ==2.2.3,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.14.2.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.1.0.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.61,
brick -demos,
any.bytestring ==0.10.12.0,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.call-stack ==0.4.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.6,
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.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.3,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
any.cryptohash-sha1 ==0.11.100.1,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.deepseq ==1.4.4.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.0,
any.disk-free-space ==0.1.0.1,
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.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-boot-th ==8.10.5,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.6.1,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
hashable +integer-gmp -random-initial-seed,
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.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
http-io-streams -brotli +fast-xor,
any.indexed-profunctors ==0.1.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.io-streams ==1.5.2.1,
io-streams +network -nointeractivetests +zlib,
any.language-c ==0.9.0.1,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
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.10,
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.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
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.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.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.1,
recursion-schemes +template-haskell,
any.regex-base ==0.94.0.1,
any.regex-posix ==0.96.0.0,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.rts ==1.0.1,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.2,
any.scientific ==0.3.7.0,
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.1,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.16.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
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-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
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.6,
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.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.14.0,
unordered-containers -debug,
any.uri-bytestring ==0.3.3.1,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.2,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-12T18:00:24Z

View File

@@ -1,28 +0,0 @@
packages: ./ghcup.cabal
optional-packages: ./vendored/*/*.cabal
optimization: 2
package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-9.0.1

View File

@@ -1,264 +0,0 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.4.0.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.1,
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.assoc ==1.0.2,
any.async ==2.2.3,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.15.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.1.0.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.61,
brick -demos,
any.bytestring ==0.10.12.1,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.call-stack ==0.4.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.6,
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.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.3,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
any.cryptohash-sha1 ==0.11.100.1,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.deepseq ==1.4.5.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.1,
any.disk-free-space ==0.1.0.1,
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.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-bignum ==1.0,
any.ghc-boot-th ==9.0.1,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.7.0,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
hashable +integer-gmp -random-initial-seed,
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.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
http-io-streams -brotli +fast-xor,
any.indexed-profunctors ==0.1.1,
any.indexed-traversable ==0.1.1,
any.indexed-traversable-instances ==0.1,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.io-streams ==1.5.2.1,
io-streams +network -nointeractivetests +zlib,
any.language-c ==0.9.0.1,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
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.10,
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.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
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.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.process ==1.6.11.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.1,
recursion-schemes +template-haskell,
any.regex-base ==0.94.0.1,
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.2,
any.scientific ==0.3.7.0,
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.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.17.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
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-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
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.6,
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.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.14.0,
unordered-containers -debug,
any.uri-bytestring ==0.3.3.1,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.2,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-12T18:00:24Z

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

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,53 +1,282 @@
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 attoparsec
build-depends: attoparsec >=0.13
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
, attoparsec
, 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
, 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.Download
@@ -59,280 +288,103 @@ 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
GHCup.Utils.String.QQ
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
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.4
, 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
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
, deepseq ^>=1.4
, 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
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:
GHCupDownloads
GHCupInfo
ToolRequirements
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.4
, 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
build-tool-depends: hspec-discover:hspec-discover -any
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

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,95 +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
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
)
=> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF = do
Settings { urlSource } <- lift getSettings
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 ghcupURL
(OwnSource url) -> liftE $ getBase url
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE $ getBase ghcupURL
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE $ getBase ghcupURL
ext <- liftE $ getBase uri
pure (mergeGhcupInfo base ext)
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
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 :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m)
=> URI
-> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
readFromCache uri = do
Dirs{..} <- lift getDirs
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
. liftIO
. L.readFile
$ yaml_file
getBase :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
)
=> URI
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase uri = do
Settings { noNetwork } <- lift getSettings
bs <- if noNetwork
then readFromCache uri
else handleIO (\_ -> warnCache >> readFromCache uri)
. catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
. reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
$ smartDl uri
liftE
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first show
. Y.decodeEither'
. L.toStrict
$ bs
where
warnCache = lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it.
@@ -200,15 +115,8 @@ getBase uri = do
-- than the local file.
--
-- Always save the local file with the mod time of the remote file.
smartDl :: forall m1 env1
. ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
)
smartDl :: forall m1
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
=> URI
-> Excepts
'[ FileDoesNotExistError
@@ -218,58 +126,53 @@ getBase uri = do
, NoLocationHeader
, TooManyRedirs
, ProcessError
, NoNetwork
]
m1
L.ByteString
smartDl uri' = do
Dirs{..} <- lift getDirs
let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file
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 uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS 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 <-
@@ -293,52 +196,31 @@ getBase uri = do
#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 :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
getDownloadInfo :: Tool
-> Version
-- ^ tool version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo t v = do
(PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-> PlatformRequest
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
let distro_preview f g =
let platformVersionSpec =
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
mv' = g mv
in fmap snd
. find
(\(mverRange, _) -> maybe
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
=<< platformVersionSpec
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
where
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
maybe
(throwE NoDownload)
pure
(case p of
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro
)
distro_preview f g =
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
@@ -348,18 +230,16 @@ getDownloadInfo t v = do
-- 2. otherwise create a random file
--
-- The file must not exist.
download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
download :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo
-> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> 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
@@ -370,106 +250,75 @@ download 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
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
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 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
path = view (dlUri % pathL') dli
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
downloadCached :: ( MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadReader Settings m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
cache <- lift getCache
case cache of
True -> downloadCached' dli mfn Nothing
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 dli tmp mfn
downloadCached' :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe cacheDir mDestDir
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure cachfile
| otherwise -> liftE $ download dli destDir mfn
------------------
@@ -480,12 +329,7 @@ downloadCached' dli mfn mDestDir = do
-- | This is used for downloading the JSON.
downloadBS :: ( MonadReader env m
, HasSettings env
, MonadCatch m
, MonadIO m
, MonadLogger m
)
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[ FileDoesNotExistError
@@ -495,7 +339,6 @@ downloadBS :: ( MonadReader env m
, NoLocationHeader
, TooManyRedirs
, ProcessError
, NoNetwork
]
m
L.ByteString
@@ -505,85 +348,40 @@ downloadBS uri'
| 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'}|]
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE NoNetwork
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 :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
)
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m)
=> DownloadInfo
-> FilePath
-> Path Abs
-> Excepts '[DigestError] m ()
checkDigest dli file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify
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 hiding ( (<>) )
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString
import HPath
@@ -47,227 +26,97 @@ 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 Version
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}".|]
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text [i|A download was required or requested, but '--offline' was specified.|]
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
-------------------------
--[ 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 . (Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
deriving instance Show BuildFailed
@@ -275,10 +124,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
@@ -291,75 +136,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,58 +1,16 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DeriveGeneric #-}
{-|
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.DeepSeq ( NFData, rnf )
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 ]--
@@ -62,12 +20,9 @@ data Key = KEsc | KChar Char | KBS | KEnter
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
}
deriving (Show, GHC.Generic)
instance NFData GHCupInfo
-------------------------
@@ -78,7 +33,7 @@ instance NFData 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
@@ -87,8 +42,6 @@ data Requirements = Requirements
}
deriving (Show, GHC.Generic)
instance NFData Requirements
@@ -104,114 +57,45 @@ 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)
instance NFData Tool
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance NFData GlobalTool
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)
instance NFData VersionInfo
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)
instance NFData Tag
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)
instance NFData Architecture
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)
instance NFData Platform
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
@@ -228,35 +112,16 @@ data LinuxDistro = Debian
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
instance NFData LinuxDistro
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)
instance NFData DownloadInfo
@@ -265,152 +130,25 @@ instance NFData 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 NFData TarDir
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)
instance NFData URLSource
instance NFData (URIRef Absolute) where
rnf (URI !_ !_ !_ !_ !_) = ()
data UserSettings = UserSettings
{ uCache :: Maybe Bool
, uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs
, uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing 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)
instance NFData KeyBindings
instance NFData Key
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, GHC.Generic)
instance NFData AppState
data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
} deriving (Show, GHC.Generic)
instance NFData LeanAppState
deriving Show
data Settings = Settings
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
, urlSource :: URLSource
, noNetwork :: Bool
{ cache :: Bool
, noVerify :: Bool
}
deriving (Show, GHC.Generic)
deriving Show
instance NFData Settings
data Dirs = Dirs
{ baseDir :: FilePath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
, tmpDir :: FilePath
}
deriving (Show, GHC.Generic)
instance NFData Dirs
data KeepDirs = Always
| Errors
| Never
deriving (Eq, Show, Ord, GHC.Generic)
instance NFData KeepDirs
data Downloader = Curl
| Wget
#if defined(INTERNAL_DOWNLOADER)
| Internal
#endif
deriving (Eq, Show, Ord, GHC.Generic)
instance NFData Downloader
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
}
@@ -427,98 +165,11 @@ data PlatformResult = PlatformResult
{ _platform :: Platform
, _distroVersion :: Maybe Versioning
}
deriving (Eq, Show, GHC.Generic)
instance NFData PlatformResult
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
deriving (Eq, Show)
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
, _rVersion :: Maybe Versioning
}
deriving (Eq, Show, GHC.Generic)
instance NFData PlatformRequest
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.
data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text
, _tvVersion :: Version
}
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)
instance NFData VersionCmp
-- | 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 NFData VersionRange
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
deriving (Eq, Show)

View File

@@ -10,69 +10,38 @@
{-# 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 } ''Tag
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)
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
x -> pure (UnknownTag x)
instance ToJSON URI where
toJSON = toJSON . decUTF8Safe . serializeURIRef'
@@ -106,10 +75,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 +86,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 +106,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 +121,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
@@ -176,143 +143,21 @@ instance FromJSONKey Version where
Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
instance ToJSON PVP where
toJSON = toJSON . prettyPVP
instance FromJSON PVP where
parseJSON = withText "PVP" $ \t -> case pvp t of
Right x -> pure x
Left e -> fail $ "Failure in PVP (FromJSON)" <> show e
instance ToJSONKey Tool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
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,24 +1,9 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Optics
import URI.ByteString
@@ -34,8 +19,6 @@ makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
makeLenses ''GHCTargetVersion
makeLenses ''GHCupInfo
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
@@ -64,82 +47,3 @@ pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL
----------------------
--[ Lens utilities ]--
----------------------
gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
=> m a
gets = asks (^. labelOptic @f)
getAppState :: MonadReader AppState m => m AppState
getAppState = ask
getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
=> m LeanAppState
getLeanAppState = do
s <- gets @"settings"
d <- gets @"dirs"
k <- gets @"keyBindings"
pure (LeanAppState s d k)
getSettings :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
)
=> m Settings
getSettings = gets @"settings"
getDirs :: ( MonadReader env m
, LabelOptic' "dirs" A_Lens env Dirs
)
=> m Dirs
getDirs = gets @"dirs"
getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
=> m KeyBindings
getKeyBindings = gets @"keyBindings"
getGHCupInfo :: ( MonadReader env m
, LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
)
=> m GHCupInfo
getGHCupInfo = gets @"ghcupInfo"
getPlatformReq :: ( MonadReader env m
, LabelOptic' "pfreq" A_Lens env PlatformRequest
)
=> m PlatformRequest
getPlatformReq = gets @"pfreq"
type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
getCache :: (MonadReader env m, HasSettings env) => m Bool
getCache = getSettings <&> cache
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
getDownloader = getSettings <&> downloader

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,292 +1,78 @@
{-# 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
( getAllDirs
, 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.Types.Optics
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 Data.Versions
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 Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
------------------------------
--[ 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
-- | Defaults to '~/.ghcup/tmp.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
getAllDirs :: IO Dirs
getAllDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir
pure Dirs { .. }
-------------------
--[ 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/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir = do
Dirs {..} <- getDirs
pure (baseDir </> "ghc")
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
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 env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
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 :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
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
--------------
@@ -294,21 +80,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,382 @@
{-# 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 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 qualified Control.Exception as EX
import qualified Data.Text as T
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 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
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
SPIB.fdWrite fileFd (bs <> "\n")
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

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,392 +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 GHCup.Types.Optics
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 env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
Settings {..} <- getSettings
Dirs {..} <- getDirs
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,252 +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 GHCup.Types.Optics
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 env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
Dirs {..} <- getDirs
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,34 +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 Data.Char ( ord )
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
@@ -44,33 +28,20 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> toLogStr (style' "[ ... ] ") <> line' )
$ xs
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
let lr = case level of
LevelDebug -> toLogStr "Debug:"
LevelDebug -> toLogStr "Debug: "
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
@@ -79,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,124 +0,0 @@
{-# 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
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Data.Functor
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
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
choice' [] = fail "Empty list"
choice' [x ] = x
choice' (x : xs) = MP.try x <|> choice' xs
parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil p = do
(MP.try (MP.lookAhead p) $> mempty)
<|> (do
c <- T.singleton <$> MP.anySingle
c2 <- parseUntil p
pure (c `mappend` c2)
)
parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil1 p = do
i1 <- MP.getOffset
t <- parseUntil p
i2 <- MP.getOffset
if i1 == i2 then fail "empty parse" else pure t
-- | Parses e.g.
-- * armv7-unknown-linux-gnueabihf-ghc
-- * armv7-unknown-linux-gnueabihf-ghci
ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP t =
(,)
<$> ( MP.try
(Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
)
<|> ((\ _ x -> x) 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)
)
<*> (version' <* MP.eof)
where
verP' :: MP.Parsec Void Text Text
verP' = do
v <- version'
let startsWithDigists =
and
. take 3
. concatMap
(map
(\case
(Digits _) -> True
(Str _) -> False
) . NE.toList)
. NE.toList
$ _vChunks v
if startsWithDigists && isNothing (_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
@@ -243,17 +218,9 @@ throwEither a = case a of
Right r -> pure r
throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
throwEither' e eth = case eth of
Left _ -> throwM e
Right r -> pure r
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 +231,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 +253,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.1.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,27 +0,0 @@
#!/bin/sh
set -xue
rm -f cabal.*.project
rm -f cabal.*.project.freeze
for ghc_ver in "$@" ; do
# shellcheck disable=SC3060
project_file=cabal.ghc${ghc_ver//./}.project
cp cabal.project "${project_file}"
case "$(uname -s)" in
MSYS*|MINGW*)
cabal freeze --project-file="${project_file}" -w "ghc-${ghc_ver}"
;;
*)
cabal freeze --project-file="${project_file}" -w "ghc-${ghc_ver}" -ftui -finternal-downloader
;;
esac
echo "" >> "${project_file}"
echo "with-compiler: ghc-${ghc_ver}" >> "${project_file}"
sed -i -e '/ghcup/d' "${project_file}".freeze
done

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -1,14 +0,0 @@
_ghcup()
{
local CMDLINE
local IFS=$'\n'
CMDLINE=(--bash-completion-index $COMP_CWORD)
for arg in ${COMP_WORDS[@]}; do
CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)
done
COMPREPLY=( $(ghcup "${CMDLINE[@]}") )
}
complete -o filenames -F _ghcup ghcup

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,60 +0,0 @@
resolver: lts-18.2
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
- base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
- chs-cabal-0.1.1.0@sha256:20ec6a9fb5ab6991f1a4adf157c537bd5d3b98d08d3c09c387c954c7c50bd011,1153
- 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
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
- hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
- hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
- streamly-bytestring-0.1.2@sha256:cc828f41d1c714c711d38fb213b4ed186febabba598ab080e13255f69c20b13c,2469
- 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 $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
</div>
<p class="other-help">If you want to run a non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</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 $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
</div>
<p class="other-help">If you want to run an non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</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>