Compare commits
137 Commits
less-bash
...
fix-symlin
| Author | SHA1 | Date | |
|---|---|---|---|
| 7ec9d90aab | |||
| 326bf510c9 | |||
| ce3d1f4309 | |||
| b31ba883e4 | |||
| e5d1c04616 | |||
| 34ff0ed9cf | |||
| 85bd87d5f3 | |||
| 8b274214af | |||
| 069e3102f4 | |||
| 8623b32721 | |||
| 6342e8edf0 | |||
| bbd8f0c84c | |||
| 873c951d6e | |||
| d9c864d3c5 | |||
| 4280d7109a | |||
| c8855c068f | |||
| 90503061e9 | |||
| 672ebf6426 | |||
| fd76fde23a | |||
| e24c9a3ffe | |||
| 2641d50c21 | |||
| 202f3ea3ba | |||
| 4f09e3ff7e | |||
| 1148219130 | |||
| 4b47800dfb | |||
| e2c4db9132 | |||
| 90af68b211 | |||
| 80603662b4 | |||
| d2c5d4dfd9 | |||
| 6f1b8b4041 | |||
| f63b2bf744 | |||
| 71cb75c170 | |||
| dac64f5718 | |||
| 27b2d2ac7d | |||
| 47142dd376 | |||
| d071a7e51b | |||
| 5c45884f5f | |||
| cafedd73a2 | |||
| 7163b77837 | |||
| 122c54b51e | |||
| b9d7d7d007 | |||
| 9050c9792a | |||
| aac8f760ad | |||
| 7d334c18f5 | |||
| 86b0e4b31b | |||
| af811f3dbc | |||
| d30d2ac8a5 | |||
| 86a4b10de6 | |||
| cfa7049ab9 | |||
| 391676e90a | |||
| 34e4ece8b5 | |||
| cf6443d83f | |||
| 846cf92fa4 | |||
| ab568901f8 | |||
| bfda95c0d6 | |||
| fb1875ee5b | |||
| 185d4f869b | |||
| 2ac8b61aa8 | |||
| 8739cb4656 | |||
| 826900cc41 | |||
| ec6bbdbf06 | |||
| 15a188c501 | |||
| b5440fc7d2 | |||
| 4b21adadf1 | |||
| 78ae77780b | |||
| ccb95bcbee | |||
| 21ac670bbe | |||
| 8b54dee66c | |||
| dad926f3ba | |||
| a298d949b5 | |||
| e1cf11f9d4 | |||
| a046f16308 | |||
| 97cd43792d | |||
| 08693e6d3a | |||
| e2227da8d2 | |||
| 5f20e4c583 | |||
| f82f1a12dd | |||
| 53148fd1c9 | |||
| 8985101b2a | |||
| d1949c8490 | |||
| b7faae1203 | |||
| b6a9d35c3e | |||
| 6cb6c7a448 | |||
| 22a5ad739e | |||
| 14c91bdd78 | |||
| 2c638cd2e2 | |||
| 9e59f484e3 | |||
| ac8419ecb2 | |||
| 3ecdb63063 | |||
| cfe24428fa | |||
| 4c4266dd8c | |||
| e8336bbc8a | |||
| 0f69c73e0e | |||
| e348de8dc4 | |||
| 55a3ba9be2 | |||
| 51b29b81b0 | |||
| 3c2e0334b7 | |||
| 0679626514 | |||
| 5035051135 | |||
| 63c70ee74b | |||
| 2e0bbca2e0 | |||
| b52fa23ca2 | |||
| ba03b78f23 | |||
| 04ef472c15 | |||
| 75cd8f2341 | |||
| f2e26c1800 | |||
| 0f7dd597d2 | |||
| fb0eba9201 | |||
| 3c80929c38 | |||
| b184ee835f | |||
| ef8e3bd940 | |||
| 1a64527e14 | |||
| 30b4d399b9 | |||
| 50424c2801 | |||
| 7e7c357e47 | |||
| 531b82a406 | |||
| 146ac38549 | |||
| c481956b07 | |||
| 8ef19f0825 | |||
| c1e29a8f16 | |||
| c3611eec6a | |||
| 74b58db7d1 | |||
| 9e4763c640 | |||
| abc4278fc8 | |||
| 8c4cde3d14 | |||
| 3824f6417a | |||
|
|
2be1aa2707 | ||
| da94fa5f92 | |||
| 35bf9b5ff2 | |||
| bed2cca8d2 | |||
| 9717a1c00f | |||
| 3ddc719d8a | |||
| 4b89810892 | |||
| b82367838d | |||
| dd7556ba21 | |||
| f4b6bfc594 | |||
| f9251589cd |
8
.gitignore
vendored
8
.gitignore
vendored
@@ -5,3 +5,11 @@ dist-newstyle/
|
||||
cabal.project.local
|
||||
.stack-work/
|
||||
bin/
|
||||
/*.prof
|
||||
/*.ps
|
||||
/*.hp
|
||||
tags
|
||||
TAGS
|
||||
/tmp/
|
||||
.entangled
|
||||
release/
|
||||
|
||||
@@ -14,6 +14,7 @@ variables:
|
||||
- x86_64-linux
|
||||
variables:
|
||||
OS: "LINUX"
|
||||
BIT: "64"
|
||||
|
||||
.alpine:64bit:
|
||||
image: "alpine:edge"
|
||||
@@ -36,12 +37,14 @@ variables:
|
||||
- x86_64-darwin
|
||||
variables:
|
||||
OS: "DARWIN"
|
||||
BIT: "64"
|
||||
|
||||
.freebsd:
|
||||
tags:
|
||||
- x86_64-freebsd
|
||||
variables:
|
||||
OS: "FREEBSD"
|
||||
BIT: "64"
|
||||
|
||||
.root_cleanup:
|
||||
after_script:
|
||||
@@ -66,6 +69,13 @@ 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:darwin:
|
||||
extends:
|
||||
- .test_ghcup_version
|
||||
@@ -97,29 +107,36 @@ variables:
|
||||
test:linux:recommended:
|
||||
extends: .test_ghcup_version:linux
|
||||
variables:
|
||||
GHC_VERSION: "8.6.5"
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
test:linux:latest:
|
||||
extends: .test_ghcup_version:linux
|
||||
variables:
|
||||
GHC_VERSION: "8.8.3"
|
||||
GHC_VERSION: "8.10.2"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
allow_failure: true
|
||||
|
||||
######## linux 32bit test ########
|
||||
|
||||
test:linux:recommended:32bit:
|
||||
extends: .test_ghcup_version:linux32
|
||||
variables:
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
######## darwin test ########
|
||||
|
||||
test:mac:recommended:
|
||||
extends: .test_ghcup_version:darwin
|
||||
variables:
|
||||
GHC_VERSION: "8.6.5"
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
test:mac:latest:
|
||||
extends: .test_ghcup_version:darwin
|
||||
variables:
|
||||
GHC_VERSION: "8.8.3"
|
||||
GHC_VERSION: "8.10.2"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
allow_failure: true
|
||||
|
||||
@@ -129,13 +146,13 @@ test:mac:latest:
|
||||
test:freebsd:recommended:
|
||||
extends: .test_ghcup_version:freebsd
|
||||
variables:
|
||||
GHC_VERSION: "8.6.5"
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
test:freebsd:latest:
|
||||
extends: .test_ghcup_version:freebsd
|
||||
variables:
|
||||
GHC_VERSION: "8.8.3"
|
||||
GHC_VERSION: "8.10.2"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
allow_failure: true
|
||||
|
||||
@@ -150,7 +167,7 @@ release:linux:64bit:
|
||||
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
||||
variables:
|
||||
ARTIFACT: "x86_64-linux-ghcup"
|
||||
GHC_VERSION: "8.8.3"
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
|
||||
@@ -162,7 +179,7 @@ release:linux:32bit:
|
||||
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
||||
variables:
|
||||
ARTIFACT: "i386-linux-ghcup"
|
||||
GHC_VERSION: "8.8.3"
|
||||
GHC_VERSION: "8.8.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
|
||||
@@ -193,5 +210,6 @@ release:freebsd:
|
||||
- ./.gitlab/before_script/freebsd/install_deps.sh
|
||||
variables:
|
||||
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
|
||||
GHC_VERSION: "8.6.5"
|
||||
GHC_VERSION: "8.8.3"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
|
||||
|
||||
@@ -11,15 +11,8 @@ mkdir -p "${TMPDIR}"
|
||||
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
|
||||
chmod +x ghcup-bin
|
||||
|
||||
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"
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin set ${GHC_VERSION}
|
||||
|
||||
exit 0
|
||||
|
||||
@@ -18,29 +18,14 @@ apk add --no-cache \
|
||||
tar \
|
||||
perl
|
||||
|
||||
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
|
||||
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
|
||||
else
|
||||
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
|
||||
curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
|
||||
fi
|
||||
chmod +x ghcup-bin
|
||||
./ghcup-bin upgrade
|
||||
./ghcup-bin install ${GHC_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"
|
||||
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
|
||||
# utils
|
||||
apk add --no-cache \
|
||||
@@ -57,7 +42,6 @@ apk add --no-cache \
|
||||
openssl-dev \
|
||||
openssl-libs-static \
|
||||
xz \
|
||||
xz-dev
|
||||
|
||||
|
||||
xz-dev \
|
||||
ncurses-static
|
||||
|
||||
|
||||
@@ -16,16 +16,24 @@ git describe
|
||||
ecabal update
|
||||
|
||||
if [ "${OS}" = "LINUX" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
|
||||
if [ "${BIT}" = "32" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
|
||||
else
|
||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
|
||||
fi
|
||||
elif [ "${OS}" = "FREEBSD" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
|
||||
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui
|
||||
else
|
||||
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
|
||||
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
|
||||
fi
|
||||
|
||||
mkdir out
|
||||
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||
ver=$(./ghcup --numeric-version)
|
||||
strip -s ./ghcup
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
strip ./ghcup
|
||||
else
|
||||
strip -s ./ghcup
|
||||
fi
|
||||
cp ghcup out/${ARTIFACT}-${ver}
|
||||
|
||||
|
||||
@@ -11,7 +11,7 @@ ecabal() {
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
|
||||
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
}
|
||||
|
||||
git describe --always
|
||||
@@ -21,13 +21,21 @@ git describe --always
|
||||
ecabal update
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION}
|
||||
ecabal build -w ghc-${GHC_VERSION} -ftui
|
||||
elif [ "${OS}" = "LINUX" ] ; then
|
||||
if [ "${BIT}" = "32" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
|
||||
else
|
||||
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
|
||||
fi
|
||||
else
|
||||
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
|
||||
ecabal build -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')" .
|
||||
ecabal haddock -w ghc-${GHC_VERSION} -ftar
|
||||
|
||||
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
|
||||
|
||||
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
|
||||
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
|
||||
@@ -40,16 +48,10 @@ rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
|
||||
### manual cli based testing
|
||||
|
||||
|
||||
ghcup-gen check -f ghcup-${JSON_VERSION}.json
|
||||
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
|
||||
|
||||
eghcup --numeric-version
|
||||
|
||||
# TODO: rm once we have tarballs
|
||||
if [ "${OS}" = "FREEBSD" ] ; then
|
||||
GHC_VERSION=8.6.3
|
||||
CABAL_VERSION=2.4.1.0
|
||||
fi
|
||||
|
||||
eghcup install ${GHC_VERSION}
|
||||
eghcup set ${GHC_VERSION}
|
||||
eghcup install-cabal ${CABAL_VERSION}
|
||||
|
||||
12
.travis.yml
12
.travis.yml
@@ -1,5 +1,10 @@
|
||||
jobs:
|
||||
include:
|
||||
- os: osx
|
||||
osx_image: xcode8
|
||||
language: generic
|
||||
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
|
||||
|
||||
- os: osx
|
||||
osx_image: xcode10.1
|
||||
language: generic
|
||||
@@ -10,6 +15,13 @@ jobs:
|
||||
language: generic
|
||||
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
|
||||
|
||||
allow_failures:
|
||||
- os: osx
|
||||
osx_image: xcode8
|
||||
language: generic
|
||||
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
|
||||
|
||||
|
||||
script: ".travis/build.sh"
|
||||
|
||||
deploy:
|
||||
|
||||
@@ -18,7 +18,7 @@ ghcup set 8.8.3
|
||||
## install ghcup
|
||||
|
||||
cabal update
|
||||
cabal build --constraint="zlib static" --constraint="lzma static"
|
||||
cabal build --constraint="zlib static" --constraint="lzma static" -ftui
|
||||
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
|
||||
strip -s ghcup
|
||||
strip ./ghcup
|
||||
cp ghcup "./${ARTIFACT}"
|
||||
|
||||
2
3rdparty/lzma/lzma.cabal
vendored
2
3rdparty/lzma/lzma.cabal
vendored
@@ -86,7 +86,7 @@ test-suite lzma-tests
|
||||
-- additional dependencies that require version bounds
|
||||
build-depends: HUnit >= 1.2 && <1.7
|
||||
, QuickCheck >= 2.8 && <2.14
|
||||
, tasty >= 0.10 && <1.3
|
||||
, tasty >= 0.10 && <1.4
|
||||
, tasty-hunit >= 0.9 && <0.11
|
||||
, tasty-quickcheck >= 0.8.3.2 && <0.11
|
||||
|
||||
|
||||
2
3rdparty/zlib/zlib.cabal
vendored
2
3rdparty/zlib/zlib.cabal
vendored
@@ -110,7 +110,7 @@ test-suite tests
|
||||
default-language: Haskell2010
|
||||
build-depends: base, bytestring, zlib,
|
||||
QuickCheck == 2.*,
|
||||
tasty >= 0.8 && < 1.3,
|
||||
tasty >= 0.8 && < 1.4,
|
||||
tasty-quickcheck >= 0.8 && < 0.11,
|
||||
tasty-hunit >= 0.8 && < 0.11
|
||||
ghc-options: -Wall
|
||||
|
||||
42
CHANGELOG.md
42
CHANGELOG.md
@@ -1,5 +1,47 @@
|
||||
# Revision history for ghcup
|
||||
|
||||
## 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
|
||||
|
||||
43
README.md
43
README.md
@@ -9,10 +9,15 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
|
||||
## Table of Contents
|
||||
|
||||
* [Installation](#installation)
|
||||
* [Simple bootstrap](#simple-bootstrap)
|
||||
* [Manual install](#manual-install)
|
||||
* [Vim integration](#vim-integration)
|
||||
* [Usage](#usage)
|
||||
* [Manpages](#manpages)
|
||||
* [Shell-completion](#shell-completion)
|
||||
* [Cross support](#cross-support)
|
||||
* [XDG support](#xdg-support)
|
||||
* [Installing custom bindists](#installing-custom-bindists)
|
||||
* [Design goals](#design-goals)
|
||||
* [How](#how)
|
||||
* [Known users](#known-users)
|
||||
@@ -36,11 +41,21 @@ 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`.
|
||||
|
||||
Common use cases are:
|
||||
For the simple interactive TUI, run:
|
||||
|
||||
```sh
|
||||
ghcup tui
|
||||
```
|
||||
|
||||
For the full functionality via cli:
|
||||
|
||||
```sh
|
||||
# list available ghc/cabal versions
|
||||
@@ -90,6 +105,32 @@ 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
|
||||
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir
|
||||
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
|
||||
|
||||
### 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 -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "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 -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`
|
||||
3. DWARF bindists
|
||||
- example: `ghcup -c -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "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
|
||||
|
||||
@@ -1,19 +1,19 @@
|
||||
# RELEASING
|
||||
|
||||
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.
|
||||
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.
|
||||
|
||||
2. Update version in ghcup.cabal
|
||||
|
||||
3. Add ChangeLog entry
|
||||
|
||||
4. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
|
||||
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
|
||||
|
||||
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 GHCupDownloads (see point 4.)
|
||||
7. Add release artifacts to yaml file (see point 4.)
|
||||
|
||||
8. Upload the final `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
|
||||
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
|
||||
|
||||
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`
|
||||
|
||||
@@ -10,13 +10,10 @@
|
||||
|
||||
module Main where
|
||||
|
||||
import GHCup.Data.GHCupInfo
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
import Data.Aeson ( eitherDecode, encode )
|
||||
import Data.Aeson.Encode.Pretty
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Data.Semigroup ( (<>) )
|
||||
#endif
|
||||
@@ -27,48 +24,15 @@ import System.IO ( stdout )
|
||||
import Validate
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Yaml as Y
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optCommand :: Command
|
||||
}
|
||||
|
||||
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 Command = ValidateYAML ValidateYAMLOpts
|
||||
| ValidateTarballs ValidateYAMLOpts
|
||||
|
||||
|
||||
data Input
|
||||
@@ -92,12 +56,12 @@ stdInput = flag'
|
||||
inputP :: Parser Input
|
||||
inputP = fileInput <|> stdInput
|
||||
|
||||
data ValidateJSONOpts = ValidateJSONOpts
|
||||
{ input :: Maybe Input
|
||||
data ValidateYAMLOpts = ValidateYAMLOpts
|
||||
{ vInput :: Maybe Input
|
||||
}
|
||||
|
||||
validateJSONOpts :: Parser ValidateJSONOpts
|
||||
validateJSONOpts = ValidateJSONOpts <$> optional inputP
|
||||
validateYAMLOpts :: Parser ValidateYAMLOpts
|
||||
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
|
||||
|
||||
opts :: Parser Options
|
||||
opts = Options <$> com
|
||||
@@ -105,18 +69,10 @@ opts = Options <$> com
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( (command
|
||||
"gen"
|
||||
( GenJSON
|
||||
<$> (info (genJSONOpts <**> helper)
|
||||
(progDesc "Generate the json downloads file")
|
||||
)
|
||||
)
|
||||
)
|
||||
<> (command
|
||||
"check"
|
||||
( ValidateJSON
|
||||
<$> (info (validateJSONOpts <**> helper)
|
||||
(progDesc "Validate the JSON")
|
||||
( ValidateYAML
|
||||
<$> (info (validateYAMLOpts <**> helper)
|
||||
(progDesc "Validate the YAML")
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -124,7 +80,7 @@ com = subparser
|
||||
"check-tarballs"
|
||||
( ValidateTarballs
|
||||
<$> (info
|
||||
(validateJSONOpts <**> helper)
|
||||
(validateYAMLOpts <**> helper)
|
||||
(progDesc "Validate all tarballs (download and checksum)")
|
||||
)
|
||||
)
|
||||
@@ -135,38 +91,27 @@ com = subparser
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \Options {..} -> case optCommand of
|
||||
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
|
||||
ValidateYAML vopts -> case vopts of
|
||||
ValidateYAMLOpts { vInput = Nothing } ->
|
||||
B.getContents >>= valAndExit validate
|
||||
ValidateYAMLOpts { vInput = Just StdInput } ->
|
||||
B.getContents >>= valAndExit validate
|
||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
||||
B.readFile file >>= valAndExit validate
|
||||
ValidateTarballs vopts -> 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
|
||||
ValidateYAMLOpts { vInput = Nothing } ->
|
||||
B.getContents >>= valAndExit validateTarballs
|
||||
ValidateYAMLOpts { vInput = Just StdInput } ->
|
||||
B.getContents >>= valAndExit validateTarballs
|
||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
||||
B.readFile file >>= valAndExit validateTarballs
|
||||
pure ()
|
||||
|
||||
where
|
||||
valAndExit f contents = do
|
||||
(GHCupInfo _ av) <- case eitherDecode contents of
|
||||
(GHCupInfo _ av) <- case Y.decodeEither' contents of
|
||||
Right r -> pure r
|
||||
Left e -> die (color Red $ show e)
|
||||
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
|
||||
|
||||
@@ -7,7 +7,9 @@ module Validate where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Version.QQ
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
@@ -88,6 +90,15 @@ validate dls = do
|
||||
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
-- alpine needs to be set explicitly, because
|
||||
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
|
||||
-- (although it could be static)
|
||||
when (not $ any (== Linux Alpine) pspecs) $
|
||||
case t of
|
||||
GHCup -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
|
||||
Cabal | v > [vver|2.4.1.0|] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
|
||||
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ M.elems $ availableToolVersions dls tool
|
||||
let nonUnique =
|
||||
@@ -111,6 +122,7 @@ validate dls = do
|
||||
where
|
||||
isUniqueTag Latest = True
|
||||
isUniqueTag Recommended = True
|
||||
isUniqueTag Prerelease = False
|
||||
isUniqueTag (Base _) = False
|
||||
isUniqueTag (UnknownTag _) = False
|
||||
|
||||
@@ -179,7 +191,8 @@ validateTarballs dls = do
|
||||
|
||||
where
|
||||
downloadAll dli = do
|
||||
let settings = Settings True False Never Curl
|
||||
dirs <- liftIO getDirs
|
||||
let settings = Settings True False Never Curl False dirs
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
|
||||
366
app/ghcup/BrickMain.hs
Normal file
366
app/ghcup/BrickMain.hs
Normal file
@@ -0,0 +1,366 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module BrickMain where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
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
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
#endif
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Bool
|
||||
import Data.Functor
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Char
|
||||
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.Exit
|
||||
import System.IO.Unsafe
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Data.Vector as V
|
||||
|
||||
|
||||
data AppState = AppState {
|
||||
lr :: LR
|
||||
, dls :: GHCupDownloads
|
||||
, pfreq :: PlatformRequest
|
||||
}
|
||||
|
||||
type LR = GenericList String Vector ListResult
|
||||
|
||||
|
||||
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
|
||||
keyHandlers =
|
||||
[ ('q', "Quit" , halt)
|
||||
, ('i', "Install" , withIOAction install')
|
||||
, ('u', "Uninstall", withIOAction del')
|
||||
, ('s', "Set" , withIOAction set')
|
||||
, ('c', "ChangeLog", withIOAction changelog')
|
||||
]
|
||||
|
||||
|
||||
ui :: AppState -> Widget String
|
||||
ui AppState {..} =
|
||||
( padBottom Max
|
||||
$ ( withBorderStyle unicode
|
||||
$ borderWithLabel (str "GHCup")
|
||||
$ (center $ renderList renderItem True lr)
|
||||
)
|
||||
)
|
||||
<=> ( withAttr "help"
|
||||
. txtWrap
|
||||
. T.pack
|
||||
. foldr1 (\x y -> x <> " " <> y)
|
||||
. (++ ["↑↓:Navigation"])
|
||||
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
|
||||
)
|
||||
|
||||
where
|
||||
renderItem b 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 = if lNoBindist
|
||||
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
|
||||
else id
|
||||
in dim
|
||||
( marks
|
||||
<+> ( padLeft (Pad 2)
|
||||
$ minHSize 20
|
||||
$ ((if b then withAttr "active" else id)
|
||||
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
|
||||
)
|
||||
)
|
||||
<+> (padLeft (Pad 1) $ if null lTag
|
||||
then emptyWidget
|
||||
else
|
||||
foldr1 (\x y -> x <+> str "," <+> y)
|
||||
$ (fmap printTag $ sort lTag)
|
||||
)
|
||||
)
|
||||
|
||||
printTag Recommended = withAttr "recommended" $ str "recommended"
|
||||
printTag Latest = withAttr "latest" $ str "latest"
|
||||
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
|
||||
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
|
||||
printTag (UnknownTag t ) = str t
|
||||
|
||||
|
||||
minHSize :: Int -> Widget n -> Widget n
|
||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
||||
|
||||
|
||||
app :: App AppState e String
|
||||
app = App { appDraw = \st -> [ui st]
|
||||
, appHandleEvent = eventHandler
|
||||
, appStartEvent = return
|
||||
, appAttrMap = const defaultAttributes
|
||||
, appChooseCursor = neverShowCursor
|
||||
}
|
||||
|
||||
defaultAttributes :: AttrMap
|
||||
defaultAttributes = attrMap
|
||||
Vty.defAttr
|
||||
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
|
||||
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
|
||||
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
|
||||
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
|
||||
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
|
||||
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
|
||||
]
|
||||
|
||||
|
||||
dimAttributes :: AttrMap
|
||||
dimAttributes = attrMap
|
||||
(Vty.defAttr `Vty.withStyle` Vty.dim)
|
||||
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
|
||||
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
|
||||
]
|
||||
|
||||
|
||||
|
||||
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
|
||||
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
|
||||
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
|
||||
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
|
||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
|
||||
continue (AppState (listMoveUp lr) dls pfreq)
|
||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
|
||||
continue (AppState (listMoveDown lr) dls pfreq)
|
||||
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
||||
case find (\(c', _, _) -> c' == c) keyHandlers of
|
||||
Nothing -> continue as
|
||||
Just (_, _, handler) -> handler as
|
||||
eventHandler st _ = continue st
|
||||
|
||||
|
||||
-- | 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 :: (AppState -> (Int, ListResult) -> IO (Either String a))
|
||||
-> AppState
|
||||
-> EventM n (Next AppState)
|
||||
withIOAction action as = case listSelectedElement (lr as) of
|
||||
Nothing -> continue as
|
||||
Just (ix, e) -> suspendAndResume $ do
|
||||
action as (ix, e) >>= \case
|
||||
Left err -> putStrLn $ ("Error: " <> err)
|
||||
Right _ -> putStrLn "Success"
|
||||
apps <- (fmap . fmap)
|
||||
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
|
||||
$ getAppState Nothing (pfreq as)
|
||||
case apps of
|
||||
Right nas -> do
|
||||
putStrLn "Press enter to continue"
|
||||
_ <- getLine
|
||||
pure nas
|
||||
Left err -> throwIO $ userError err
|
||||
|
||||
|
||||
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
||||
install' AppState {..} (_, ListResult {..}) = do
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
let
|
||||
run =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[AlreadyInstalled
|
||||
, UnknownArchive
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoUpdate
|
||||
, TarDirDoesNotExist
|
||||
]
|
||||
|
||||
(run $ do
|
||||
case lTool of
|
||||
GHC -> liftE $ installGHCBin dls lVer pfreq
|
||||
Cabal -> liftE $ installCabalBin dls lVer pfreq
|
||||
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
||||
VLeft (V (BuildFailed _ e)) ->
|
||||
pure $ Left [i|Build failed with #{e}|]
|
||||
VLeft (V NoDownload) ->
|
||||
pure $ Left [i|No available version for #{prettyVer lVer}|]
|
||||
VLeft (V NoUpdate) -> pure $ Right ()
|
||||
VLeft e -> pure $ Left [i|#{e}
|
||||
Also check the logs in ~/.ghcup/logs|]
|
||||
|
||||
|
||||
set' :: AppState -> (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 $> ()
|
||||
GHCup -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
||||
del' _ (_, ListResult {..}) = do
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
(run $ do
|
||||
case lTool of
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
|
||||
Cabal -> liftE $ rmCabalVer lVer $> ()
|
||||
GHCup -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
||||
changelog' AppState {..} (_, ListResult {..}) = do
|
||||
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"
|
||||
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
uri' :: IORef (Maybe URI)
|
||||
{-# NOINLINE uri' #-}
|
||||
uri' = unsafePerformIO (newIORef Nothing)
|
||||
|
||||
|
||||
settings' :: IORef Settings
|
||||
{-# NOINLINE settings' #-}
|
||||
settings' = unsafePerformIO $ do
|
||||
dirs <- getDirs
|
||||
newIORef Settings { cache = True
|
||||
, noVerify = False
|
||||
, keepDirs = Never
|
||||
, downloader = Curl
|
||||
, verbose = False
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
logger' :: IORef LoggerConfig
|
||||
{-# NOINLINE logger' #-}
|
||||
logger' = unsafePerformIO
|
||||
(newIORef $ LoggerConfig { lcPrintDebug = False
|
||||
, colorOutter = \_ -> pure ()
|
||||
, rawOutter = \_ -> pure ()
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
||||
brickMain s muri l av pfreq' = do
|
||||
writeIORef uri' muri
|
||||
writeIORef settings' s
|
||||
-- logger interpreter
|
||||
writeIORef logger' l
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
eApps <- getAppState (Just av) pfreq'
|
||||
case eApps of
|
||||
Right as -> defaultMain app (selectLatest as) $> ()
|
||||
Left e -> do
|
||||
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
||||
exitWith $ ExitFailure 2
|
||||
where
|
||||
selectLatest :: AppState -> AppState
|
||||
selectLatest AppState {..} =
|
||||
(\ix -> AppState { lr = listMoveTo ix lr, .. })
|
||||
. fromJust
|
||||
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
||||
$ (listElements lr)
|
||||
|
||||
|
||||
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
|
||||
getAppState mg pfreq' = do
|
||||
muri <- readIORef uri'
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
r <-
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[JSONError, DownloadFailed, FileDoesNotExistError]
|
||||
$ do
|
||||
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
|
||||
|
||||
lV <- lift $ listVersions dls Nothing Nothing pfreq'
|
||||
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@@ -10,6 +11,10 @@
|
||||
|
||||
module Main where
|
||||
|
||||
#if defined(BRICK)
|
||||
import BrickMain ( brickMain )
|
||||
#endif
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
@@ -21,8 +26,12 @@ import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Version
|
||||
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
#endif
|
||||
import Control.Exception.Safe
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@@ -30,6 +39,7 @@ import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Aeson ( eitherDecode )
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import Data.Either
|
||||
@@ -60,6 +70,7 @@ import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Lazy.UTF8 as BLU
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
@@ -93,6 +104,9 @@ data Command
|
||||
| Upgrade UpgradeOpts Bool
|
||||
| ToolRequirements
|
||||
| ChangeLog ChangeLogOptions
|
||||
#if defined(BRICK)
|
||||
| Interactive
|
||||
#endif
|
||||
|
||||
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
||||
| ToolTag Tag
|
||||
@@ -108,6 +122,7 @@ data InstallCommand = InstallGHC InstallOptions
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instPlatform :: Maybe PlatformRequest
|
||||
, instBindist :: Maybe DownloadInfo
|
||||
}
|
||||
|
||||
data SetCommand = SetGHC SetOptions
|
||||
@@ -221,7 +236,20 @@ opts =
|
||||
com :: Parser Command
|
||||
com =
|
||||
subparser
|
||||
#if defined(BRICK)
|
||||
( command
|
||||
"tui"
|
||||
( (\_ -> Interactive)
|
||||
<$> (info
|
||||
helper
|
||||
( progDesc "Start the interactive GHCup UI"
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
#else
|
||||
( command
|
||||
#endif
|
||||
"install"
|
||||
( Install
|
||||
<$> (info
|
||||
@@ -312,32 +340,32 @@ com =
|
||||
)
|
||||
where
|
||||
installToolFooter :: String
|
||||
installToolFooter = [i|Discussion:
|
||||
installToolFooter = [s|Discussion:
|
||||
Installs GHC or cabal. When no command is given, installs GHC
|
||||
with the specified version/tag.
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
|
||||
setFooter :: String
|
||||
setFooter = [i|Discussion:
|
||||
setFooter = [s|Discussion:
|
||||
Sets the currently active GHC or cabal version. When no command is given,
|
||||
defaults to setting GHC with the specified version/tag (if no tag
|
||||
is given, sets GHC to 'recommended' version).
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
|
||||
rmFooter :: String
|
||||
rmFooter = [i|Discussion:
|
||||
rmFooter = [s|Discussion:
|
||||
Remove the given GHC or cabal version. When no command is given,
|
||||
defaults to removing GHC with the specified version.
|
||||
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
|
||||
|
||||
changeLogFooter :: String
|
||||
changeLogFooter = [i|Discussion:
|
||||
changeLogFooter = [s|Discussion:
|
||||
By default returns the URI of the ChangeLog of the latest GHC release.
|
||||
Pass '-o' to automatically open via xdg-open.|]
|
||||
|
||||
|
||||
installCabalFooter :: String
|
||||
installCabalFooter = [i|Discussion:
|
||||
installCabalFooter = [s|Discussion:
|
||||
Installs the specified cabal-install version (or a recommended default one)
|
||||
into "~/.ghcup/bin", so it can be overwritten by later
|
||||
"cabal install cabal-install", which installs into "~/.cabal/bin" by
|
||||
@@ -373,15 +401,19 @@ installParser =
|
||||
<|> (Right <$> installOpts)
|
||||
where
|
||||
installGHCFooter :: String
|
||||
installGHCFooter = [i|Discussion:
|
||||
installGHCFooter = [s|Discussion:
|
||||
Installs the specified GHC version (or a recommended default one) into
|
||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||
|
||||
Examples:
|
||||
# install 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|]
|
||||
|
||||
|
||||
installOpts :: Parser InstallOptions
|
||||
installOpts =
|
||||
(flip InstallOptions)
|
||||
(\p u v -> InstallOptions v p u)
|
||||
<$> (optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
@@ -393,6 +425,17 @@ installOpts =
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader bindistParser)
|
||||
( short 'u'
|
||||
<> long "url"
|
||||
<> metavar "BINDIST_URL"
|
||||
<> help
|
||||
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> optional toolVersionArgument
|
||||
|
||||
|
||||
@@ -424,13 +467,13 @@ setParser =
|
||||
<|> (Right <$> setOpts)
|
||||
where
|
||||
setGHCFooter :: String
|
||||
setGHCFooter = [i|Discussion:
|
||||
setGHCFooter = [s|Discussion:
|
||||
Sets the the current GHC version by creating non-versioned
|
||||
symlinks for all ghc binaries of the specified version in
|
||||
"~/.ghcup/bin/<binary>".|]
|
||||
|
||||
setCabalFooter :: String
|
||||
setCabalFooter = [i|Discussion:
|
||||
setCabalFooter = [s|Discussion:
|
||||
Sets the the current Cabal version.|]
|
||||
|
||||
|
||||
@@ -530,7 +573,7 @@ compileP = subparser
|
||||
)
|
||||
)
|
||||
where
|
||||
compileFooter = [i|Discussion:
|
||||
compileFooter = [s|Discussion:
|
||||
Compiles and installs the specified GHC version into
|
||||
a self-contained "~/.ghcup/ghc/<ghcver>" directory
|
||||
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
|
||||
@@ -776,15 +819,19 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
pure v
|
||||
|
||||
|
||||
bindistParser :: String -> Either String DownloadInfo
|
||||
bindistParser = eitherDecode . BLU.fromString
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
toSettings :: Options -> IO Settings
|
||||
toSettings Options {..} = do
|
||||
let cache = optCache
|
||||
noVerify = optNoVerify
|
||||
keepDirs = optKeepDirs
|
||||
downloader = optsDownloader
|
||||
in Settings { .. }
|
||||
verbose = optVerbose
|
||||
dirs <- getDirs
|
||||
pure $ Settings { .. }
|
||||
|
||||
|
||||
upgradeOptsP :: Parser UpgradeOpts
|
||||
@@ -843,7 +890,7 @@ main = do
|
||||
<> internal
|
||||
)
|
||||
|
||||
let main_footer = [i|Discussion:
|
||||
let main_footer = [s|Discussion:
|
||||
ghcup installs the Glasgow Haskell Compiler from the official
|
||||
release channels, enabling you to easily switch between different
|
||||
versions. It maintains a self-contained ~/.ghcup directory.
|
||||
@@ -860,19 +907,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(footerDoc (Just $ text main_footer))
|
||||
)
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings@Settings{..} = toSettings opt
|
||||
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
|
||||
|
||||
-- create ~/.ghcup dir
|
||||
ghcdir <- ghcupBaseDir
|
||||
createDirIfMissing newDirPerms ghcdir
|
||||
createDirRecursive' baseDir
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging [rel|ghcup.log|]
|
||||
let runLogger = myLoggerT LoggerConfig
|
||||
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = optVerbose
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = appendFile logfile
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
|
||||
|
||||
-------------------------
|
||||
@@ -886,17 +933,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, UnknownArchive
|
||||
, DistroNotFound
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, NoCompatiblePlatform
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, TarDirDoesNotExist
|
||||
]
|
||||
|
||||
let
|
||||
@@ -907,20 +955,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let
|
||||
runSetCabal =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
|
||||
let runListGHC = runLogger . flip runReaderT settings
|
||||
|
||||
let runRmGHC =
|
||||
let runRm =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
@@ -937,15 +985,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
@'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotFoundInPATH
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
|
||||
let runCompileCabal =
|
||||
@@ -957,14 +1006,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, BuildFailed
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
|
||||
let runUpgrade =
|
||||
@@ -973,9 +1023,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ DigestError
|
||||
, DistroNotFound
|
||||
, NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NoUpdate
|
||||
, FileDoesNotExistError
|
||||
@@ -984,9 +1031,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
]
|
||||
|
||||
|
||||
---------------------------
|
||||
-- Getting download info --
|
||||
---------------------------
|
||||
----------------------------------------
|
||||
-- Getting download and platform info --
|
||||
----------------------------------------
|
||||
|
||||
pfreq <- (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
) >>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) [i|Error determining Platform: #{e}|])
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
|
||||
(GHCupInfo treq dls) <-
|
||||
( runLogger
|
||||
@@ -1001,14 +1058,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger
|
||||
($(logError) [i|Error fetching download info: #{e}|])
|
||||
exitWith (ExitFailure 2)
|
||||
(runLogger
|
||||
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) [i|Error checking for upgrades: #{e}|])
|
||||
|
||||
case optCommand of
|
||||
Upgrade _ _ -> pure ()
|
||||
_ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
@@ -1018,7 +1072,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let installGHC InstallOptions{..} =
|
||||
(runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
|
||||
case instBindist of
|
||||
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
@@ -1032,7 +1088,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
case keepDirs of
|
||||
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
|
||||
_ -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
||||
Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V NoDownload) -> do
|
||||
@@ -1045,14 +1101,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 3
|
||||
|
||||
|
||||
let installCabal InstallOptions{..} =
|
||||
(runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
|
||||
case instBindist of
|
||||
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
@@ -1072,7 +1130,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
@@ -1102,7 +1160,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let rmGHC' RmOptions{..} =
|
||||
(runRmGHC $ do
|
||||
(runRm $ do
|
||||
liftE $ rmGHCVer ghcVer
|
||||
)
|
||||
>>= \case
|
||||
@@ -1112,7 +1170,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 7
|
||||
|
||||
let rmCabal' tv =
|
||||
(runSetCabal $ do
|
||||
(runRm $ do
|
||||
liftE $ rmCabalVer tv
|
||||
)
|
||||
>>= \case
|
||||
@@ -1124,6 +1182,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
|
||||
res <- case optCommand of
|
||||
#if defined(BRICK)
|
||||
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
|
||||
#endif
|
||||
Install (Right iopts) -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
||||
installGHC iopts
|
||||
@@ -1141,16 +1202,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
(runListGHC $ do
|
||||
l <- listVersions dls lTool lCriteria
|
||||
pure l
|
||||
l <- listVersions dls lTool lCriteria pfreq
|
||||
liftIO $ printListResult lRawFormat l
|
||||
pure ExitSuccess
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> do
|
||||
liftIO $ printListResult lRawFormat r
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
pure $ ExitFailure 6
|
||||
|
||||
Rm (Right rmopts) -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
|
||||
@@ -1177,6 +1232,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
buildConfig
|
||||
patchDir
|
||||
addConfArgs
|
||||
pfreq
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
@@ -1190,9 +1246,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
VLeft (V (BuildFailed tmpdir e)) -> do
|
||||
case keepDirs of
|
||||
Never -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/.ghcup/logs|])
|
||||
Check the logs at #{logsDir}|])
|
||||
_ -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
||||
Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure $ ExitFailure 9
|
||||
VLeft e -> do
|
||||
@@ -1201,7 +1257,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
Compile (CompileCabal CabalCompileOptions {..}) ->
|
||||
(runCompileCabal $ do
|
||||
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
|
||||
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> do
|
||||
@@ -1214,7 +1270,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
case keepDirs of
|
||||
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
|
||||
_ -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
||||
Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure $ ExitFailure 10
|
||||
VLeft e -> do
|
||||
@@ -1228,11 +1284,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
|
||||
pure $ Just p
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> do
|
||||
bdir <- liftIO $ ghcupBinDir
|
||||
pure (Just (bdir </> [rel|ghcup|]))
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
|
||||
|
||||
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
|
||||
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
|
||||
VRight v' -> do
|
||||
let pretty_v = prettyVer v'
|
||||
runLogger $ $(logInfo)
|
||||
@@ -1284,9 +1338,14 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure ExitSuccess
|
||||
Just uri -> do
|
||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||
cmd = case _rPlatform pfreq of
|
||||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
|
||||
if clOpen
|
||||
then
|
||||
exec "xdg-open"
|
||||
exec cmd
|
||||
True
|
||||
[serializeURIRef' uri]
|
||||
Nothing
|
||||
@@ -1370,45 +1429,41 @@ printListResult raw lr = do
|
||||
where
|
||||
printTag Recommended = color' Green "recommended"
|
||||
printTag Latest = color' Yellow "latest"
|
||||
printTag Prerelease = color' Red "prerelease"
|
||||
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
|
||||
printTag (UnknownTag t ) = t
|
||||
color' = case raw of
|
||||
True -> flip const
|
||||
False -> color
|
||||
|
||||
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
|
||||
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
|
||||
=> GHCupDownloads
|
||||
-> Excepts
|
||||
'[ NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
]
|
||||
m
|
||||
()
|
||||
checkForUpdates dls = do
|
||||
-> PlatformRequest
|
||||
-> m ()
|
||||
checkForUpdates dls pfreq = do
|
||||
forM_ (getLatest dls GHCup) $ \l -> do
|
||||
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
||||
when (l > ghc_ver)
|
||||
$ lift $ $(logWarn)
|
||||
$ $(logWarn)
|
||||
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
|
||||
|
||||
forM_ (getLatest dls GHC) $ \l -> do
|
||||
mghc_ver <- latestInstalled GHC
|
||||
forM mghc_ver $ \ghc_ver ->
|
||||
when (l > ghc_ver)
|
||||
$ lift $ $(logWarn)
|
||||
$ $(logWarn)
|
||||
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
|
||||
|
||||
forM_ (getLatest dls Cabal) $ \l -> do
|
||||
mcabal_ver <- latestInstalled Cabal
|
||||
forM mcabal_ver $ \cabal_ver ->
|
||||
when (l > cabal_ver)
|
||||
$ lift $ $(logWarn)
|
||||
$ $(logWarn)
|
||||
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
|
||||
|
||||
where
|
||||
latestInstalled tool = (fmap lVer . lastMay)
|
||||
<$> (listVersions dls (Just tool) (Just ListInstalled))
|
||||
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
|
||||
|
||||
|
||||
prettyDebugInfo :: DebugInfo -> String
|
||||
@@ -1425,6 +1480,13 @@ Version: #{describe_result}|]
|
||||
prettyArch :: Architecture -> String
|
||||
prettyArch A_64 = "amd64"
|
||||
prettyArch A_32 = "i386"
|
||||
prettyArch A_PowerPC = "PowerPC"
|
||||
prettyArch A_PowerPC64 = "PowerPC64"
|
||||
prettyArch A_Sparc = "Sparc"
|
||||
prettyArch A_Sparc64 = "Sparc64"
|
||||
prettyArch A_ARM = "ARM"
|
||||
prettyArch A_ARM64 = "ARM64"
|
||||
|
||||
prettyPlatform :: PlatformResult -> String
|
||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
= show plat <> ", " <> show v'
|
||||
|
||||
@@ -4,6 +4,17 @@
|
||||
(
|
||||
|
||||
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
|
||||
|
||||
export GHCUP_USE_XDG_DIRS
|
||||
|
||||
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
|
||||
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local}/ghcup
|
||||
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
|
||||
else
|
||||
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
|
||||
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
|
||||
fi
|
||||
|
||||
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
|
||||
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
|
||||
|
||||
@@ -18,26 +29,55 @@ edo()
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
edo _eghcup "$@"
|
||||
}
|
||||
|
||||
_eghcup() {
|
||||
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
|
||||
edo ghcup "$@"
|
||||
ghcup "$@"
|
||||
else
|
||||
edo ghcup --verbose "$@"
|
||||
ghcup --verbose "$@"
|
||||
fi
|
||||
}
|
||||
|
||||
_done() {
|
||||
echo
|
||||
echo "All done!"
|
||||
echo
|
||||
echo "To start a simple repl, run:"
|
||||
echo " ghci"
|
||||
echo
|
||||
echo "To start a new haskell project in the current directory, run:"
|
||||
echo " cabal init --interactive"
|
||||
echo
|
||||
echo "To install other GHC versions, run:"
|
||||
echo " ghcup tui"
|
||||
|
||||
exit 0
|
||||
}
|
||||
|
||||
download_ghcup() {
|
||||
_plat="$(uname -s)"
|
||||
_arch=$(uname -m)
|
||||
_ghver="0.1.5"
|
||||
_ghver="0.1.10"
|
||||
_base_url="https://downloads.haskell.org/~ghcup"
|
||||
|
||||
case "${_plat}" in
|
||||
"linux"|"Linux")
|
||||
case "${_arch}" in
|
||||
x86_64|amd64)
|
||||
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-linux-ghcup-${_ghver}
|
||||
# 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
|
||||
;;
|
||||
i*86)
|
||||
_url=https://downloads.haskell.org/~ghcup/${_ghver}/i386-linux-ghcup-${_ghver}
|
||||
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
|
||||
;;
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
@@ -53,7 +93,7 @@ download_ghcup() {
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
esac
|
||||
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
|
||||
_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
|
||||
;;
|
||||
"Darwin"|"darwin")
|
||||
case "${_arch}" in
|
||||
@@ -65,14 +105,23 @@ download_ghcup() {
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
esac
|
||||
_url=https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2 ;;
|
||||
_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
|
||||
*) die "Unknown platform: ${_plat}"
|
||||
;;
|
||||
esac
|
||||
|
||||
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
||||
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
|
||||
|
||||
unset _plat _arch _url _ghver
|
||||
edo chmod +x "${GHCUP_BIN}"/ghcup
|
||||
|
||||
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 _ghver _base_url
|
||||
}
|
||||
|
||||
|
||||
@@ -80,12 +129,19 @@ echo
|
||||
echo "Welcome to Haskell!"
|
||||
echo
|
||||
echo "This script will download and install the following binaries:"
|
||||
echo " * ghcup - The Haskell toolchain installer (for managing GHC/cabal versions)"
|
||||
echo " * ghcup - The Haskell toolchain installer"
|
||||
echo " (for managing GHC/cabal versions)"
|
||||
echo " * ghc - The Glasgow Haskell Compiler"
|
||||
echo " * cabal - The Cabal build tool"
|
||||
echo
|
||||
echo "ghcup installs only into the following directory, which can be removed anytime:"
|
||||
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
|
||||
if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
|
||||
echo "ghcup installs only into the following directory,"
|
||||
echo "which can be removed anytime:"
|
||||
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
|
||||
else
|
||||
echo "ghcup installs into XDG directories as long as"
|
||||
echo "'GHCUP_USE_XDG_DIRS' is set."
|
||||
fi
|
||||
echo
|
||||
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
@@ -97,22 +153,14 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
read -r answer </dev/tty
|
||||
fi
|
||||
|
||||
edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
|
||||
edo mkdir -p "${GHCUP_BIN}"
|
||||
|
||||
if command -V "ghcup" >/dev/null 2>&1 ; then
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
|
||||
eghcup upgrade
|
||||
_eghcup upgrade || download_ghcup
|
||||
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
|
||||
@@ -129,10 +177,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
read -r answer </dev/tty
|
||||
fi
|
||||
|
||||
eghcup --cache install "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||
|
||||
eghcup set "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||
eghcup --cache install-cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
|
||||
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
|
||||
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
|
||||
|
||||
edo cabal new-update
|
||||
|
||||
@@ -142,7 +190,7 @@ printf "\\033[0;35m%s\\033[0m\\n" ""
|
||||
|
||||
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 "You may want to source '$GHCUP_DIR/env' in your shell"
|
||||
echo "configuration to do so (e.g. ~/.bashrc)."
|
||||
|
||||
case $SHELL in
|
||||
@@ -160,10 +208,13 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
GHCUP_PROFILE_FILE="$HOME/.zshrc"
|
||||
MY_SHELL="zsh"
|
||||
else
|
||||
exit 0
|
||||
_done
|
||||
fi
|
||||
;;
|
||||
*) exit 0 ;;
|
||||
*/fish) # login shell is fish
|
||||
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
|
||||
MY_SHELL="fish" ;;
|
||||
*) _done ;;
|
||||
esac
|
||||
|
||||
|
||||
@@ -178,12 +229,27 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
|
||||
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}"
|
||||
case $MY_SHELL in
|
||||
"") break ;;
|
||||
fish)
|
||||
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
|
||||
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
|
||||
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
|
||||
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
|
||||
fi
|
||||
break ;;
|
||||
*)
|
||||
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
|
||||
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
|
||||
fi
|
||||
break ;;
|
||||
esac
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
|
||||
exit 0;;
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
|
||||
_done
|
||||
;;
|
||||
[Nn]*)
|
||||
exit 0;;
|
||||
_done ;;
|
||||
*)
|
||||
echo "Please type YES or NO and press enter.";;
|
||||
esac
|
||||
|
||||
@@ -2,6 +2,12 @@ packages: ./ghcup.cabal
|
||||
|
||||
optional-packages: ./3rdparty/*/*.cabal
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskus/packages.git
|
||||
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
|
||||
subdir: haskus-utils-types
|
||||
|
||||
optimization: 2
|
||||
|
||||
package streamly
|
||||
@@ -10,9 +16,9 @@ package streamly
|
||||
package ghcup
|
||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||
|
||||
package tar-bytestring
|
||||
ghc-options: -O2
|
||||
|
||||
constraints: http-io-streams -brotli
|
||||
|
||||
allow-newer: base
|
||||
package libarchive
|
||||
flags: -system-libarchive
|
||||
|
||||
allow-newer: base, ghc-prim, template-haskell
|
||||
|
||||
2348
ghcup-0.0.2.json
2348
ghcup-0.0.2.json
File diff suppressed because it is too large
Load Diff
1426
ghcup-0.0.2.yaml
Normal file
1426
ghcup-0.0.2.yaml
Normal file
File diff suppressed because it is too large
Load Diff
75
ghcup.cabal
75
ghcup.cabal
@@ -1,6 +1,6 @@
|
||||
cabal-version: 3.0
|
||||
name: ghcup
|
||||
version: 0.1.5
|
||||
version: 0.1.10
|
||||
synopsis: ghc toolchain installer as an exe/library
|
||||
description:
|
||||
A rewrite of the shell script ghcup, for providing
|
||||
@@ -21,11 +21,21 @@ source-repository head
|
||||
type: git
|
||||
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||
|
||||
flag tui
|
||||
description: Build the brick powered tui (ghcup tui)
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag internal-downloader
|
||||
description: Compile the internal downloader, which links against OpenSSL
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag tar
|
||||
description: Use tar-bytestring instead of libarchive
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
common HsOpenSSL
|
||||
build-depends: HsOpenSSL >=0.11.4.18
|
||||
|
||||
@@ -50,6 +60,9 @@ common base16-bytestring
|
||||
common binary
|
||||
build-depends: binary >=0.8.6.0
|
||||
|
||||
common brick
|
||||
build-depends: brick >=0.54
|
||||
|
||||
common bytestring
|
||||
build-depends: bytestring >=0.10
|
||||
|
||||
@@ -81,13 +94,13 @@ common hpath
|
||||
build-depends: hpath >=0.11
|
||||
|
||||
common hpath-directory
|
||||
build-depends: hpath-directory >=0.13.3
|
||||
build-depends: hpath-directory >=0.14
|
||||
|
||||
common hpath-filepath
|
||||
build-depends: hpath-filepath >=0.10.3
|
||||
|
||||
common hpath-io
|
||||
build-depends: hpath-io >=0.13.1
|
||||
build-depends: hpath-io >=0.14
|
||||
|
||||
common hpath-posix
|
||||
build-depends: hpath-posix >=0.13.2
|
||||
@@ -98,6 +111,9 @@ common http-io-streams
|
||||
common io-streams
|
||||
build-depends: io-streams >=1.5
|
||||
|
||||
common libarchive
|
||||
build-depends: libarchive >= 3.0.0.0
|
||||
|
||||
common lzma
|
||||
build-depends: lzma >=0.0.0.3
|
||||
|
||||
@@ -137,6 +153,9 @@ common safe
|
||||
common safe-exceptions
|
||||
build-depends: safe-exceptions >=0.1
|
||||
|
||||
common split
|
||||
build-depends: split >=0.2.3.4
|
||||
|
||||
common streamly
|
||||
build-depends: streamly >=0.7.1
|
||||
|
||||
@@ -155,17 +174,17 @@ common string-interpolate
|
||||
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 tar-bytestring
|
||||
build-depends: tar-bytestring >=0.6.3.1
|
||||
|
||||
common terminal-progress-bar
|
||||
build-depends: terminal-progress-bar >=0.4.1
|
||||
|
||||
common text
|
||||
build-depends: text >=1.2
|
||||
build-depends: text >=1.2.4.0
|
||||
|
||||
common time
|
||||
build-depends: time >=1.9.3
|
||||
@@ -173,6 +192,9 @@ common time
|
||||
common transformers
|
||||
build-depends: transformers >=0.5
|
||||
|
||||
common os-release
|
||||
build-depends: os-release >=1.0.0
|
||||
|
||||
common unix
|
||||
build-depends: unix >=2.7
|
||||
|
||||
@@ -194,9 +216,15 @@ common vector
|
||||
common versions
|
||||
build-depends: versions >=3.5
|
||||
|
||||
common vty
|
||||
build-depends: vty >=5.28.2
|
||||
|
||||
common word8
|
||||
build-depends: word8 >=0.1.3
|
||||
|
||||
common yaml
|
||||
build-depends: yaml >=0.11.4.0
|
||||
|
||||
common zlib
|
||||
build-depends: zlib >=0.6.2.1
|
||||
|
||||
@@ -251,16 +279,17 @@ library
|
||||
, resourcet
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, split
|
||||
, streamly
|
||||
, streamly-posix
|
||||
, streamly-bytestring
|
||||
, strict-base
|
||||
, string-interpolate
|
||||
, tar-bytestring
|
||||
, template-haskell
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, os-release
|
||||
, unix
|
||||
, unix-bytestring
|
||||
, unordered-containers
|
||||
@@ -269,13 +298,11 @@ library
|
||||
, vector
|
||||
, versions
|
||||
, word8
|
||||
, yaml
|
||||
, zlib
|
||||
|
||||
exposed-modules:
|
||||
GHCup
|
||||
GHCup.Data.GHCupDownloads
|
||||
GHCup.Data.GHCupInfo
|
||||
GHCup.Data.ToolRequirements
|
||||
GHCup.Download
|
||||
GHCup.Download.Utils
|
||||
GHCup.Errors
|
||||
@@ -285,7 +312,6 @@ library
|
||||
GHCup.Types.JSON
|
||||
GHCup.Types.Optics
|
||||
GHCup.Utils
|
||||
GHCup.Utils.OsRelease
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.Logger
|
||||
@@ -301,17 +327,26 @@ library
|
||||
|
||||
if flag(internal-downloader)
|
||||
import:
|
||||
, HsOpenSSL
|
||||
HsOpenSSL
|
||||
, http-io-streams
|
||||
, io-streams
|
||||
, terminal-progress-bar
|
||||
exposed-modules: GHCup.Download.IOStreams
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
|
||||
if flag(tar)
|
||||
import:
|
||||
tar-bytestring
|
||||
cpp-options: -DTAR
|
||||
else
|
||||
import:
|
||||
libarchive
|
||||
|
||||
executable ghcup
|
||||
import:
|
||||
config
|
||||
, base
|
||||
, aeson
|
||||
, bytestring
|
||||
, containers
|
||||
, haskus-utils-variant
|
||||
@@ -345,6 +380,19 @@ executable ghcup
|
||||
if flag(internal-downloader)
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
|
||||
if flag(tui)
|
||||
import:
|
||||
brick
|
||||
, vector
|
||||
, vty
|
||||
other-modules: BrickMain
|
||||
cpp-options: -DBRICK
|
||||
|
||||
if flag(tar)
|
||||
cpp-options: -DTAR
|
||||
else
|
||||
import:
|
||||
libarchive
|
||||
|
||||
executable ghcup-gen
|
||||
import:
|
||||
@@ -370,6 +418,7 @@ executable ghcup-gen
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
, versions
|
||||
, yaml
|
||||
|
||||
--
|
||||
main-is: Main.hs
|
||||
|
||||
614
lib/GHCup.hs
614
lib/GHCup.hs
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -1,11 +0,0 @@
|
||||
module GHCup.Data.GHCupInfo where
|
||||
|
||||
import GHCup.Data.GHCupDownloads
|
||||
import GHCup.Data.ToolRequirements
|
||||
import GHCup.Types
|
||||
|
||||
|
||||
ghcupInfo :: GHCupInfo
|
||||
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
|
||||
, _ghcupDownloads = ghcupDownloads
|
||||
}
|
||||
@@ -1,147 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.Data.ToolRequirements where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Utils.Version.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"
|
||||
, "libffi-dev"
|
||||
, "libffi6"
|
||||
, "libgmp-dev"
|
||||
, "libgmp10"
|
||||
, "libncurses-dev"
|
||||
, "libncurses5"
|
||||
, "libtinfo5"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Debian
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[ "build-essential"
|
||||
, "curl"
|
||||
, "libffi-dev"
|
||||
, "libffi6"
|
||||
, "libgmp-dev"
|
||||
, "libgmp10"
|
||||
, "libncurses-dev"
|
||||
, "libncurses5"
|
||||
, "libtinfo5"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux CentOS
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[ "gcc"
|
||||
, "gcc-c++"
|
||||
, "gmp"
|
||||
, "gmp-devel"
|
||||
, "make"
|
||||
, "ncurses"
|
||||
, "ncurses-compat-libs"
|
||||
, "xz"
|
||||
, "perl"
|
||||
]
|
||||
""
|
||||
),
|
||||
( Just [vers|7|]
|
||||
, Requirements
|
||||
[ "gcc"
|
||||
, "gcc-c++"
|
||||
, "gmp"
|
||||
, "gmp-devel"
|
||||
, "make"
|
||||
, "ncurses"
|
||||
, "xz"
|
||||
, "perl"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( 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"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
@@ -9,6 +9,23 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{-|
|
||||
Module : GHCup.Download
|
||||
Description : Downloading
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
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)
|
||||
@@ -35,6 +52,7 @@ import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.CaseInsensitive ( CI )
|
||||
@@ -50,7 +68,7 @@ import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO as HIO
|
||||
import HPath.IO as HIO hiding ( hideError )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
@@ -71,6 +89,7 @@ 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
|
||||
@@ -86,7 +105,7 @@ import qualified System.Posix.RawFilePath.Directory
|
||||
|
||||
|
||||
-- | Like 'getDownloads', but tries to fall back to
|
||||
-- cached ~/.ghcup/cache/ghcup-<format-ver>.json
|
||||
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
|
||||
getDownloadsF :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
@@ -114,17 +133,17 @@ getDownloadsF urlSource = do
|
||||
(OwnSpec _) -> liftE $ getDownloads urlSource
|
||||
where
|
||||
readFromCache = do
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
cacheDir <- liftIO $ ghcupCacheDir
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
$ liftIO
|
||||
$ readFile json_file
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
$ readFile yaml_file
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
@@ -145,10 +164,10 @@ getDownloads urlSource = do
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
where
|
||||
@@ -181,8 +200,8 @@ getDownloads urlSource = do
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
let path = view pathL' uri'
|
||||
cacheDir <- liftIO $ ghcupCacheDir
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
@@ -207,7 +226,7 @@ getDownloads urlSource = do
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ readFile json_file
|
||||
else do
|
||||
liftIO $ createDirIfMissing newDirPerms cacheDir
|
||||
liftIO $ createDirRecursive' cacheDir
|
||||
getModTime >>= \case
|
||||
Just modTime -> dlWithMod modTime json_file
|
||||
Nothing -> do
|
||||
@@ -270,7 +289,10 @@ getDownloadInfo :: Tool
|
||||
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
(case p of
|
||||
-- non-musl won't work on alpine
|
||||
Linux Alpine -> with_distro <|> without_distro_ver
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
@@ -308,7 +330,7 @@ download dli dest mfn
|
||||
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
|
||||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
liftIO $ createDirRecursive' dest
|
||||
destFile <- getDestFile
|
||||
fromFile <- parseAbs path
|
||||
liftIO $ copyFile fromFile destFile Strict
|
||||
@@ -318,7 +340,7 @@ download dli dest mfn
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
liftIO $ createDirRecursive' dest
|
||||
destFile <- getDestFile
|
||||
|
||||
-- download
|
||||
@@ -370,15 +392,15 @@ downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cachedir </> fn
|
||||
let cachfile = cacheDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure $ cachfile
|
||||
| otherwise -> liftE $ download dli cachedir mfn
|
||||
| otherwise -> liftE $ download dli cacheDir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
@@ -3,6 +3,15 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
@@ -80,6 +89,9 @@ data JSONError = JSONDecodeError String
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||
deriving Show
|
||||
|
||||
-- | File digest verification failed.
|
||||
data DigestError = DigestError Text Text
|
||||
deriving Show
|
||||
|
||||
@@ -6,13 +6,21 @@
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Platform where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.OsRelease
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
@@ -36,6 +44,7 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
import System.OsRelease
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.Text as T
|
||||
@@ -48,10 +57,7 @@ import qualified Data.Text as T
|
||||
-- | Get the full platform request, consisting of architecture, distro, ...
|
||||
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[ NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
]
|
||||
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
|
||||
m
|
||||
PlatformRequest
|
||||
platformRequest = do
|
||||
@@ -62,15 +68,21 @@ platformRequest = do
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
"i386" -> Right A_32
|
||||
what -> Left (NoCompatibleArch what)
|
||||
|
||||
"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)
|
||||
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , DistroNotFound]
|
||||
'[NoCompatiblePlatform, DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
@@ -82,6 +94,7 @@ getPlatform = do
|
||||
ver <-
|
||||
( either (const Nothing) Just
|
||||
. versioning
|
||||
-- TODO: maybe do this somewhere else
|
||||
. getMajorVersion
|
||||
. decUTF8Safe
|
||||
)
|
||||
@@ -144,8 +157,9 @@ getLinuxDistro = do
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
OsRelease { name = Just n, version_id = v } <- parseOsRelease
|
||||
pure (T.pack n, fmap T.pack v)
|
||||
Just (OsRelease { name = name, version_id = version_id }) <-
|
||||
fmap osRelease <$> parseOsRelease
|
||||
pure (T.pack name, fmap T.pack version_id)
|
||||
|
||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||
try_lsb_release_cmd = do
|
||||
|
||||
@@ -1,5 +1,14 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Requirements
|
||||
Description : Requirements utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Requirements where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
@@ -2,6 +2,15 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
Description : GHCup types
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
@@ -83,6 +92,7 @@ data VersionInfo = VersionInfo
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
| Prerelease
|
||||
| Base PVP
|
||||
| UnknownTag String -- ^ used for upwardscompat
|
||||
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
|
||||
@@ -90,6 +100,12 @@ data Tag = Latest
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
| A_PowerPC
|
||||
| A_PowerPC64
|
||||
| A_Sparc
|
||||
| A_Sparc64
|
||||
| A_ARM
|
||||
| A_ARM64
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
@@ -121,7 +137,7 @@ data LinuxDistro = Debian
|
||||
-- to download, extract and install a tool.
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlSubdir :: Maybe TarDir
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -134,6 +150,12 @@ data DownloadInfo = DownloadInfo
|
||||
--------------
|
||||
|
||||
|
||||
-- | How to descend into a tar archive.
|
||||
data TarDir = RealDir (Path Rel)
|
||||
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
@@ -142,13 +164,25 @@ data URLSource = GHCupURL
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
{ -- set by user
|
||||
cache :: Bool
|
||||
, noVerify :: Bool
|
||||
, keepDirs :: KeepDirs
|
||||
, downloader :: Downloader
|
||||
, verbose :: Bool
|
||||
|
||||
-- set on app start
|
||||
, dirs :: Dirs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: Path Abs
|
||||
, binDir :: Path Abs
|
||||
, cacheDir :: Path Abs
|
||||
, logsDir :: Path Abs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data KeepDirs = Always
|
||||
| Errors
|
||||
|
||||
@@ -10,11 +10,21 @@
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
@@ -44,6 +54,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
|
||||
instance ToJSON Tag where
|
||||
toJSON Latest = String "Latest"
|
||||
toJSON Recommended = String "Recommended"
|
||||
toJSON Prerelease = String "Prerelease"
|
||||
toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'')
|
||||
toJSON (UnknownTag x ) = String (T.pack x)
|
||||
|
||||
@@ -51,6 +62,7 @@ instance FromJSON Tag where
|
||||
parseJSON = withText "Tag" $ \t -> case T.unpack t of
|
||||
"Latest" -> pure Latest
|
||||
"Recommended" -> pure Recommended
|
||||
"Prerelease" -> pure Prerelease
|
||||
('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
|
||||
Right x -> pure $ Base x
|
||||
Left e -> fail . show $ e
|
||||
@@ -182,3 +194,18 @@ instance FromJSON (Path Rel) where
|
||||
case parseRel d of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
|
||||
|
||||
|
||||
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
|
||||
|
||||
@@ -1,5 +1,14 @@
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Types.Optics where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
@@ -6,7 +6,18 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils
|
||||
Description : GHCup domain specific utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
This module contains GHCup helpers specific to
|
||||
installation and introspection of files/versions etc.
|
||||
-}
|
||||
module GHCup.Utils
|
||||
( module GHCup.Utils.Dirs
|
||||
, module GHCup.Utils
|
||||
@@ -24,6 +35,9 @@ import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive hiding ( Directory )
|
||||
#endif
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
@@ -34,7 +48,9 @@ import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.List.Split
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
@@ -42,7 +58,7 @@ import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
@@ -58,12 +74,18 @@ import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import Text.Regex.Posix
|
||||
import URI.ByteString
|
||||
|
||||
#if defined(TAR)
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
#endif
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
#if !defined(TAR)
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
@@ -77,20 +99,24 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m)
|
||||
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> GHCTargetVersion
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver =
|
||||
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
|
||||
-> m ByteString
|
||||
ghcLinkDestination tool ver = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
t <- parseRel tool
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
|
||||
|
||||
|
||||
-- e.g. ghc-8.6.5
|
||||
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
|
||||
rmMinorSymlinks GHCTargetVersion {..} = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
bindir
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
|
||||
*> (MP.chunk $ prettyVer _tvVersion)
|
||||
@@ -98,42 +124,41 @@ rmMinorSymlinks GHCTargetVersion {..} = do
|
||||
)
|
||||
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
-- Removes the set ghc version for the given target, if any.
|
||||
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Maybe Text -- ^ target
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain target = do
|
||||
mtv <- ghcSet target
|
||||
Settings {dirs = Dirs {..}} <- lift ask
|
||||
mtv <- lift $ ghcSet target
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = (bindir </> [rel|haddock-ghc|])
|
||||
let hdc_file = (binDir </> [rel|haddock-ghc|])
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
|
||||
-- e.g. ghc-8.6
|
||||
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
-> m ()
|
||||
rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ findFiles'
|
||||
bindir
|
||||
binDir
|
||||
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
|
||||
*> parseUntil1 (MP.chunk v')
|
||||
*> MP.chunk v'
|
||||
@@ -141,7 +166,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
)
|
||||
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
let fullF = (binDir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
@@ -153,98 +178,128 @@ rmMajorSymlinks GHCTargetVersion {..} = do
|
||||
-----------------------------------
|
||||
|
||||
|
||||
ghcInstalled :: GHCTargetVersion -> IO Bool
|
||||
-- | Whethe the given GHC versin is installed.
|
||||
ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
liftIO $ doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
|
||||
-- | Whether the given GHC version is installed from source.
|
||||
ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
ghcSet :: (MonadThrow m, MonadIO m)
|
||||
-- | Whether the given GHC version is set as the current.
|
||||
ghcSet :: (MonadReader Settings m, MonadThrow m, MonadIO m)
|
||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
|
||||
ghcBin <- (</> ghc) <$> liftIO ghcupBinDir
|
||||
let ghcBin = binDir </> ghc
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
|
||||
ghcLinkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
where
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
|
||||
ghcLinkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
where
|
||||
parser =
|
||||
MP.chunk "../ghc/"
|
||||
*> (do
|
||||
r <- parseUntil1 (MP.chunk "/")
|
||||
rest <- MP.getInput
|
||||
MP.setInput r
|
||||
x <- ghcTargetVerP
|
||||
MP.setInput rest
|
||||
pure x
|
||||
)
|
||||
<* MP.chunk "/"
|
||||
<* MP.takeRest
|
||||
<* MP.eof
|
||||
parser =
|
||||
(do
|
||||
_ <- parseUntil1 (MP.chunk "/ghc/")
|
||||
_ <- MP.chunk "/ghc/"
|
||||
r <- parseUntil1 (MP.chunk "/")
|
||||
rest <- MP.getInput
|
||||
MP.setInput r
|
||||
x <- ghcTargetVerP
|
||||
MP.setInput rest
|
||||
pure x
|
||||
)
|
||||
<* MP.chunk "/"
|
||||
<* MP.takeRest
|
||||
<* MP.eof
|
||||
|
||||
|
||||
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
|
||||
-- If a dir cannot be parsed, returns left.
|
||||
getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion]
|
||||
getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
|
||||
getInstalledGHCs = do
|
||||
ghcdir <- liftIO $ ghcupGHCBaseDir
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
|
||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
||||
Right r -> pure $ Right r
|
||||
Left _ -> pure $ Left f
|
||||
|
||||
|
||||
getInstalledCabals :: IO [Either (Path Rel) Version]
|
||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
||||
getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m)
|
||||
=> m [Either (Path Rel) Version]
|
||||
getInstalledCabals = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
bindir
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
cs <- cabalSet -- for legacy cabal
|
||||
pure $ maybe vs (\x -> Right x:vs) cs
|
||||
pure $ maybe vs (\x -> nub $ Right x:vs) cs
|
||||
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
-- | Whether the given cabal version is installed.
|
||||
cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled ver = do
|
||||
vers <- fmap rights $ getInstalledCabals
|
||||
pure $ elem ver $ vers
|
||||
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
-- Return the currently set cabal version, if any.
|
||||
cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet = do
|
||||
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
|
||||
cabalbin
|
||||
["--numeric-version"]
|
||||
Nothing
|
||||
fmap join $ forM mc $ \c -> if
|
||||
| not (B.null (_stdOut c))
|
||||
, _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
|
||||
case version $ decUTF8Safe reportedVer of
|
||||
Left e -> throwM e
|
||||
Right r -> pure $ Just r
|
||||
| otherwise -> pure Nothing
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
|
||||
if
|
||||
| b -> do
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
broken <- isBrokenSymlink cabalbin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- readSymbolicLink $ toFilePath cabalbin
|
||||
Just <$> linkVersion link
|
||||
| otherwise -> do -- legacy behavior
|
||||
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
|
||||
cabalbin
|
||||
["--numeric-version"]
|
||||
Nothing
|
||||
fmap join $ forM mc $ \c -> if
|
||||
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
|
||||
case version $ decUTF8Safe reportedVer of
|
||||
Left e -> throwM e
|
||||
Right r -> pure $ Just r
|
||||
| otherwise -> pure Nothing
|
||||
where
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
where
|
||||
parser =
|
||||
MP.chunk "cabal-" *> version'
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -253,6 +308,7 @@ cabalSet = do
|
||||
-----------------------------------------
|
||||
|
||||
|
||||
-- | Extract (major, minor) from any version.
|
||||
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
|
||||
getMajorMinorV Version {..} = case _vChunks of
|
||||
([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y)
|
||||
@@ -267,7 +323,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> Maybe Text -- ^ the target triple
|
||||
@@ -310,28 +366,67 @@ getLatestGHCFor major' minor' dls = do
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
-> Excepts '[UnknownArchive] m ()
|
||||
-> Excepts '[UnknownArchive
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m ()
|
||||
unpackToDir dest av = do
|
||||
fp <- (decUTF8Safe . toFilePath) <$> basename av
|
||||
let dfp = decUTF8Safe . toFilePath $ dest
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
#if defined(TAR)
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
|
||||
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#else
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#endif
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
||||
(untar . GZip.decompress =<< rf av)
|
||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
filecontents <- liftE $ rf av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
liftE $ untar decompressed
|
||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
||||
liftE (untar . BZip.decompress =<< rf av)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
|
||||
=> Path Abs -- ^ unpacked tar dir
|
||||
-> TarDir -- ^ how to descend
|
||||
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
|
||||
intoSubdir bdir tardir = case tardir of
|
||||
RealDir pr -> do
|
||||
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
|
||||
(throwE $ TarDirDoesNotExist tardir)
|
||||
pure (bdir </> pr)
|
||||
RegexDir r -> do
|
||||
let rs = splitOn "/" r
|
||||
foldlM
|
||||
(\y x ->
|
||||
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
|
||||
[] -> throwE $ TarDirDoesNotExist tardir
|
||||
(p : _) -> pure (y </> p)
|
||||
)
|
||||
bdir
|
||||
rs
|
||||
where regex = makeRegexOpts compIgnoreCase execBlank
|
||||
|
||||
|
||||
|
||||
|
||||
------------
|
||||
@@ -388,16 +483,17 @@ urlBaseName :: MonadThrow m
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
|
||||
-- while ignoring *-<ver> symlinks and accounting for cross triple prefix.
|
||||
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
|
||||
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
|
||||
--
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
|
||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
--
|
||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
||||
ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
|
||||
-- fail if ghc is not installed
|
||||
@@ -439,17 +535,20 @@ ghcToolFiles ver = do
|
||||
isHadrian = fmap (/= SymbolicLink) . getFileType
|
||||
|
||||
|
||||
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
|
||||
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader Settings m)
|
||||
=> [ByteString]
|
||||
-> Maybe (Path Abs)
|
||||
-> m (Either ProcessError ())
|
||||
make args workdir = do
|
||||
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
|
||||
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
|
||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
||||
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
||||
|
||||
@@ -474,6 +573,7 @@ applyPatches pdir ddir = do
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
||||
darwinNotarization Darwin path = exec
|
||||
"xattr"
|
||||
@@ -502,24 +602,18 @@ runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
Settings {..} <- lift ask
|
||||
v <- flip
|
||||
onException
|
||||
(do
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteDirRecursive bdir
|
||||
)
|
||||
v <-
|
||||
flip onException exAction
|
||||
$ catchAllE
|
||||
(\es -> do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteDirRecursive bdir
|
||||
exAction
|
||||
throwE (BuildFailed bdir es)
|
||||
)
|
||||
$ action
|
||||
@@ -527,3 +621,25 @@ runBuildAction bdir instdir action = do
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
|
||||
bdir
|
||||
pure v
|
||||
|
||||
|
||||
-- | More permissive version of 'createDirRecursive'. This doesn't
|
||||
-- error when the destination is a symlink to a directory.
|
||||
createDirRecursive' :: Path b -> IO ()
|
||||
createDirRecursive' p =
|
||||
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
|
||||
. createDirRecursive newDirPerms
|
||||
$ p
|
||||
|
||||
where
|
||||
isSymlinkDir e = do
|
||||
ft <- getFileType p
|
||||
case ft of
|
||||
SymbolicLink -> do
|
||||
rp <- canonicalizePath p
|
||||
rft <- getFileType rp
|
||||
case rft of
|
||||
Directory -> pure ()
|
||||
_ -> throwIO e
|
||||
_ -> throwIO e
|
||||
|
||||
|
||||
@@ -1,8 +1,27 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module GHCup.Utils.Dirs where
|
||||
{-|
|
||||
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 : POSIX
|
||||
-}
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
, ghcupGHCBaseDir
|
||||
, ghcupGHCDir
|
||||
, parseGHCupGHCDir
|
||||
, mkGhcupTmpDir
|
||||
, withGHCupTmpDir
|
||||
, relativeSymlink
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
@@ -15,6 +34,7 @@ import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Maybe
|
||||
import HPath
|
||||
import HPath.IO
|
||||
@@ -26,6 +46,7 @@ import Prelude hiding ( abs
|
||||
import System.Posix.Env.ByteString ( getEnv
|
||||
, getEnvDefault
|
||||
)
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Temp.ByteString ( mkdtemp )
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
@@ -36,33 +57,117 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
|
||||
------------------------------
|
||||
--[ 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 (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_DATA_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.local/share|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else do
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
|
||||
|
||||
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
|
||||
-- (which, sadly is not strictly xdg spec).
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
getEnv "XDG_BIN_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.local/bin|])
|
||||
else ghcupBaseDir <&> (</> [rel|bin|])
|
||||
|
||||
|
||||
-- | Defaults to '~/.ghcup/cache'.
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else ghcupBaseDir <&> (</> [rel|cache|])
|
||||
|
||||
|
||||
-- | Defaults to '~/.ghcup/logs'.
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
|
||||
ghcupLogsDir :: IO (Path Abs)
|
||||
ghcupLogsDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup/logs|])
|
||||
else ghcupBaseDir <&> (</> [rel|logs|])
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
getDirs = do
|
||||
baseDir <- ghcupBaseDir
|
||||
binDir <- ghcupBinDir
|
||||
cacheDir <- ghcupCacheDir
|
||||
logsDir <- ghcupLogsDir
|
||||
pure Dirs { .. }
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ GHCup directories ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
-- | ~/.ghcup by default
|
||||
ghcupBaseDir :: IO (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
|
||||
ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs)
|
||||
ghcupGHCBaseDir = do
|
||||
Settings {..} <- ask
|
||||
pure (baseDir dirs </> [rel|ghc|])
|
||||
|
||||
|
||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||
-- The dir may be of the form
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
|
||||
ghcupGHCDir :: (MonadReader Settings m, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
@@ -73,16 +178,6 @@ parseGHCupGHCDir (toFilePath -> f) = do
|
||||
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 :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
@@ -94,6 +189,8 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
@@ -107,3 +204,23 @@ getHomeDirectory = do
|
||||
Nothing -> do
|
||||
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
||||
parseAbs $ UTF8.fromString h -- this is a guess
|
||||
|
||||
|
||||
useXDG :: IO Bool
|
||||
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
|
||||
|
||||
|
||||
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
|
||||
-> Path Abs -- ^ the symlink destination
|
||||
-> ByteString
|
||||
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
||||
let d1 = splitDirectories p1
|
||||
d2 = splitDirectories p2
|
||||
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
||||
cPrefix = drop (length common) d1
|
||||
in joinPath (replicate (length cPrefix) "..")
|
||||
<> joinPath ("/" : (drop (length common) d2))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,41 +1,55 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File
|
||||
Description : File and unix APIs
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
This module handles file and executable handling.
|
||||
Some of these functions use sophisticated logging.
|
||||
-}
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Sequence ( Seq, (|>) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Void
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Optics hiding ((<|), (|>))
|
||||
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.Files.ByteString
|
||||
import System.Posix.Foreign ( oExcl )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( openFd )
|
||||
@@ -45,31 +59,20 @@ import Text.Regex.Posix
|
||||
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import Streamly.External.Posix.DirStream
|
||||
import qualified Streamly.Internal.Memory.ArrayStream
|
||||
as AS
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.Data.Unfold as SU
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
|
||||
|
||||
|
||||
-- | Bool signals whether the regions should be cleaned.
|
||||
data StopThread = StopThread Bool
|
||||
deriving Show
|
||||
|
||||
instance Exception StopThread
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
| PTerminated ByteString [ByteString]
|
||||
| PStopped ByteString [ByteString]
|
||||
@@ -87,25 +90,6 @@ data CapturedProcess = CapturedProcess
|
||||
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.
|
||||
--
|
||||
@@ -133,110 +117,155 @@ executeOut path args chdir = captureOutStreams $ do
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
execLogged :: ByteString -- ^ thing to execute
|
||||
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
||||
=> ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Path Rel -- ^ log filename
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
-> m (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
|
||||
Settings {dirs = Dirs {..}, ..} <- ask
|
||||
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
|
||||
closeFd
|
||||
(action verbose)
|
||||
where
|
||||
action fd = do
|
||||
action verbose fd = do
|
||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||
-- start the thread that logs to stdout in a region
|
||||
done <- newEmptyMVar
|
||||
tid <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||
-- start the thread that logs to stdout
|
||||
pState <- newEmptyMVar
|
||||
done <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip finally (putMVar done ())
|
||||
$ printToRegion fd stdoutRead 6
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ (if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6 pState
|
||||
)
|
||||
|
||||
-- fork our subprocess
|
||||
-- fork the subprocess
|
||||
pid <- SPPB.forkProcess $ do
|
||||
void $ dupTo stdoutWrite stdOutput
|
||||
void $ dupTo stdoutWrite stdError
|
||||
closeFd stdoutWrite
|
||||
closeFd stdoutRead
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
void $ 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
|
||||
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
|
||||
putMVar pState (either (const False) (const True) e)
|
||||
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
closeFd stdoutRead
|
||||
|
||||
pure e
|
||||
|
||||
tee :: Fd -> Fd -> IO ()
|
||||
tee fileFd fdIn = readTilEOF lineAction fdIn
|
||||
|
||||
where
|
||||
lineAction :: ByteString -> IO ()
|
||||
lineAction bs' = do
|
||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
||||
|
||||
-- Reads fdIn and logs the output in a continous scrolling area
|
||||
-- of 'size' terminal lines. Also writes to a log file.
|
||||
printToRegion 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
|
||||
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
|
||||
(\(StopThread b) -> do
|
||||
when b (forM_ rs closeConsoleRegion)
|
||||
EX.throw (StopThread b)
|
||||
(\(ex :: SomeException) -> do
|
||||
ps <- liftIO $ takeMVar pState
|
||||
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
|
||||
throw ex
|
||||
)
|
||||
$ do
|
||||
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
|
||||
-- wait for explicit stop from the parent to signal what cleanup to run
|
||||
forever (threadDelay 5000)
|
||||
$ readTilEOF (lineAction rs) fdIn
|
||||
|
||||
where
|
||||
-- action to perform line by line
|
||||
lineAction ref rs bs' = do
|
||||
modifyIORef' ref (swapRegs bs')
|
||||
regs <- readIORef ref
|
||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
forM (zip regs rs) $ \(bs, r) -> do
|
||||
setConsoleRegion r $ do
|
||||
w <- consoleWidth
|
||||
return
|
||||
. T.pack
|
||||
. color Blue
|
||||
. T.unpack
|
||||
. decUTF8Safe
|
||||
. trim w
|
||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
||||
$ bs
|
||||
-- TODO: do this with vty for efficiency
|
||||
lineAction :: (MonadMask m, MonadIO m)
|
||||
=> Seq ConsoleRegion
|
||||
-> ByteString
|
||||
-> StateT (Seq ByteString) m ()
|
||||
lineAction rs = \bs' -> do
|
||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
modify (swapRegs bs')
|
||||
regs <- get
|
||||
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
|
||||
w <- consoleWidth
|
||||
return
|
||||
. T.pack
|
||||
. color Blue
|
||||
. T.unpack
|
||||
. decUTF8Safe
|
||||
. trim w
|
||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
||||
$ bs
|
||||
|
||||
swapRegs bs regs | length regs < size = regs ++ [bs]
|
||||
| otherwise = tail regs ++ [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 w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
|
||||
| otherwise = bs
|
||||
trim :: Int -> ByteString -> ByteString
|
||||
trim w = \bs -> if
|
||||
| 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'
|
||||
-- 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 = \inBs -> go inBs
|
||||
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 action' fd' = do
|
||||
bs <- readLine fd'
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
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
|
||||
@@ -273,13 +302,12 @@ captureOutStreams action = do
|
||||
done <- newEmptyMVar
|
||||
_ <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip finally (putMVar done ())
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||
|
||||
status <- SPPB.getProcessStatus True True pid
|
||||
takeMVar done
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
|
||||
case status of
|
||||
-- readFd will take care of closing the fd
|
||||
@@ -299,13 +327,13 @@ captureOutStreams action = do
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip finally (putMVar doneOut ())
|
||||
$ flip EX.finally (putMVar doneOut ())
|
||||
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
|
||||
doneErr <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip finally (putMVar doneErr ())
|
||||
$ flip EX.finally (putMVar doneErr ())
|
||||
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
|
||||
takeMVar doneOut
|
||||
takeMVar doneErr
|
||||
@@ -351,21 +379,13 @@ toProcessError :: 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 (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
-- | 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`.
|
||||
@@ -409,3 +429,24 @@ findFiles' path parser = do
|
||||
Right p' -> isJust $ MP.parseMaybe parser p')
|
||||
$ dirContentsStream dirStream
|
||||
pure $ join $ fmap parseRel f
|
||||
|
||||
|
||||
isBrokenSymlink :: Path Abs -> IO Bool
|
||||
isBrokenSymlink p =
|
||||
handleIO
|
||||
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
|
||||
$ do
|
||||
_ <- canonicalizePath p
|
||||
pure False
|
||||
|
||||
|
||||
chmod_777 :: (MonadLogger m, MonadIO m) => Path a -> m ()
|
||||
chmod_777 (toFilePath -> fp) = do
|
||||
let exe_mode =
|
||||
newFilePerms
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
$(logDebug) [i|chmod 777 #{fp}|]
|
||||
liftIO $ setFileMode fp exe_mode
|
||||
|
||||
|
||||
@@ -1,10 +1,25 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Logger
|
||||
Description : logger definition
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Here we define our main logger.
|
||||
-}
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Logger
|
||||
import HPath
|
||||
import HPath.IO
|
||||
@@ -50,11 +65,12 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs)
|
||||
initGHCupFileLogging context = do
|
||||
logs <- ghcupLogsDir
|
||||
let logfile = logs </> context
|
||||
createDirIfMissing newDirPerms logs
|
||||
hideError doesNotExistErrorType $ deleteFile logfile
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
Settings {dirs = Dirs {..}} <- ask
|
||||
let logfile = logsDir </> context
|
||||
liftIO $ do
|
||||
createDirRecursive' logsDir
|
||||
hideError doesNotExistErrorType $ deleteFile logfile
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
|
||||
@@ -1,6 +1,15 @@
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Utils.MegaParsec where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
@@ -1,164 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | A module to retrieve os-release information according to the
|
||||
-- freedesktop standard:
|
||||
-- https://www.freedesktop.org/software/systemd/man/os-release.html
|
||||
--
|
||||
-- Some of it is stolen from:
|
||||
-- https://hackage.haskell.org/package/os-release-0.2.2/docs/src/System-OsRelease.html
|
||||
module GHCup.Utils.OsRelease where
|
||||
|
||||
import GHCup.Utils.MegaParsec
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Char
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Void
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
)
|
||||
|
||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Text.Megaparsec.Char as MP
|
||||
|
||||
|
||||
-- | All the explicitly documented fields of `os-release`.
|
||||
data OsRelease = OsRelease {
|
||||
name :: Maybe String
|
||||
, version :: Maybe String
|
||||
, id :: Maybe String
|
||||
, id_like :: Maybe String
|
||||
, version_codename :: Maybe String
|
||||
, version_id :: Maybe String
|
||||
, pretty_name :: Maybe String
|
||||
, ansi_color :: Maybe String
|
||||
, cpe_name :: Maybe String
|
||||
, home_url :: Maybe String
|
||||
, documentation_url :: Maybe String
|
||||
, support_url :: Maybe String
|
||||
, bug_report_url :: Maybe String
|
||||
, privacy_policy_url :: Maybe String
|
||||
, build_id :: Maybe String
|
||||
, variant :: Maybe String
|
||||
, variant_id :: Maybe String
|
||||
, logo :: Maybe String
|
||||
} deriving (Show)
|
||||
|
||||
emptyOsRelease :: OsRelease
|
||||
emptyOsRelease = OsRelease { name = Nothing
|
||||
, version = Nothing
|
||||
, id = Nothing
|
||||
, id_like = Nothing
|
||||
, version_codename = Nothing
|
||||
, version_id = Nothing
|
||||
, pretty_name = Nothing
|
||||
, ansi_color = Nothing
|
||||
, cpe_name = Nothing
|
||||
, home_url = Nothing
|
||||
, documentation_url = Nothing
|
||||
, support_url = Nothing
|
||||
, bug_report_url = Nothing
|
||||
, privacy_policy_url = Nothing
|
||||
, build_id = Nothing
|
||||
, variant = Nothing
|
||||
, variant_id = Nothing
|
||||
, logo = Nothing
|
||||
}
|
||||
|
||||
-- | Parse a single line assignment and extract the right hand side.
|
||||
-- This is only a subset of a shell parser, see
|
||||
-- https://www.freedesktop.org/software/systemd/man/os-release.html
|
||||
parseAssignment :: MP.Parsec Void String (String, String)
|
||||
parseAssignment =
|
||||
(,)
|
||||
<$> (MP.space *> key)
|
||||
<*> (MP.char '=' *> (MP.try qval <|> mempty) <* MP.space <* MP.eof)
|
||||
where
|
||||
dropSpace :: String -> String
|
||||
dropSpace = reverse . dropWhile (\x -> x == ' ' || x == '\t') . reverse
|
||||
|
||||
key :: MP.Parsec Void String String
|
||||
key = some (MP.try MP.alphaNumChar <|> MP.char '_')
|
||||
|
||||
qval :: MP.Parsec Void String String
|
||||
qval = do
|
||||
c <- MP.lookAhead MP.printChar
|
||||
case c of
|
||||
' ' -> pure ""
|
||||
'"' -> MP.char c *> val c <* MP.char c
|
||||
'\'' -> MP.char c *> val c <* MP.char c
|
||||
-- no quote, have to drop trailing spaces
|
||||
_ -> fmap dropSpace (some MP.alphaNumChar)
|
||||
val :: Char -> MP.Parsec Void String String
|
||||
val q = many (qspecial q <|> MP.noneOf (specials q)) -- noneOf may be too lax
|
||||
|
||||
qspecial :: Char -> MP.Parsec Void String Char
|
||||
qspecial q =
|
||||
fmap (!! 1)
|
||||
. choice'
|
||||
. fmap (\s -> MP.try . MP.chunk $ ['\\', s])
|
||||
$ (specials q)
|
||||
|
||||
specials :: Char -> [Char]
|
||||
specials q = [q, '\\', '$', '`']
|
||||
|
||||
|
||||
-- | Get all allAssignments as `(key, val)` from the `os-release`
|
||||
-- file contents.
|
||||
allAssignments :: String -- ^ file contents of os-release
|
||||
-> [(String, String)]
|
||||
allAssignments = rights . fmap (MP.parse parseAssignment "") . lines
|
||||
|
||||
|
||||
-- | Parse the assignments into OsRelease.
|
||||
--
|
||||
-- This can't fail and will create an "empty" product type instead on
|
||||
-- failure.
|
||||
osRelease :: [(String, String)] -- ^ assignments
|
||||
-> OsRelease
|
||||
osRelease =
|
||||
(\case
|
||||
Error _ -> emptyOsRelease
|
||||
Success v -> v
|
||||
)
|
||||
. fromJSON
|
||||
. Object
|
||||
. HM.fromList
|
||||
. fmap (\(k, v) -> (T.toLower . T.pack $ k, String . T.pack $ v))
|
||||
|
||||
|
||||
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order.
|
||||
-- Throws an exception if both files do not exist.
|
||||
readOsRelease :: IO String
|
||||
readOsRelease = do
|
||||
let os_release1 :: Path Abs
|
||||
os_release1 = [abs|/etc/os-release|]
|
||||
let os_release2 :: Path Abs
|
||||
os_release2 = [abs|/usr/lib/os-release|]
|
||||
|
||||
bs <- readFile os_release1 <|> readFile os_release2
|
||||
-- os-release is utf8
|
||||
pure . UTF8.toString $ bs
|
||||
|
||||
|
||||
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order
|
||||
-- and parses into `OsRelease`. Throws an exception if both files do not
|
||||
-- exist.
|
||||
parseOsRelease :: IO OsRelease
|
||||
parseOsRelease = fmap (osRelease . allAssignments) readOsRelease
|
||||
|
||||
|
||||
deriveJSON defaultOptions ''OsRelease
|
||||
@@ -8,6 +8,17 @@
|
||||
{-# 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 : POSIX
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
-}
|
||||
module GHCup.Utils.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
@@ -165,6 +176,11 @@ 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 :: [IOErrorType] -> a -> IO a -> IO a
|
||||
hideErrorDef errs def =
|
||||
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
|
||||
|
||||
@@ -1,25 +1,35 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- | 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
|
||||
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 : POSIX
|
||||
|
||||
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
|
||||
)
|
||||
|
||||
@@ -7,6 +7,15 @@
|
||||
{-# 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 : POSIX
|
||||
-}
|
||||
module GHCup.Utils.Version.QQ where
|
||||
|
||||
import Data.Data
|
||||
@@ -42,7 +51,6 @@ 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
|
||||
|
||||
@@ -1,6 +1,15 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
|
||||
{-|
|
||||
Module : GHCup.Version
|
||||
Description : Static version information
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Version where
|
||||
|
||||
import GHCup.Utils.Version.QQ
|
||||
@@ -11,12 +20,14 @@ import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | This reflects the API version of the JSON.
|
||||
-- | This reflects the API version of the YAML.
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
|
||||
|
||||
-- | The current ghcup version.
|
||||
ghcUpVer :: PVP
|
||||
ghcUpVer = [pver|0.1.5|]
|
||||
ghcUpVer = [pver|0.1.10|]
|
||||
|
||||
-- | ghcup version as numeric string.
|
||||
numericVer :: String
|
||||
numericVer = T.unpack . prettyPVP $ ghcUpVer
|
||||
|
||||
@@ -101,6 +101,7 @@ body#idx p.other-help {
|
||||
|
||||
.instructions div.command-button {
|
||||
display: flex;
|
||||
align-items: center;
|
||||
}
|
||||
|
||||
.instructions div.command-button button {
|
||||
@@ -111,7 +112,7 @@ body#idx p.other-help {
|
||||
border-style: solid;
|
||||
border-radius: 3px;
|
||||
|
||||
margin-left: 1rem;
|
||||
margin-left: 0.5rem;
|
||||
margin-right: auto;
|
||||
margin-top: 25px;
|
||||
margin-bottom: 25px;
|
||||
@@ -134,20 +135,21 @@ hr {
|
||||
#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-win32 > div > pre,
|
||||
#platform-instructions-win64 > div > pre,
|
||||
#platform-instructions-default > div > div > pre,
|
||||
#platform-instructions-unknown > div > div > pre {
|
||||
background-color: #515151;
|
||||
color: white;
|
||||
margin-left: auto;
|
||||
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,
|
||||
|
||||
@@ -46,6 +46,9 @@
|
||||
<p>
|
||||
To install Haskell, follow the instructions on
|
||||
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
|
||||
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
|
||||
</p>
|
||||
<div 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>
|
||||
<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>
|
||||
@@ -55,6 +58,9 @@
|
||||
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 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
|
||||
</p>
|
||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
||||
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
|
||||
</div>
|
||||
|
||||
@@ -77,7 +83,7 @@
|
||||
|
||||
<!-- duplicate the default cross-platform instructions -->
|
||||
<div>
|
||||
<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>
|
||||
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
||||
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
||||
</div>
|
||||
@@ -95,7 +101,7 @@
|
||||
|
||||
<div id="platform-instructions-default" class="instructions">
|
||||
<div>
|
||||
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
|
||||
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
|
||||
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
|
||||
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
|
||||
@@ -140,7 +146,7 @@
|
||||
|
||||
<div id="platform-instructions-default" class="instructions">
|
||||
<div>
|
||||
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
|
||||
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
|
||||
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
|
||||
<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>
|
||||
|
||||
Reference in New Issue
Block a user