Compare commits

...

91 Commits

Author SHA1 Message Date
86a4b10de6 Merge branch 'yaml' 2020-08-10 08:58:55 +02:00
cfa7049ab9 Merge branch 'CI' 2020-08-09 22:11:48 +02:00
391676e90a Use yaml instead of pesky json 2020-08-09 21:56:11 +02:00
34e4ece8b5 Merge branch 'ghc-8.10.2' 2020-08-09 16:14:04 +02:00
cf6443d83f Add GHC-8.10.2 2020-08-09 15:53:56 +02:00
846cf92fa4 Add GHC-8.10.2 2020-08-09 15:49:08 +02:00
ab568901f8 Try to build for El Capitan 2020-07-22 22:50:13 +02:00
bfda95c0d6 Fix haskus-utils-types build with GHC-8.10.1 2020-07-22 02:35:22 +02:00
fb1875ee5b Doc fixes 2020-07-22 02:34:17 +02:00
185d4f869b Remove unnecessary bundles 2020-07-22 01:37:15 +02:00
2ac8b61aa8 Fix bootstrap-haskell when ghcup is a broken script
Fixes #28
2020-07-22 01:25:12 +02:00
8739cb4656 Enable haddock building in CI 2020-07-22 01:11:37 +02:00
826900cc41 Improve documentation 2020-07-22 01:08:58 +02:00
ec6bbdbf06 Update ghcup binaries 2020-07-22 00:18:31 +02:00
15a188c501 Update FreeBSD 8.10.1 2020-07-22 00:17:14 +02:00
b5440fc7d2 Fix bug in installCabalBin 2020-07-21 23:10:47 +02:00
4b21adadf1 Release 0.1.8 2020-07-21 22:47:21 +02:00
78ae77780b Fix bug in logging thread
It would die on newlines due to empty String blindness.
Also make sure takeMVar does not block.
2020-07-21 22:43:09 +02:00
ccb95bcbee f custom 2020-07-21 22:42:39 +02:00
21ac670bbe Update FreeBSD bindist 2020-07-21 21:08:41 +02:00
8b54dee66c Merge branch 'CI-m' 2020-07-21 20:21:53 +02:00
dad926f3ba Allow to specify custom bindist, fixes #14 2020-07-21 20:19:33 +02:00
a298d949b5 Remove FreeBSD workaround in CI 2020-07-21 19:00:10 +02:00
e1cf11f9d4 Add Alpine GHC 8.4.4 for 64bit 2020-07-21 01:18:03 +02:00
a046f16308 Remove libtinfo compat symlinks 2020-07-21 00:36:31 +02:00
97cd43792d Set 8.8.4 as recommended GHC version 2020-07-21 00:31:02 +02:00
08693e6d3a Add more alpine bindists 2020-07-21 00:29:46 +02:00
e2227da8d2 Update ghcup binaries 2020-07-21 00:02:14 +02:00
5f20e4c583 Bump versions in CI 2020-07-20 23:57:26 +02:00
f82f1a12dd Update version in bootstrap-script 2020-07-20 23:04:11 +02:00
53148fd1c9 Release 0.1.7 2020-07-20 22:25:28 +02:00
8985101b2a Use 8.8.4 for test build 2020-07-20 22:25:09 +02:00
d1949c8490 Use available bindists for release build 2020-07-20 22:24:21 +02:00
b7faae1203 Add more alpine bindists 2020-07-20 22:20:24 +02:00
b6a9d35c3e Merge branch 'alpine-bindists' 2020-07-20 20:59:08 +02:00
6cb6c7a448 Install alpine bindists with --disable-ld-override 2020-07-20 20:48:22 +02:00
22a5ad739e Don't try non-musl bindists for Alpine Linux 2020-07-20 20:47:45 +02:00
14c91bdd78 Merge branch 'libarchive-fix' 2020-07-20 20:34:54 +02:00
2c638cd2e2 Fix unpacking of bindists with hardinks pointing to themselves
https://github.com/vmchale/libarchive/issues/14
https://github.com/libarchive/libarchive/issues/1381
2020-07-20 20:34:36 +02:00
9e59f484e3 Fix alpine bindists 2020-07-20 20:30:47 +02:00
ac8419ecb2 Fix platform detection for i386 docker images wrt #37 2020-07-20 20:30:36 +02:00
3ecdb63063 Update tarballs 2020-07-19 00:50:57 +02:00
cfe24428fa Only check for upgrades when not upgrading 2020-07-19 00:47:20 +02:00
4c4266dd8c Add GHC-8.8.4 for FreeBSD 2020-07-16 14:38:19 +02:00
e8336bbc8a Add GHC-8.8.4 2020-07-16 10:57:44 +02:00
0f69c73e0e Rework printing/tee
This should be faster to draw, use less syscalls
and generally use EOF and pipes correctly.
2020-07-16 00:10:27 +02:00
e348de8dc4 Drop unused error variants 2020-07-14 19:16:01 +02:00
55a3ba9be2 Improve fish support in bootstrap-haskell 2020-07-14 19:08:20 +02:00
51b29b81b0 Use new-style ghcup commands in bootstrap-haskell 2020-07-14 19:07:57 +02:00
3c2e0334b7 Update ghcup binary urls 2020-07-14 19:07:19 +02:00
0679626514 Self host ghcup binaries 2020-07-14 14:29:23 +02:00
5035051135 Update 0.1.6 2020-07-13 23:50:11 +02:00
63c70ee74b Fix changelog subcommand on darwin 2020-07-13 23:10:17 +02:00
2e0bbca2e0 Fix freebsd tui 2020-07-13 22:45:38 +02:00
b52fa23ca2 Update alpine install-deps 2020-07-13 22:34:38 +02:00
ba03b78f23 Update ghcup binaries 2020-07-13 22:15:39 +02:00
04ef472c15 Fix freebsd gitlab-ci 2020-07-13 21:29:13 +02:00
75cd8f2341 Fix stripping in travis 2020-07-13 21:17:01 +02:00
f2e26c1800 Fix release build 2020-07-13 20:48:37 +02:00
0f7dd597d2 Update .gitignore 2020-07-13 20:37:34 +02:00
fb0eba9201 Release 0.1.6 2020-07-13 20:31:14 +02:00
3c80929c38 Merge branch 'ghc-8.10.1' 2020-07-13 20:06:17 +02:00
b184ee835f Add freebsd 8.6.5 bindist 2020-07-13 20:05:02 +02:00
ef8e3bd940 Reduce number of os/dl lookups 2020-07-13 18:27:21 +02:00
1a64527e14 Improve verbosity 2020-07-13 16:27:01 +02:00
30b4d399b9 Add -ftui to travis build 2020-07-13 16:26:54 +02:00
50424c2801 Allow to build with tar-bytestring on e.g. 32bit 2020-07-13 15:41:31 +02:00
7e7c357e47 Fix freebsd CI 2020-07-13 15:41:30 +02:00
531b82a406 Add ghc-8.8.3 freebsd bindist 2020-07-13 15:41:30 +02:00
146ac38549 Add 8.10.1 freebsd bindist 2020-07-12 16:48:25 +02:00
c481956b07 Bump GHC versions in CI 2020-07-11 23:03:04 +02:00
8ef19f0825 Allow to build with ghc-8.10.1 and 8.6.5 2020-07-11 22:53:38 +02:00
c1e29a8f16 Rm bundled os-release 2020-07-11 21:25:45 +02:00
c3611eec6a Grey out versions without bindists in tui 2020-07-11 18:53:11 +02:00
74b58db7d1 Merge branch 'tui' 2020-07-11 13:32:34 +02:00
9e4763c640 Merge branch 'www-wsl' 2020-07-11 00:00:53 +02:00
abc4278fc8 Improve style 2020-07-10 23:55:01 +02:00
8c4cde3d14 Recommend the curl command for potential WSL users on website
Fixes #32
2020-07-10 23:53:55 +02:00
3824f6417a Update libarchive 2020-07-10 22:44:16 +02:00
Ben Gamari
2be1aa2707 Simplify upgrade copying logic 2020-07-10 22:03:04 +02:00
da94fa5f92 Create brick tui wrt #24 2020-07-10 21:55:12 +02:00
35bf9b5ff2 Merge branch 'libarchive' 2020-07-05 23:33:47 +02:00
bed2cca8d2 Use libarchive instead of tar-bytestring 2020-07-05 23:03:24 +02:00
9717a1c00f Use os-release package 2020-07-04 23:28:30 +02:00
3ddc719d8a Fix quasi quotes in Main 2020-07-04 21:49:59 +02:00
4b89810892 Rm unused functions 2020-07-04 21:20:08 +02:00
b82367838d Fix memory leak 2020-07-04 21:18:51 +02:00
dd7556ba21 Merge branch 'less-bash' 2020-06-27 21:38:12 +02:00
f4b6bfc594 Merge branch 'better-platform' 2020-06-27 21:37:45 +02:00
2de549862a Get rid of language-bash
And clean up detection logic a bit. We also don't
read /etc/lsb-release manually more, since it's format is
not specified.
2020-06-27 18:54:20 +02:00
c502f70f68 Update DOCKER_REV 2020-06-27 01:38:38 +02:00
45 changed files with 2665 additions and 5167 deletions

7
.gitignore vendored
View File

@@ -5,3 +5,10 @@ dist-newstyle/
cabal.project.local
.stack-work/
bin/
/*.prof
/*.ps
/*.hp
tags
TAGS
/tmp/
.entangled

View File

@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
############################################################
# CI Step
@@ -97,13 +97,13 @@ 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.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -113,13 +113,13 @@ test:linux:latest:
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.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -129,13 +129,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.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -150,7 +150,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 +162,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 +193,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"

View File

@@ -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

View File

@@ -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

View File

@@ -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}

View File

@@ -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,11 +21,13 @@ git describe --always
ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION}
ecabal build -w ghc-${GHC_VERSION} -ftui
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal haddock
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')" .
@@ -40,16 +42,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}

View File

@@ -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:

View File

@@ -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}"

View File

@@ -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

View File

@@ -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

View File

@@ -1,5 +1,31 @@
# Revision history for ghcup
## 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

View File

@@ -40,7 +40,13 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
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

View File

@@ -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`

View File

@@ -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)

View File

@@ -179,7 +179,7 @@ validateTarballs dls = do
where
downloadAll dli = do
let settings = Settings True False Never Curl
let settings = Settings True False Never Curl False
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

362
app/ghcup/BrickMain.hs Normal file
View File

@@ -0,0 +1,362 @@
{-# 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 (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)
, ("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
r <- action as (ix, e)
case r of
Left err -> throwIO $ userError err
Right _ -> do
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]
(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
(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}|]

View File

@@ -10,6 +10,10 @@
module Main where
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
import GHCup
import GHCup.Download
import GHCup.Errors
@@ -21,8 +25,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 +38,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 +69,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 +103,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 +121,7 @@ data InstallCommand = InstallGHC InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe DownloadInfo
}
data SetCommand = SetGHC SetOptions
@@ -221,7 +235,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 +339,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,7 +400,7 @@ 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>".|]
@@ -381,7 +408,7 @@ installParser =
installOpts :: Parser InstallOptions
installOpts =
(flip InstallOptions)
(\p u v -> InstallOptions v p u)
<$> (optional
(option
(eitherReader platformParser)
@@ -393,6 +420,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\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
)
)
)
<*> optional toolVersionArgument
@@ -424,13 +462,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 +568,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,6 +814,8 @@ 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
@@ -784,6 +824,7 @@ toSettings Options {..} =
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
in Settings { .. }
@@ -843,7 +884,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.
@@ -868,11 +909,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|]
let runLogger = myLoggerT LoggerConfig
let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
let runLogger = myLoggerT loggerConfig
-------------------------
@@ -886,13 +928,13 @@ 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
@@ -907,7 +949,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, TagNotFound
]
let
@@ -918,9 +959,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runListGHC = runLogger
let runRmGHC =
let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
@@ -937,15 +978,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
let runCompileCabal =
@@ -957,14 +998,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
let runUpgrade =
@@ -973,9 +1014,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, NoUpdate
, FileDoesNotExistError
@@ -984,9 +1022,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 +1049,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 $ checkForUpdates dls pfreq
-----------------------
@@ -1018,7 +1063,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
@@ -1052,7 +1099,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
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
@@ -1102,7 +1151,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 +1161,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 +1173,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 +1193,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 +1223,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig
patchDir
addConfArgs
pfreq
)
>>= \case
VRight _ -> do
@@ -1201,7 +1248,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
@@ -1232,7 +1279,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [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 +1331,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
@@ -1378,37 +1430,32 @@ printListResult raw lr = do
checkForUpdates :: (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

View File

@@ -18,26 +18,39 @@ edo()
}
eghcup() {
edo _eghcup "$@"
}
_eghcup() {
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
edo ghcup "$@"
ghcup "$@"
else
edo ghcup --verbose "$@"
ghcup --verbose "$@"
fi
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.5"
_ghver="0.1.8"
_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 +66,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 +78,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
unset _plat _arch _url _ghver
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
unset _plat _arch _url _ghver _base_url
}
@@ -101,18 +123,10 @@ edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
if command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
eghcup upgrade
_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 +143,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
@@ -163,6 +177,9 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
exit 0
fi
;;
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) exit 0 ;;
esac
@@ -178,7 +195,16 @@ 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)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env ; and set -gx PATH \$HOME/.cabal/bin \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
break ;;
*)
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
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;;

View File

@@ -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: static
allow-newer: base ghc-prim template-haskell

File diff suppressed because it is too large Load Diff

1322
ghcup-0.0.2.yaml Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.5
version: 0.1.8
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,8 +111,8 @@ common http-io-streams
common io-streams
build-depends: io-streams >=1.5
common language-bash
build-depends: language-bash >=0.9
common libarchive
build-depends: libarchive >= 2.2.5.2
common lzma
build-depends: lzma >=0.0.0.3
@@ -158,17 +171,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
@@ -176,12 +189,18 @@ 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
common unix-bytestring
build-depends: unix-bytestring >=0.3
common unordered-containers
build-depends: unordered-containers >= 0.2.10.0
common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2
@@ -194,12 +213,15 @@ common vector
common versions
build-depends: versions >=3.5
common waargonaut
build-depends: waargonaut >=0.8
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
@@ -242,7 +264,6 @@ library
, hpath-filepath
, hpath-io
, hpath-posix
, language-bash
, lzma
, megaparsec
, monad-logger
@@ -260,25 +281,24 @@ library
, streamly-bytestring
, strict-base
, string-interpolate
, tar-bytestring
, template-haskell
, text
, time
, transformers
, os-release
, unix
, unix-bytestring
, unordered-containers
, uri-bytestring
, utf8-string
, vector
, versions
, word8
, yaml
, zlib
exposed-modules:
GHCup
GHCup.Data.GHCupDownloads
GHCup.Data.GHCupInfo
GHCup.Data.ToolRequirements
GHCup.Download
GHCup.Download.Utils
GHCup.Errors
@@ -288,7 +308,6 @@ library
GHCup.Types.JSON
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.Logger
@@ -304,17 +323,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
@@ -348,6 +376,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:
@@ -373,6 +414,7 @@ executable ghcup-gen
, uri-bytestring
, utf8-string
, versions
, yaml
--
main-is: Main.hs

View File

@@ -11,6 +11,21 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup
Description : GHCup installation functions
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module contains the main functions that correspond
to the command line interface, like installation, listing versions
and so on.
These are the entry points.
-}
module GHCup where
@@ -27,6 +42,9 @@ import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import GHCup.Version
#if !defined(TAR)
import Codec.Archive ( ArchiveResult )
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -47,7 +65,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
@@ -73,42 +91,40 @@ import qualified Data.Text.Encoding as E
-------------------------
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installGHCBin bDls ver mpfReq = do
-- | Like 'installGHCBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installGHCBindist :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> PlatformRequest -- ^ the platform to install on
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver)
Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version)
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
@@ -128,48 +144,90 @@ installGHCBin bDls ver mpfReq = do
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadLogger m, MonadIO m)
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ liftIO $ execLogged "./configure"
lEM $ execLogged "./configure"
False
["--prefix=" <> toFilePath inst]
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ liftIO $ make ["install"] (Just path)
lEM $ make ["install"] (Just path)
pure ()
alpineArgs
| ver >= [vver|8.2.2|]
, Linux Alpine <- _rPlatform = ["--disable-ld-override"]
| otherwise = []
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installCabalBin bDls ver mpfReq = do
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
-- following symlinks in @~\/.ghcup\/bin@:
--
-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@
-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads -- ^ the download info to look up the tarball from
-> Version -- ^ the version to install
-> PlatformRequest -- ^ the platform to install on
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installGHCBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
installGHCBindist dlinfo ver pfreq
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
@@ -183,11 +241,7 @@ installCabalBin bDls ver mpfReq = do
)
$ (throwE $ AlreadyInstalled Cabal ver)
Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version)
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
@@ -224,6 +278,40 @@ installCabalBin bDls ver mpfReq = do
Overwrite
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
-- the latest installed version.
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installCabalBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
installCabalBindist dlinfo ver pfreq
---------------------
--[ Set GHC/cabal ]--
@@ -231,15 +319,15 @@ installCabalBin bDls ver mpfReq = do
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> SetGHC
@@ -304,7 +392,7 @@ setGHC ver sghc = do
-- | Set the ~/.ghcup/bin/cabal symlink.
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
@@ -344,10 +432,13 @@ setCabal ver = do
------------------
-- | Filter data type for 'listVersions'.
data ListCriteria = ListInstalled
| ListSet
deriving Show
-- | A list result describes a single tool version
-- and various of its properties.
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
@@ -362,6 +453,7 @@ data ListResult = ListResult
deriving (Eq, Ord, Show)
-- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
availableToolVersions av tool = view
(at tool % non Map.empty % to (fmap (_viTags)))
@@ -379,31 +471,25 @@ listVersions :: ( MonadCatch m
=> GHCupDownloads
-> Maybe Tool
-> Maybe ListCriteria
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
[ListResult]
listVersions av lt criteria = do
pfreq <- platformRequest
-> PlatformRequest
-> m [ListResult]
listVersions av lt criteria pfreq = do
case lt of
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t)
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- lift $ strayGHCs avTools
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria
ghcupvers <- listVersions av (Just GHCup) criteria
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> ghcupvers)
where
@@ -448,8 +534,8 @@ listVersions av lt criteria = do
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult
toListResult pfreq t (v, tags) = case t of
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult t (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v
@@ -496,7 +582,11 @@ listVersions av lt criteria = do
--------------------
-- | This function may throw and crash in various ways.
-- | Delete a ghc version and all its symlinks.
--
-- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version).
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@@ -535,7 +625,8 @@ rmGHCVer ver = do
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | This function may throw and crash in various ways.
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
@@ -584,6 +675,8 @@ getDebugInfo = do
---------------
-- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
@@ -599,23 +692,24 @@ compileGHC :: ( MonadMask m
-> Maybe (Path Abs) -- ^ build config
-> Maybe (Path Abs) -- ^ patch directory
-> [Text] -- ^ additional args to ./configure
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
@@ -629,7 +723,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of
@@ -662,7 +755,7 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
@@ -690,7 +783,7 @@ Stage1Only = YES|]
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( ["--prefix=" <> toFilePath ghcdir]
@@ -704,7 +797,7 @@ Stage1Only = YES|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( [ "--prefix=" <> toFilePath ghcdir
@@ -729,11 +822,11 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ make ["install"] (Just workdir)
lEM $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
@@ -765,6 +858,8 @@ Stage1Only = YES|]
-- | Compile a cabal from source. This behaves wrt symlinks and installation
-- the same as 'installCabalBin'.
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
@@ -777,23 +872,24 @@ compileCabal :: ( MonadReader Settings m
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int
-> Maybe (Path Abs)
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileCabal dls tver bghc jobs patchdir = do
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir
@@ -814,7 +910,6 @@ compileCabal dls tver bghc jobs patchdir = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
@@ -835,7 +930,7 @@ compileCabal dls tver bghc jobs patchdir = do
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
@@ -868,7 +963,7 @@ compileCabal dls tver bghc jobs patchdir = do
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ liftIO $ execLogged "./bootstrap.sh"
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap|]
@@ -884,6 +979,8 @@ compileCabal dls tver bghc jobs patchdir = do
---------------------
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
upgradeGHCup :: ( MonadMask m
, MonadReader Settings m
, MonadCatch m
@@ -896,23 +993,20 @@ upgradeGHCup :: ( MonadMask m
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> PlatformRequest
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NoUpdate
]
m
Version
upgradeGHCup dls mtarget force = do
upgradeGHCup dls mtarget force pfreq = do
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
pfreq <- liftE platformRequest
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
@@ -922,20 +1016,13 @@ upgradeGHCup dls mtarget force = do
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir
liftIO $ hideError NoSuchThing $ deleteFile (dest </> fn)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
(dest </> fn)
Overwrite
liftIO $ setFileMode (toFilePath (dest </> fn)) fileMode'
Just fullDest -> do
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
binDir <- liftIO $ ghcupBinDir
let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
pure latestVer
@@ -945,7 +1032,7 @@ upgradeGHCup dls mtarget force = do
-------------
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion

File diff suppressed because it is too large Load Diff

View File

@@ -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
}

View File

@@ -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"
]
""
)
]
)
]
)
]
)
]

View File

@@ -9,6 +9,23 @@
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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
@@ -118,13 +137,13 @@ getDownloadsF urlSource = do
[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
@@ -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

View File

@@ -3,6 +3,15 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-|
Module : GHCup.Errors
Description : GHCup error types
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Errors where
import GHCup.Types

View File

@@ -6,13 +6,21 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Plaform
Description : Retrieving platform information
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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.Bash
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
@@ -115,7 +124,6 @@ getLinuxDistro = do
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
@@ -140,10 +148,6 @@ getLinuxDistro = do
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
@@ -153,9 +157,9 @@ getLinuxDistro = do
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
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
@@ -164,12 +168,6 @@ getLinuxDistro = do
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap decUTF8Safe' $ readFile redhat_release

View File

@@ -1,5 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Requirements
Description : Requirements utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Requirements where
import GHCup.Types

View File

@@ -2,6 +2,15 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types
Description : GHCup types
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Types where
import Data.Map.Strict ( Map )
@@ -152,6 +161,7 @@ data Settings = Settings
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
}
deriving Show

View File

@@ -10,6 +10,15 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Types.JSON
Description : GHCup JSON types/instances
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Types.JSON where
import GHCup.Types

View File

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

View File

@@ -6,7 +6,18 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -42,7 +56,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 +72,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
@@ -84,7 +104,7 @@ ghcLinkDestination tool ver =
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
-- e.g. ghc-8.6.5
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do
bindir <- liftIO $ ghcupBinDir
@@ -103,7 +123,7 @@ rmMinorSymlinks GHCTargetVersion {..} = do
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- Removes the set ghc version for the given target, if any.
-- | Removes the set ghc version for the given target, if any.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
@@ -122,7 +142,7 @@ rmPlain target = do
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- e.g. ghc-8.6
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion
-> m ()
@@ -153,18 +173,21 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-----------------------------------
-- | Whethe the given GHC versin is installed.
ghcInstalled :: GHCTargetVersion -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
@@ -210,6 +233,7 @@ getInstalledGHCs = do
Left _ -> pure $ Left f
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir
@@ -224,12 +248,14 @@ getInstalledCabals = do
pure $ maybe vs (\x -> Right x:vs) cs
-- | Whether the given cabal version is installed.
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
@@ -248,11 +274,13 @@ cabalSet = do
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
-- | 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)
@@ -310,25 +338,43 @@ 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
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
#endif
#if defined(TAR)
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
#else
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
#endif
rf = liftIO . readFile
-- 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
@@ -388,11 +434,12 @@ 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"]
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel]
@@ -439,17 +486,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 +524,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"

View File

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

View File

@@ -2,6 +2,15 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.Dirs
Description : Definition of GHCup directories
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Utils.Dirs where

View File

@@ -1,37 +1,48 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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.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.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
@@ -45,31 +56,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 +87,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 +114,156 @@ 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 {..} <- ask
ldir <- liftIO ghcupLogsDir
logfile <- (ldir </>) <$> 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 +300,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 +325,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
@@ -358,14 +384,6 @@ toProcessError exe args mps = case mps of
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`.

View File

@@ -1,5 +1,16 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Utils.Logger
Description : logger definition
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Utils

View File

@@ -1,6 +1,15 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Utils.MegaParsec
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Utils.MegaParsec where
import GHCup.Types

View File

@@ -8,6 +8,17 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module : GHCup.Utils.Prelude
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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)

View File

@@ -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 : GPL-3
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
)

View File

@@ -7,6 +7,15 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Version.QQ
Description : Version quasi-quoters
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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

View File

@@ -1,6 +1,15 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Version
Description : Static version information
Copyright : (c) Julian Ospald, 2020
License : GPL-3
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.8|]
-- | ghcup version as numeric string.
numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer

View File

@@ -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,

View File

@@ -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>