Compare commits

..

62 Commits

Author SHA1 Message Date
2fb07201c7 Fix freebsd12 tag 2021-09-24 20:54:55 +02:00
b5ca01dc4f Merge branch 'issue-248' 2021-09-24 20:52:41 +02:00
d662682fb5 Honour NO_COLOR in bootstrap scrips, fixes #248 2021-09-24 20:37:55 +02:00
ff2b06a5e8 Merge branch 'no-color' 2021-09-23 23:28:04 +02:00
aece305003 Move logger stuff to logger module 2021-09-23 12:53:01 +02:00
ef8da9bcec Make sure NO_COLOR also applies to logging 2021-09-23 12:16:49 +02:00
3cd55beab1 Metadata bump 2021-09-21 12:24:24 +02:00
6766501858 Merge branch 'hls-compile-improve' 2021-09-20 23:27:15 +02:00
d5b41683ca Improve HLS compile 2021-09-20 22:24:20 +02:00
ff8dbe111d Fix spelling 2021-09-20 20:01:24 +02:00
28d4071fac Bump version 2021-09-20 19:55:11 +02:00
31a523755f Remove solus support 2021-09-20 19:42:06 +02:00
3d1d8f1af7 Improve optparse hls stuff 2021-09-20 14:43:43 +02:00
167f6d0683 Merge branch 'freebsd-ci' 2021-09-20 12:09:54 +02:00
8580487b61 Add retries 2021-09-20 11:30:58 +02:00
a8b1c33280 Add FreeBSD12 CI back 2021-09-20 11:25:40 +02:00
fca2a4134b Merge branch 'hls-compile' 2021-09-19 22:38:51 +02:00
f90741f4d3 Implement compiling HLS from source 2021-09-19 22:04:32 +02:00
ba4b45f7fb Merge branch 'unset' 2021-09-19 16:25:30 +02:00
4767f3db5b Implement ghcup unset 2021-09-19 14:17:55 +02:00
709658462c Merge branch 'gpg' 2021-09-19 12:28:46 +02:00
c431c0ae00 Implement GPG verification wrt #236 2021-09-18 21:51:19 +02:00
6f61b5dbef Make hlint shut up 2021-09-18 15:47:54 +02:00
c42c4b64f9 Improve logging 2021-09-18 15:46:53 +02:00
d3a36c2c9a Merge remote-tracking branch 'origin/merge-requests/156' 2021-09-18 15:19:06 +02:00
6799e9616e Merge remote-tracking branch 'origin/merge-requests/177' 2021-09-17 22:14:33 +02:00
Emily Pillmore
e8d962ac44 Add language fixes per issue #237 2021-09-17 14:11:00 -06:00
ac1e145028 Update README 2021-09-17 12:00:07 +02:00
2fdf121167 Update readme 2021-09-17 11:54:43 +02:00
dcca8b0bf2 Merge branch 'issue-231' 2021-09-17 11:51:33 +02:00
b1f891b005 Add supported platforms to README 2021-09-17 11:50:26 +02:00
648dcc7287 Update HLS 2021-09-16 21:41:05 +02:00
2175f7dd3d Warn when installing 8.10.5/8.10.6 2021-09-16 16:01:51 +02:00
aff90a52f1 Merge branch 'hls-1.4.0' 2021-09-15 23:08:48 +02:00
0f14dee72a Bump HLS to 1.4.0 2021-09-15 22:41:57 +02:00
ae2031174e Improve warnAboutHlsCompatibility 2021-09-14 12:36:14 +02:00
c163278c64 Merge remote-tracking branch 'origin/merge-requests/172' 2021-09-14 12:26:41 +02:00
d10133f06f Clean up toolRequirements 2021-09-13 22:33:46 +02:00
4377fc663e Merge branch 'opencollective' 2021-09-13 08:43:10 +02:00
487e236882 Add opencollective button 2021-09-13 08:34:13 +02:00
Arjun Kathuria
8fc128e89b move some code around for better consistency 2021-09-12 09:25:09 +05:30
Chris Smith
737f72f90f Lint fix. 2021-09-11 23:35:39 -04:00
Chris Smith
c3aab65521 Rewording 2021-09-11 23:24:21 -04:00
Chris Smith
972474f79a Add version numbers to error message.
Fixes after formatting changes.
2021-09-11 23:17:14 -04:00
bc64d2ade0 Apply 3 suggestion(s) to 1 file(s) 2021-09-12 03:09:36 +00:00
Chris Smith
eddda55fe6 Fix hlint warnings 2021-09-11 19:57:42 -04:00
Chris Smith
13aca91231 Add a warning when the installed HLS and GHC versions are not compatible.
This is triggered when:

1. The user has just set either the GHC or HLS version.
2. There is an HLS version set (so some GHC version is compatible).
3. There is a GHC version.
4. The HLS version doesn't support that GHC version.

Fixes #234
2021-09-11 19:33:27 -04:00
Arjun Kathuria
6011242eae minor cleanup 2021-09-11 23:23:58 +05:30
Arjun Kathuria
cadb5086e1 Implements --force install for GHC 2021-09-11 23:20:06 +05:30
Arjun Kathuria
10a30bbf38 Implements --force install for Stack 2021-09-11 22:04:54 +05:30
Arjun Kathuria
6ac7a75bab Implements --force install for HLS 2021-09-11 22:04:40 +05:30
Arjun Kathuria
d60f58cf43 simplify checkIfToolInstalled for Cabal 2021-09-07 14:22:21 +05:30
Arjun Kathuria
7a6a119829 Patch for MonadLogger deletion since new rebase 2021-09-07 14:21:24 +05:30
Arjun Kathuria
f0fb019c70 Merge branch 'feat-force' of gitlab.haskell.org:arjun/ghcup-hs into feat-force 2021-09-07 11:29:33 +05:30
Arjun Kathuria
0f98ec6b78 factor out checkIfCabalInstalled to checkIfToolInstalled 2021-09-07 11:24:28 +05:30
Arjun Kathuria
107fed6e60 refactor nested case statements when installing cabal 2021-09-07 11:23:30 +05:30
Arjun Kathuria
59a9a770a5 implements --force option for cabal installs. 2021-09-07 11:23:26 +05:30
Arjun Kathuria
20bcb26e3d Adds the --force option in install commands 2021-09-07 11:17:10 +05:30
Arjun Kathuria
be82565775 factor out checkIfCabalInstalled to checkIfToolInstalled 2021-08-30 15:20:33 +05:30
Arjun Kathuria
f8d0243146 refactor nested case statements when installing cabal 2021-08-30 15:18:43 +05:30
Arjun Kathuria
d7f82d643c implements --force option for cabal installs. 2021-08-27 13:06:18 +05:30
Arjun Kathuria
15560a06b1 Adds the --force option in install commands 2021-08-27 13:05:54 +05:30
42 changed files with 1563 additions and 3177 deletions

View File

@@ -49,6 +49,7 @@ variables:
OS: "LINUX"
ARCH: "ARM"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
retry: 2
.linux:aarch64:
image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV"
@@ -75,7 +76,7 @@ variables:
ARCH: "ARM64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.freebsd:
.freebsd13:
tags:
- x86_64-freebsd13
variables:
@@ -83,6 +84,14 @@ variables:
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.freebsd12:
tags:
- x86_64-freebsd12
variables:
OS: "FREEBSD"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
.windows:
tags:
- new-x86_64-windows
@@ -90,6 +99,7 @@ variables:
OS: "WINDOWS"
ARCH: "64"
CABAL_DIR: "$CI_PROJECT_DIR/cabal"
retry: 2
.root_cleanup:
after_script:
@@ -99,7 +109,7 @@ variables:
script:
- bash ./.gitlab/script/ghcup_version.sh
variables:
JSON_VERSION: "0.0.7"
JSON_VERSION: "0.0.6"
artifacts:
expire_in: 2 week
paths:
@@ -173,10 +183,18 @@ variables:
runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1
runInNixShell ./.gitlab/script/ghcup_version.sh 2>&1
.test_ghcup_version:freebsd:
.test_ghcup_version:freebsd12:
extends:
- .test_ghcup_version
- .freebsd
- .freebsd12
- .root_cleanup
before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh
.test_ghcup_version:freebsd13:
extends:
- .test_ghcup_version
- .freebsd13
- .root_cleanup
before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh
@@ -207,7 +225,7 @@ variables:
only:
- tags
variables:
JSON_VERSION: "0.0.7"
JSON_VERSION: "0.0.6"
######## stack test ########
@@ -263,6 +281,23 @@ test:linux:
CABAL_VERSION: "3.4.0.0"
needs: []
test:linux:hls:
stage: test
extends:
- .test_ghcup_version
- .debian
variables:
GHC_VERSION: "8.10.7"
HLS_TARGET_VERSION: "1.4.0"
CABAL_VERSION: "3.6.0.0"
needs: []
when: manual
allow_failure: true
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
script:
- ./.gitlab/script/ghcup_hls.sh
test:linux:cross-armv7:
stage: test
extends:
@@ -355,9 +390,19 @@ test:mac:aarch64:
######## freebsd test ########
test:freebsd:
test:freebsd12:
stage: test
extends: .test_ghcup_version:freebsd
extends: .test_ghcup_version:freebsd12
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
test:freebsd13:
stage: test
extends: .test_ghcup_version:freebsd13
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
@@ -491,11 +536,26 @@ release:darwin:aarch64:
######## freebsd release ########
release:freebsd:
release:freebsd12:
stage: release
needs: ["test:freebsd"]
needs: ["test:freebsd12"]
extends:
- .freebsd
- .freebsd12
- .release_ghcup
- .root_cleanup
before_script:
- ./.gitlab/before_script/freebsd/install_deps.sh
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.10.6"
CABAL_VERSION: "3.4.0.0"
allow_failure: true
release:freebsd13:
stage: release
needs: ["test:freebsd13"]
extends:
- .freebsd13
- .release_ghcup
- .root_cleanup
before_script:

View File

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

51
.gitlab/script/ghcup_hls.sh Executable file
View File

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

View File

@@ -101,6 +101,10 @@ eghcup install ghc ${GHC_VERSION}
eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit || echo yes
eghcup set cabal ${CABAL_VERSION}
[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
cabal --version
@@ -151,9 +155,13 @@ else
[ "$(ghc --numeric-version)" = "8.10.3" ]
eghcup set ${GHC_VERSION}
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup unset ghc
"$GHCUP_BIN"/ghc --numeric-version && exit || echo yes
eghcup set ${GHC_VERSION}
eghcup --offline rm 8.10.3
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
$(eghcup whereis hls) --version
@@ -164,9 +172,13 @@ else
if [ "${ARCH}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
eghcup unset hls
"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes
eghcup install stack
stack --version
eghcup unset hls
"$GHCUP_BIN"/stack --version && exit || echo yes
fi
fi
fi

View File

@@ -10,13 +10,15 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
[![Join the chat at Matrix.org](https://img.shields.io/matrix/haskell-tooling:matrix.org?label=chat%20on%20matrix.org)](https://app.element.io/#/room/#haskell-tooling:matrix.org)
[![Join the chat at Discord](https://img.shields.io/discord/280033776820813825?label=chat%20on%20discord)](https://discord.gg/pKYf3zDQU7)
[![Join the chat at https://gitter.im/haskell/ghcup](https://badges.gitter.im/haskell/ghcup.svg)](https://gitter.im/haskell/ghcup?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
<a href="https://opencollective.com/ghcup#category-CONTRIBUTE"><img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" alt="Donate" width="150"></a>
* [Installation](#installation)
* [Simple bootstrap](#simple-bootstrap)
* [Supported platforms](#supported-platforms)
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Configuration](#configuration)
* [GPG verification](#gpg-verification)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Compiling GHC from source](#compiling-ghc-from-source)
@@ -34,9 +36,59 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
## Installation
### Simple bootstrap
Most users should follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/).
Advanced users may want to perform a [manual installation](#manual-install).
Follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/)
### Supported platforms
This list may not be exhaustive and specifies support for bindists only.
| Platform | Architecture | ghcup | GHC | cabal | HLS | stack |
| ------ | ------ | ------ | ------ | ------ | ------ | ------ |
| Windows 7 | amd64 | ❔ | ✅ | ✅ | ✅ | ✅ |
| Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows Server 2016 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows Server 2019 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows Server 2022 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Windows WSL1 | amd64 | ❌ | ❔ | ❔ | ❔ | ❔ |
| Windows WSL2 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| MacOS >=13 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| MacOS <13 | amd64 | ❌ | ❔ | ❔ | ❔ | ❔ |
| MacOS | aarch64 | ✅ | ✅ | ✅ | ⚠️ | ❌ |
| FreeBSD | amd64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
| Linux generic | x86 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Linux generic | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
| Linux generic | aarch64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
| Linux generic | armv7 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
#### Windows 7
May or may not work, several issues:
* https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140
* https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197
#### WSL1
Unsupported. GHC may or may not work. Upgrade to WSL2.
#### MacOS <13
Not supported. Would require separate binaries, since >=13 binaries are incompatible.
Please upgrade.
#### MacOS aarch64
HLS bindists are still experimental. Stack is theoretically supported, but has no binaries yet.
#### FreeBSD
Lacks some upstream bindists and may need compat libs, since most bindists are built on FreeBSD-12.
HLS bindists are experimental.
#### Linux ARMv7/AARCH64
Lower availability of bindists. HLS only has experimental ones. Stack not supported currently.
### Manual install
@@ -95,6 +147,34 @@ explaining all possible configurations can be found in this repo: [config.yaml](
Partial configuration is fine. Command line options always override the config file settings.
### GPG verification
GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
this is cryptographically secure.
First, obtain the gpg key:
```sh
gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
```
Then verify the gpg key in one of these ways:
1. find out where I live and visit me to do offline key signing
2. figure out my mobile phone number and call me to verify the fingerprint
3. more boring: contact me on Libera IRC (`maerwald`) and verify the fingerprint
Once you've verified the key, you have to figure out if you trust me.
If you trust me, then you can configure gpg in `~/.ghcup/config.yaml`:
```yml
gpg-setting: GPGLax # GPGStrict | GPGLax | GPGNone
```
In `GPGStrict` mode, ghcup will fail if verification fails. In `GPGLax` mode it will just print a warning.
You can also pass the mode via `ghcup --gpg <strict|lax|none>`.
### Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
@@ -155,6 +235,7 @@ This is the complete list of env variables that change GHCup behavior:
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup

View File

@@ -11,21 +11,23 @@
module Main where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
import GHCup.Types.JSON ( )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
import Data.Maybe
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO ( stderr )
import Text.Regex.Posix
@@ -114,12 +116,14 @@ com = subparser
main :: IO ()
main = do
let loggerConfig = LoggerConfig { lcPrintDebug = True
, colorOutter = T.hPutStr stderr
, rawOutter = \_ -> pure ()
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig { lcPrintDebug = True
, consoleOutter = T.hPutStr stderr
, fileOutter = \_ -> pure ()
, fancyColors = not no_color
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings loggerConfig
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
@@ -129,7 +133,7 @@ main = do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of

View File

@@ -15,6 +15,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
@@ -229,6 +230,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, GPGError
, DownloadFailed
, UnknownArchive
, ArchiveResult
@@ -237,7 +239,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
Right _ -> do
p <- liftE $ downloadCached dli Nothing
@@ -247,7 +249,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
case r of
VRight (Just basePath) -> do

View File

@@ -13,9 +13,9 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
@@ -429,6 +429,7 @@ install' _ (_, ListResult {..}) = do
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
@@ -440,19 +441,19 @@ install' _ (_, ListResult {..}) = do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer Nothing $> vi
liftE $ installGHCBin lVer Nothing False $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing $> vi
liftE $ installCabalBin lVer Nothing False $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing $> vi
liftE $ installHLSBin lVer Nothing False $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing $> vi
liftE $ installStackBin lVer Nothing False $> vi
)
>>= \case
VRight vi -> do
@@ -536,9 +537,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
let loggerConfig = LoggerConfig { lcPrintDebug = False
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
}
newIORef $ AppState (Settings { cache = True
, noVerify = False
@@ -547,6 +549,7 @@ settings' = unsafePerformIO $ do
, verbose = False
, urlSource = GHCupURL
, noNetwork = False
, gpgSetting = GPGNone
, ..
})
dirs
@@ -591,7 +594,7 @@ getGHCupInfo = do
r <-
flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF

View File

@@ -87,21 +87,23 @@ import qualified Text.Megaparsec.Char as MPC
data Options = Options
{
-- global options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
, optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting
-- commands
, optCommand :: Command
, optCommand :: Command
}
data Command
= Install (Either InstallCommand InstallOptions)
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
| UnSet UnsetCommand
| List ListOptions
| Rm (Either RmCommand RmOptions)
| DInfo
@@ -141,6 +143,7 @@ data InstallOptions = InstallOptions
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
}
data SetCommand = SetGHC SetOptions
@@ -148,6 +151,11 @@ data SetCommand = SetGHC SetOptions
| SetHLS SetOptions
| SetStack SetOptions
data UnsetCommand = UnsetGHC UnsetOptions
| UnsetCabal UnsetOptions
| UnsetHLS UnsetOptions
| UnsetStack UnsetOptions
-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
| SetToolTag Tag
@@ -158,6 +166,10 @@ data SetOptions = SetOptions
{ sToolVer :: SetToolVersion
}
data UnsetOptions = UnsetOptions
{ sToolVer :: Maybe Text -- target platform triple
}
data ListOptions = ListOptions
{ loTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
@@ -175,6 +187,7 @@ data RmOptions = RmOptions
data CompileCommand = CompileGHC GHCCompileOptions
| CompileHLS HLSCompileOptions
data ConfigCommand = ShowConfig | SetConfig String String | InitConfig
@@ -193,6 +206,18 @@ data GHCCompileOptions = GHCCompileOptions
, isolateDir :: Maybe FilePath
}
data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: Either Version GitBranch
, jobs :: Maybe Int
, setCompile :: Bool
, ovewrwiteVer :: Maybe Version
, isolateDir :: Maybe FilePath
, cabalProject :: Maybe FilePath
, cabalProjectLocal :: Maybe FilePath
, patchDir :: Maybe FilePath
, targetGHCs :: [ToolVersion]
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt FilePath
| UpgradeGHCupDir
@@ -309,6 +334,13 @@ opts =
<> hidden
))
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> optional (option
(eitherReader gpgParser)
( long "gpg"
<> metavar "<strict|lax|none>"
<> help
"GPG verification (default: none)"
))
<*> com
where
parseUri s' =
@@ -348,6 +380,14 @@ com =
<> footerDoc (Just $ text setFooter)
)
)
<> command
"unset"
(info
(UnSet <$> unsetParser <**> helper)
( progDesc "Unset currently active GHC/cabal version"
<> footerDoc (Just $ text unsetFooter)
)
)
<> command
"rm"
(info
@@ -461,6 +501,10 @@ com =
is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
unsetFooter :: String
unsetFooter = [s|Discussion:
Unsets the currently active GHC or cabal version.|]
rmFooter :: String
rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given,
@@ -602,7 +646,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is -> InstallOptions v p u b is)
(\p (u, v) b is f -> InstallOptions v p u b is f)
<$> optional
(option
(eitherReader platformParser)
@@ -640,6 +684,9 @@ installOpts tool =
<> help "install in an isolated dir instead of the default one"
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install")
setParser :: Parser (Either SetCommand SetOptions)
@@ -703,12 +750,74 @@ setParser =
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
unsetParser :: Parser UnsetCommand
unsetParser =
(subparser
( command
"ghc"
( UnsetGHC
<$> info
(unsetOpts <**> helper)
( progDesc "Unset GHC version"
<> footerDoc (Just $ text unsetGHCFooter)
)
)
<> command
"cabal"
( UnsetCabal
<$> info
(unsetOpts <**> helper)
( progDesc "Unset Cabal version"
<> footerDoc (Just $ text unsetCabalFooter)
)
)
<> command
"hls"
( UnsetHLS
<$> info
(unsetOpts <**> helper)
( progDesc "Unset haskell-language-server version"
<> footerDoc (Just $ text unsetHLSFooter)
)
)
<> command
"stack"
( UnsetStack
<$> info
(unsetOpts <**> helper)
( progDesc "Unset stack version"
<> footerDoc (Just $ text unsetStackFooter)
)
)
)
)
where
unsetGHCFooter :: String
unsetGHCFooter = [s|Discussion:
Unsets the the current GHC version. That means there won't
be a ~/.ghcup/bin/ghc anymore.|]
unsetCabalFooter :: String
unsetCabalFooter = [s|Discussion:
Unsets the the current Cabal version.|]
unsetStackFooter :: String
unsetStackFooter = [s|Discussion:
Unsets the the current Stack version.|]
unsetHLSFooter :: String
unsetHLSFooter = [s|Discussion:
Unsets the the current haskell-language-server version.|]
setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$>
(fromMaybe SetRecommended <$>
optional (setVersionArgument (Just ListInstalled) tool))
unsetOpts :: Parser UnsetOptions
unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE"))
listOpts :: Parser ListOptions
listOpts =
ListOptions
@@ -799,6 +908,15 @@ compileP = subparser
<> footerDoc (Just $ text compileFooter)
)
)
<> command
"hls"
( CompileHLS
<$> info
(hlsCompileOpts <**> helper)
( progDesc "Compile HLS from source"
<> footerDoc (Just $ text compileHLSFooter)
)
)
)
where
compileFooter = [s|Discussion:
@@ -823,6 +941,14 @@ Examples:
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version.
The last argument is a list of GHC versions to compile for.
These need to be available in PATH prior to compilation.
Examples:
ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|]
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
@@ -1092,6 +1218,78 @@ ghcCompileOpts =
)
)
hlsCompileOpts :: Parser HLSCompileOptions
hlsCompileOpts =
HLSCompileOptions
<$> ((Left <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
) <|>
(Right <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
)))
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
"Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
)
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
<*> optional
(option
str
(long "cabal-project" <> metavar "CABAL_PROJECT" <> help
"If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
)
)
<*> optional
(option
(eitherReader absolutePathParser)
(long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
"Absolute path to a cabal.project.local to be used for the build. Will be copied over."
)
)
<*> optional
(option
(eitherReader absolutePathParser)
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
)
)
<*> some (toolVersionArgument Nothing (Just GHC))
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP' <|> toolP
@@ -1107,9 +1305,13 @@ toolVersionParser = verP' <|> toolP
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument criteria tool =
argument (eitherReader toolVersionEither)
(metavar "VERSION|TAG"
(metavar (mv tool)
<> completer (tagCompleter (fromMaybe GHC tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
mv (Just GHC) = "GHC_VERSION|TAG"
mv (Just HLS) = "HLS_VERSION|TAG"
mv _ = "VERSION|TAG"
setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
@@ -1136,12 +1338,13 @@ tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
(Settings True False Never Curl False GHCupURL True GPGNone)
dirs'
defaultKeyBindings
loggerConfig
@@ -1162,11 +1365,12 @@ versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let settings = Settings True False Never Curl False GHCupURL True
let settings = Settings True False Never Curl False GHCupURL True GPGNone
let leanAppState = LeanAppState
settings
dirs'
@@ -1253,6 +1457,13 @@ downloaderParser s' | t == T.pack "curl" = Right Curl
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
gpgParser :: String -> Either String GPGSetting
gpgParser s' | t == T.pack "strict" = Right GPGStrict
| t == T.pack "lax" = Right GPGLax
| t == T.pack "none" = Right GPGNone
| otherwise = Left ("Unknown gpg setting value: " <> s')
where t = T.toLower (T.pack s')
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
@@ -1311,6 +1522,11 @@ isolateParser f = case isValid f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
absolutePathParser :: FilePath -> Either String FilePath
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right $ normalise f
False -> Left "Please enter a valid absolute filepath."
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
@@ -1332,6 +1548,7 @@ toSettings options = do
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
@@ -1367,7 +1584,8 @@ updateSettings config settings = do
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork'
gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting'
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
@@ -1392,7 +1610,7 @@ describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL False)
let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone)
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
@@ -1472,17 +1690,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- flip runReaderT dirs initGHCupFileLogging
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = T.hPutStr stderr
, rawOutter =
, consoleOutter = T.hPutStr stderr
, fileOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> T.appendFile logfile
, fancyColors = not no_color
}
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { consoleOutter = \_ -> pure () } } :: LeanAppState)
-------------------------
@@ -1502,7 +1722,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
ghcupInfo <-
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
)
@@ -1575,6 +1795,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
@@ -1607,6 +1828,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
runUnsetGHC =
runAppState
. runE
@'[ NotInstalled ]
let
runLeanSetCabal =
runLeanAppState
@@ -1665,6 +1891,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
@@ -1677,6 +1904,29 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, ArchiveResult
]
let runCompileHLS =
runAppState
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled
, DirNotEmpty
, ArchiveResult
]
let
runLeanWhereIs =
-- Don't use runLeanAppState here, which is disabled on windows.
@@ -1703,6 +1953,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, GPGError
, NoDownload
, NoUpdate
, FileDoesNotExistError
@@ -1719,6 +1970,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
, NoDownload
, DigestError
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError
@@ -1733,7 +1985,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) isolateDir
liftE $ installGHCBin
(_tvVersion v)
isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
@@ -1741,9 +1996,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
forceInstall
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
@@ -1755,8 +2011,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
@@ -1775,16 +2035,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) isolateDir
liftE $ installCabalBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
@@ -1795,8 +2059,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal " <> prettyVer v <> "' first"
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
@@ -1807,16 +2075,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) isolateDir
liftE $ installHLSBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
@@ -1829,10 +2101,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls "
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "' first"
<> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
@@ -1843,16 +2119,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) isolateDir
liftE $ installStackBin
(_tvVersion v)
isolateDir
forceInstall
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
forceInstall
pure vi
)
>>= \case
@@ -1863,8 +2143,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack " <> prettyVer v <> "' first"
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
@@ -2032,10 +2316,31 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Set (Left (SetHLS sopts)) -> setHLS' sopts
Set (Left (SetStack sopts)) -> setStack' sopts
UnSet (UnsetGHC (UnsetOptions triple)) -> runUnsetGHC (unsetGHC triple)
>>= \case
VRight _ -> do
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
UnSet (UnsetCabal (UnsetOptions _)) -> do
runAppState unsetCabal
runLogger $ logInfo "Cabal successfully unset"
pure ExitSuccess
UnSet (UnsetHLS (UnsetOptions _)) -> do
runAppState unsetHLS
runLogger $ logInfo "HLS successfully unset"
pure ExitSuccess
UnSet (UnsetStack (UnsetOptions _)) -> do
runAppState unsetStack
runLogger $ logInfo "Stack successfully unset"
pure ExitSuccess
List ListOptions {..} ->
runListGHC (do
l <- listVersions loTool lCriteria
liftIO $ printListResult lRawFormat l
liftIO $ printListResult no_color lRawFormat l
pure ExitSuccess
)
@@ -2057,6 +2362,53 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8
Compile (CompileHLS HLSCompileOptions { .. }) -> do
runCompileHLS (do
case targetHLS of
Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ compileHLS
targetHLS
ghcs
jobs
ovewrwiteVer
isolateDir
cabalProject
cabalProjectLocal
patchDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
setHLS targetVer
pure (vi, targetVer)
)
>>= \case
VRight (vi, tv) -> do
runLogger $ logInfo
"HLS successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
putStr (T.unpack $ prettyVer tv)
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
@@ -2099,8 +2451,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logWarn $
"Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
@@ -2455,9 +2811,8 @@ fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool
printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
printListResult :: Bool -> Bool -> [ListResult] -> IO ()
printListResult no_color raw lr = do
let
color | raw || no_color = flip const

View File

@@ -8,6 +8,10 @@ verbose: False
keep-dirs: Errors # Always | Never | Errors
# Which downloader to use
downloader: Curl # Curl | Wget | Internal
# whether to run in offline mode
no-network: False
# whether/how to do gpg verification
gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
# TUI key bindings,
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key

View File

@@ -72,7 +72,6 @@ toolRequirements:
'( >= 7 && < 8 )':
distroPKGs:
- gcc
- gcc-c++
- gmp
- gmp-devel
- make
@@ -83,7 +82,6 @@ toolRequirements:
unknown_versioning:
distroPKGs:
- gcc
- gcc-c++
- gmp
- gmp-devel
- make
@@ -96,7 +94,6 @@ toolRequirements:
unknown_versioning:
distroPKGs:
- gcc
- gcc-c++
- gmp
- gmp-devel
- make
@@ -111,14 +108,15 @@ toolRequirements:
- binutils-gold
- curl
- gcc
- g++
- gmp-dev
- ncurses-dev
- libc-dev
- libffi-dev
- make
- xz
- tar
- musl-dev
- ncurses-dev
- perl
- tar
- xz
notes: ''
Linux_UnknownLinux:
unknown_versioning:
@@ -1598,6 +1596,11 @@ ghcupDownloads:
dlHash: f10941f16e4fbd98580ab5241b9271bb0851304560c4d5ca127e3b0e20e3076f
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viPostInstall: &ghc-8105-post-install |
GHC 8.10.5 and 8.10.6 have several issues on Darwin, e.g.
https://gitlab.haskell.org/ghc/ghc/-/issues/19950
Consider upgrading to 8.10.7 via
ghcup install ghc --set 8.10.7
viArch:
A_64:
Linux_Debian:
@@ -1698,6 +1701,7 @@ ghcupDownloads:
dlHash: 43afba72a533408b42c1492bd047b5e37e5f7204e41a5cedd3182cc841610ce9
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viPostInstall: *ghc-8105-post-install
viArch:
A_64:
Linux_Debian:
@@ -2265,7 +2269,7 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.6.0.0/cabal-install-3.6.0.0-armv7-linux.tar.xz
dlHash: 11b5ca042a8bf45971224f2127a3e9d6b803f09210042ca80a254bea06f01a2e
GHCup:
0.1.16.2:
0.1.17:
viTags:
- Recommended
- Latest
@@ -2275,46 +2279,47 @@ ghcupDownloads:
A_64:
Linux_UnknownLinux:
unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-linux-ghcup-0.1.16.2
dlHash: d5e43b95ce1d42263376e414f7eb7c5dd440271c7c6cd9bad446fdeff3823893
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-linux-ghcup-0.1.17
dlHash: 1eaa33af4180f97edf02822d6d711ce618d9828fe9ebbf042d198fe6c1c9d153
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-apple-darwin-ghcup-0.1.16.2
dlHash: a334620ccce7705211b2142882dde544003e6030af4b91a44c890542a90f879f
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-apple-darwin-ghcup-0.1.17
dlHash: a3d4ed12f8631c0537d8d9531cc5518bc6f90edcee3326e5d4e0efb72c8dfc6f
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-portbld-freebsd-ghcup-0.1.16.2
dlHash: 92359592a5694375e53b22628920086bf4bbf0faff5be018a0ed3e745a6426a9
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-portbld-freebsd-ghcup-0.1.17
dlHash: 83012de837773f3aa26182c607c2da85ee6ff3b0092becb78907700f407a27fb
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-mingw64-ghcup-0.1.16.2.exe
dlHash: ec78872a84213968c490675127b9aad2285980b747c68207801ae824b98c7948
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-mingw64-ghcup-0.1.17.exe
dlHash: 40bda6050c800fa69af51d2e668426ca73b4179214bfeef329b795484991d258
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/i386-linux-ghcup-0.1.16.2
dlHash: 01968ca6decac7b6e8ba6e2c817870d3fa47289a6507e0c1ab563f7b6eec0e38
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/i386-linux-ghcup-0.1.17
dlHash: d0f887b13a2c7a11477dc54cb90b446ef0ebe1d2a6bfbf60ccd4b37fc5de70cc
Linux_Alpine:
unknown_versioning: *ghcup-32
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/aarch64-linux-ghcup-0.1.16.2
dlHash: 0bdbfc724e0ddabb266156eea83c2c4e19c6ed79dd06db0c29b7d69df8d9fa8c
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/aarch64-linux-ghcup-0.1.17
dlHash: be67cf8800ae305c5ba210b645f4fce8751763f3eac3db399f6efca145b7ab38
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/aarch64-apple-darwin-ghcup-0.1.16.2
dlHash: 8854e991a2ba1350abda59dab96ce50ae7729d1ce99399d67929ef31e90f1da5
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/aarch64-apple-darwin-ghcup-0.1.17
dlHash: b1be8c55838bd0d972e42b02b71bdf47fbbf67be1456e0de2d7d346620538539
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/armv7-linux-ghcup-0.1.16.2
dlHash: 983ebb5b584bfa600704216a63f94b40d36a02573834e90ef1042c8472d9ad57
dlUri: https://downloads.haskell.org/~ghcup/0.1.17/armv7-linux-ghcup-0.1.17
dlHash: fe54ded2fafff4f8d82e511229f257f4c3b87b14c796f9b5b0ea35c359c26cb0
HLS:
1.1.0:
viTags: []
viTags:
- old
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#110
viPostInstall: &hls-post-install |
This is just the server part of your LSP configuration. Consult the README on how to
@@ -2337,7 +2342,8 @@ ghcupDownloads:
Linux_Alpine:
unknown_versioning: *hls-110-64
1.2.0:
viTags: []
viTags:
- old
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#120
viPostInstall: *hls-post-install
viArch:
@@ -2357,9 +2363,7 @@ ghcupDownloads:
Linux_Alpine:
unknown_versioning: *hls-120-64
1.3.0:
viTags:
- Recommended
- Latest
viTags: []
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#130
viPostInstall: *hls-post-install
viArch:
@@ -2378,6 +2382,50 @@ ghcupDownloads:
dlHash: 46aac7be888e29a9907cf56698c1ce1475c148b5e6cc099513e9ef74a0520dcf
Linux_Alpine:
unknown_versioning: *hls-130-64
1.4.0:
viTags:
- Recommended
- Latest
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#140
viPostInstall: *hls-post-install
viSourceDL:
dlUri: https://downloads.haskell.org/ghcup/src/haskell-language-server/1.4.0/haskell-language-server-1.4.0.tar.gz
dlSubdir: haskell-language-server-1.4.0
dlHash: c5d7dbf7fae9aa3ed2c1184b49e82d8ac623ca786494ef6602cfe11735d28db0
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning: &hls-140-64
dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.4.0/haskell-language-server-Linux-1.4.0.tar.gz
dlHash: f93c114441911ccce55649702adc9553cb4c9f953c37878321d2806a3525fee8
Darwin:
unknown_versioning:
dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.4.0/haskell-language-server-macOS-1.4.0.tar.gz
dlHash: a7f0ac6be93ffb08cc239e5f5fead99b061061825f99566c1be33ee60cab62a4
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/haskell-language-server/1.4.0/haskell-language-server-freebsd-1.4.0.tar.gz
dlHash: 6b2ad2398ed8c3964dea017e3d5e553b54c10ba1373d7653d2edd019854f4da2
Windows:
unknown_versioning:
dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.4.0/haskell-language-server-Windows-1.4.0.tar.gz
dlHash: 0ec77cee750037b7a0ede817b46a913a702821f4098c6a858bcb686cb30f7efd
Linux_Alpine:
unknown_versioning: *hls-140-64
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/haskell-language-server/1.4.0/haskell-language-server-linux-aarch64-1.4.0.tar.gz
dlHash: 8ad97e2bf1c538e637edec194e1cd9939019955bb749cb470f34bbe5a067b001
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/haskell-language-server/1.4.0/haskell-language-server-macOS-aarch64-1.4.0.tar.gz
dlHash: 70c6fe38e987ba44c1e19173486c01f666ffb30a74cd5a7968296a5aba4c2dd0
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/haskell-language-server/1.4.0/haskell-language-server-linux-armv7-1.4.0.tar.gz
dlHash: 4a921fbca06b02f3b1c0930cec5e65e9362b603e7715680ec7b150f18bd703d6
Stack:
2.5.1:
viTags:

File diff suppressed because it is too large Load Diff

View File

@@ -1,32 +0,0 @@
FROM alpine:3.14.2
# install deps needed by GHC
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
gmp \
ncurses \
libffi \
make \
xz \
tar \
perl
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup install ghc --set 8.10.7 && \
ghcup install cabal latest && \
ghcup install stack latest

View File

@@ -1,30 +0,0 @@
FROM alpine:3.14.2
# install deps needed by GHC
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
gmp \
ncurses \
libffi \
make \
xz \
tar \
perl
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup prefetch metadata

View File

@@ -1,32 +0,0 @@
FROM alpine:latest
# install deps needed by GHC
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
gmp \
ncurses \
libffi \
make \
xz \
tar \
perl
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup install ghc --set 8.10.7 && \
ghcup install cabal latest && \
ghcup install stack latest

View File

@@ -1,30 +0,0 @@
FROM alpine:latest
# install deps needed by GHC
RUN apk add --no-cache \
curl \
gcc \
g++ \
binutils \
binutils-gold \
gmp \
ncurses \
libffi \
make \
xz \
tar \
perl
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup prefetch metadata

View File

@@ -1,25 +0,0 @@
FROM ubuntu:20.04
# install deps needed by GHC
RUN export DEBIAN_FRONTEND=noninteractive && \
apt-get update -y && \
apt-get install -y --no-install-recommends libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl && \
apt-get clean && \
rm -rf /var/cache/apt/archives && \
rm -rf /var/lib/apt/lists/*
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup install ghc --set 8.10.7 && \
ghcup install cabal latest && \
ghcup install stack latest

View File

@@ -1,23 +0,0 @@
FROM ubuntu:20.04
# install deps needed by GHC
RUN export DEBIAN_FRONTEND=noninteractive && \
apt-get update -y && \
apt-get install -y --no-install-recommends libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl && \
apt-get clean && \
rm -rf /var/cache/apt/archives && \
rm -rf /var/lib/apt/lists/*
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup prefetch metadata

View File

@@ -1,25 +0,0 @@
FROM ubuntu:latest
# install deps needed by GHC
RUN export DEBIAN_FRONTEND=noninteractive && \
apt-get update -y && \
apt-get install -y --no-install-recommends libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl && \
apt-get clean && \
rm -rf /var/cache/apt/archives && \
rm -rf /var/lib/apt/lists/*
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup install ghc --set 8.10.7 && \
ghcup install cabal latest && \
ghcup install stack latest

View File

@@ -1,23 +0,0 @@
FROM ubuntu:latest
# install deps needed by GHC
RUN export DEBIAN_FRONTEND=noninteractive && \
apt-get update -y && \
apt-get install -y --no-install-recommends libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl && \
apt-get clean && \
rm -rf /var/cache/apt/archives && \
rm -rf /var/lib/apt/lists/*
ARG GHCUP_VERSION
# install ghcup
RUN if [ -n "$GHCUP_VERSION" ] ; \
then curl -sSfL https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION > /usr/bin/ghcup ; \
else curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup ; \
fi && \
chmod +x /usr/bin/ghcup
ENV GHCUP_INSTALL_BASE_PREFIX=/usr/local
ENV PATH=/usr/local/.ghcup/bin:$PATH
RUN ghcup prefetch metadata

View File

@@ -1,5 +1,19 @@
# Revision history for ghcup
## 0.1.17 -- 2021-09-20
* Add `--force` option to install/compile wrt [#210](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/210) by Arjun Kathuria
* Implement compiling HLS from source wrt [#201](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/201)
* Implement experimental GPG verification of the metadata file (see README) wrt [#263](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/236)
* Add `ghcup unset` command wrt [#145](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/145)
* Add `ghcup whereis bindir` etc wrt [#221](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/221)
* Greatly reduce dependency footprint wrt [#212](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/212)
* Add `ghcup --plan-json`
* Improve `--patchdir` option for GHC compilation wrt [#226](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/226)
* Try to improve logging and failure modes, especially during downloads
* Add descriptive warnings when HLS and GHC versions are incompatible
* Improve curl header parsing wrt [#213](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/213)
## 0.1.16.2 -- 2021-08-12
* Add isolated installations wrt [#141](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/141) by Arjun Kathuria

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.16.2
version: 0.1.17
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
@@ -24,7 +24,6 @@ extra-doc-files:
data/metadata/ghcup-0.0.4.yaml
data/metadata/ghcup-0.0.5.yaml
data/metadata/ghcup-0.0.6.yaml
data/metadata/ghcup-0.0.7.yaml
extra-source-files:
data/build_mk/default
@@ -100,6 +99,7 @@ library
, base16-bytestring >=0.1.1.6 && <1.1
, binary ^>=0.8.6.0
, bytestring ^>=0.10
, Cabal
, case-insensitive ^>=1.2.1.0
, casing ^>=0.1.4.1
, concurrent-output ^>=1.10.11

View File

@@ -34,6 +34,7 @@ import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
@@ -63,6 +64,11 @@ import Data.Text ( Text )
import Data.Time.Clock
import Data.Time.Format.ISO8601
import Data.Versions
import Distribution.Types.Version hiding ( Version )
import Distribution.Types.PackageId
import Distribution.Types.PackageDescription
import Distribution.Types.GenericPackageDescription
import Distribution.PackageDescription.Parsec
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
@@ -83,6 +89,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
@@ -121,6 +128,7 @@ fetchToolBindist :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, GPGError
, DownloadFailed
, NoDownload
]
@@ -148,6 +156,7 @@ fetchGHCSrc :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, GPGError
, DownloadFailed
, NoDownload
]
@@ -184,10 +193,12 @@ installGHCBindist :: ( MonadFail m
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -198,15 +209,26 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver isoFilepath = do
installGHCBindist dlinfo ver isoFilepath forceInstall = do
let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
_ -> pure ()
regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver
if
| not forceInstall
, regularGHCInstalled
, Nothing <- isoFilepath -> do
throwE $ AlreadyInstalled GHC ver
| forceInstall
, regularGHCInstalled
, Nothing <- isoFilepath -> do
lift $ logInfo "Removing the currently installed GHC version first!"
liftE $ rmGHCVer tver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -215,13 +237,13 @@ installGHCBindist dlinfo ver isoFilepath = do
ghcdir <- lift $ ghcupGHCDir tver
toolchainSanityChecks
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall
Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
@@ -249,11 +271,13 @@ installPackedGHC :: ( MonadMask m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts
'[ BuildFailed
, UnknownArchive
@@ -261,10 +285,11 @@ installPackedGHC :: ( MonadMask m
, DirNotEmpty
, ArchiveResult
] m ()
installPackedGHC dl msubdir inst ver = do
installPackedGHC dl msubdir inst ver forceInstall = do
PlatformRequest {..} <- lift getPlatformReq
liftE $ installDestSanityCheck inst
unless forceInstall
(liftE $ installDestSanityCheck inst)
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
@@ -275,7 +300,7 @@ installPackedGHC dl msubdir inst ver = do
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
msubdir
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
@@ -365,10 +390,12 @@ installGHCBin :: ( MonadFail m
)
=> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> Bool -- ^ force install
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -379,9 +406,9 @@ installGHCBin :: ( MonadFail m
]
m
()
installGHCBin ver isoFilepath = do
installGHCBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver isoFilepath
installGHCBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@@ -401,10 +428,12 @@ installCabalBindist :: ( MonadMask m
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -415,25 +444,30 @@ installCabalBindist :: ( MonadMask m
]
m
()
installCabalBindist dlinfo ver isoFilepath = do
installCabalBindist dlinfo ver isoFilepath forceInstall = do
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- for regular install check if any previous versions installed
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
-- check if we already have a regular cabal already installed
regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver
_ -> pure () -- check isn't required in isolated installs
if
| not forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
throwE $ AlreadyInstalled Cabal ver
| forceInstall
, regularCabalInstalled
, Nothing <- isoFilepath -> do
lift $ logInfo "Removing the currently installed version first!"
liftE $ rmCabalVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -448,23 +482,24 @@ installCabalBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing
liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall
Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir (Just ver)
liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version for regular installs
cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
-- | Install an unpacked cabal distribution.Symbol
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Bool -- ^ Force Install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do
installCabalUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
@@ -473,7 +508,8 @@ installCabalUnpacked path inst mver' = do
<> exeExt
let destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath
unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
@@ -498,10 +534,12 @@ installCabalBin :: ( MonadMask m
)
=> Version
-> Maybe FilePath -- isolated install Path, if user provided any
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -512,9 +550,9 @@ installCabalBin :: ( MonadMask m
]
m
()
installCabalBin ver isoFilepath = do
installCabalBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver isoFilepath
installCabalBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@@ -534,10 +572,12 @@ installHLSBindist :: ( MonadMask m
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -548,20 +588,28 @@ installHLSBindist :: ( MonadMask m
]
m
()
installHLSBindist dlinfo ver isoFilepath = do
installHLSBindist dlinfo ver isoFilepath forceInstall = do
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing ->
-- we only check for already installed in regular (non-isolated) installs
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver
_ -> pure ()
if
| not forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular install
throwE $ AlreadyInstalled HLS ver
| forceInstall
, regularHLSInstalled
, Nothing <- isoFilepath -> do -- regular forced install
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
liftE $ rmHLSVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -576,15 +624,12 @@ installHLSBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing
liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall
Nothing -> do
liftE $ installHLSUnpacked workdir binDir (Just ver)
liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
liftE $ installHLSPostInst isoFilepath ver
-- | Install an unpacked hls distribution.
@@ -592,8 +637,9 @@ installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m,
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Bool -- ^ is it a force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do
installHLSUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
@@ -612,7 +658,8 @@ installHLSUnpacked path inst mver' = do
let srcPath = path </> f
let destPath = inst </> toF
liftE $ throwIfFileAlreadyExists destPath
unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
srcPath
@@ -627,7 +674,8 @@ installHLSUnpacked path inst mver' = do
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF
liftE $ throwIfFileAlreadyExists destWrapperPath
unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
srcWrapperPath
@@ -635,6 +683,21 @@ installHLSUnpacked path inst mver' = do
lift $ chmod_755 destWrapperPath
installHLSPostInst :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadCatch m, MonadMask m, MonadFail m, MonadUnliftIO m)
=> Maybe FilePath
-> Version
-> Excepts '[NotInstalled] m ()
installHLSPostInst isoFilepath ver =
case isoFilepath of
Just _ -> pure ()
Nothing -> do
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
@@ -651,11 +714,13 @@ installHLSBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Maybe FilePath -- isolated install Dir (if any)
-> Bool -- force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -666,9 +731,174 @@ installHLSBin :: ( MonadMask m
]
m
()
installHLSBin ver isoFilepath = do
installHLSBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver isoFilepath
installHLSBindist dlinfo ver isoFilepath forceInstall
compileHLS :: ( MonadMask m
, MonadCatch m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
)
=> Either Version GitBranch
-> [Version]
-> Maybe Int
-> Maybe Version
-> Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> Excepts '[ NoDownload
, GPGError
, DownloadFailed
, DigestError
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, BuildFailed
, NotInstalled
] m Version
compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir = do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs
(workdir, tver) <- case targetHLS of
-- unpack from version tarball
Left tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver
-- download source tarball
dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
pure (workdir, tver)
-- clone from git
Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
, "origin"
, fromString rep ]
let fetch_args =
[ "fetch"
, "--depth"
, "1"
, "--quiet"
, "origin"
, fromString ref ]
lEM $ git fetch_args
lEM $ git [ "checkout", "FETCH_HEAD" ]
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack </> "haskell-language-server.cabal"))
pure . (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
pure (tmpUnpack, tver)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
let installVer = fromMaybe tver ov
liftE $ runBuildAction
workdir
Nothing
(reThrowAll @_ @'[PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let installDir = workdir </> "out"
liftIO $ createDirRecursive' installDir
-- apply patches
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
-- set up project files
cp <- case cabalProject of
Just cp
| isAbsolute cp -> do
handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir </> "cabal.project")
pure "cabal.project"
| otherwise -> pure (takeFileName cp)
Nothing -> pure "cabal.project"
forM_ cabalProjectLocal $ \cpl -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cpl (workdir </> cp <.> "local")
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' installDir
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
liftE $ lEM @_ @'[ProcessError] $
execLogged "cabal" ( [ "v2-install"
, "-w"
, "ghc-" <> T.unpack (prettyVer ghc)
, "--install-method=copy"
] ++
maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
[ "--overwrite-policy=always"
, "--disable-profiling"
, "--disable-tests"
, "--enable-split-sections"
, "--enable-executable-stripping"
, "--enable-executable-static"
, "--installdir=" <> ghcInstallDir
, "--project-file=" <> cp
, "exe:haskell-language-server"
, "exe:haskell-language-server-wrapper"]
)
(Just workdir) "cabal" Nothing
pure ghcInstallDir
forM_ artifacts $ \artifact -> do
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(installDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(installDir </> "haskell-language-server-wrapper" <.> exeExt)
liftIO $ rmPathForcibly artifact
case isolateDir of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked installDir isoDir Nothing True
Nothing -> do
liftE $ installHLSUnpacked installDir binDir (Just installVer) True
)
liftE $ installHLSPostInst isolateDir installVer
pure installVer
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@@ -688,11 +918,13 @@ installStackBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Maybe FilePath -- ^ isolate install Dir (if any)
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -703,9 +935,9 @@ installStackBin :: ( MonadMask m
]
m
()
installStackBin ver isoFilepath = do
installStackBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver isoFilepath
installStackBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
@@ -724,11 +956,13 @@ installStackBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath
-> Maybe FilePath -- ^ isolate install Dir (if any)
-> Bool -- ^ Force install
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@@ -739,18 +973,27 @@ installStackBindist :: ( MonadMask m
]
m
()
installStackBindist dlinfo ver isoFilepath = do
installStackBindist dlinfo ver isoFilepath forceInstall = do
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
case isoFilepath of
Nothing -> -- check previous versions in case of regular installs
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
regularStackInstalled <- lift $ checkIfToolInstalled Stack ver
_ -> pure () -- don't do shit for isolates
if
| not forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
throwE $ AlreadyInstalled Stack ver
| forceInstall
, regularStackInstalled
, Nothing <- isoFilepath -> do
lift $ logInfo "Removing the currently installed version of Stack first!"
liftE $ rmStackVer ver
| otherwise -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -766,9 +1009,9 @@ installStackBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing
liftE $ installStackUnpacked workdir isoDir Nothing forceInstall
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver)
liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall
-- create symlink if this is the latest version and a regular install
sVers <- lift $ fmap rights getInstalledStacks
@@ -781,8 +1024,9 @@ installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs
-> Bool -- ^ Force install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do
installStackUnpacked path inst mver' forceInstall = do
lift $ logInfo "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
@@ -791,7 +1035,8 @@ installStackUnpacked path inst mver' = do
<> exeExt
destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath
unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
@@ -868,6 +1113,8 @@ setGHC ver sghc = do
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
pure ver
where
@@ -906,6 +1153,17 @@ setGHC ver sghc = do
$ createDirectoryLink targetF fullF
_ -> pure ()
unsetGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
unsetGHC = rmPlain
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
@@ -913,7 +1171,6 @@ setCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadUnliftIO m)
@@ -937,18 +1194,24 @@ setCabal ver = do
pure ()
unsetCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetCabal = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
hideError doesNotExistErrorType $ rmLink cabalbin
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m
, MonadReader env m
setHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
, MonadFail m
, MonadUnliftIO m
)
=> Version
@@ -978,9 +1241,26 @@ setHLS ver = do
lift $ createLink destL wrapper
lift warnAboutHlsCompatibility
pure ()
unsetHLS :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetHLS = do
Dirs {..} <- getDirs
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'
binDir
(MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)
forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))
hideError doesNotExistErrorType $ rmLink wrapper
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m
, MonadReader env m
@@ -1010,6 +1290,42 @@ setStack ver = do
pure ()
unsetStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadIO m)
=> m ()
unsetStack = do
Dirs {..} <- getDirs
let stackbin = binDir </> "stack" <> exeExt
hideError doesNotExistErrorType $ rmLink stackbin
-- | Warn if the installed and set HLS is not compatible with the installed and
-- set GHC version.
warnAboutHlsCompatibility :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadCatch m
, MonadIO m
)
=> m ()
warnAboutHlsCompatibility = do
supportedGHC <- hlsGHCVersions
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
currentHLS <- hlsSet
case (currentGHC, currentHLS) of
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
logWarn $
"GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
"Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
"Haskell IDE support may not work until this is fixed." <> "\n" <>
"Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
T.pack (prettyShow supportedGHC)
_ -> return ()
------------------
--[ List tools ]--
@@ -1783,6 +2099,7 @@ compileGHC :: ( MonadMask m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
@@ -1908,6 +2225,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(Just $ RegexDir "ghc-.*")
ghcdir
(tver ^. tvVersion)
False -- not a force install, since we already overwrite when compiling.
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
@@ -2229,6 +2547,8 @@ upgradeGHCup :: ( MonadMask m
-> Excepts
'[ CopyError
, DigestError
, GPGError
, GPGError
, DownloadFailed
, NoDownload
, NoUpdate
@@ -2245,7 +2565,7 @@ upgradeGHCup mtarget force' = do
dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- lift withGHCupTmpDir
let fn = "ghcup" <> exeExt
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ logDebug $ "mkdir -p " <> T.pack destDir
@@ -2354,6 +2674,22 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath
-- | Doesn't work for cross GHC.
checkIfToolInstalled :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
Version ->
m Bool
checkIfToolInstalled tool ver =
case tool of
Cabal -> cabalInstalled ver
HLS -> hlsInstalled ver
Stack -> stackInstalled ver
GHC -> ghcInstalled $ mkTVer ver
_ -> pure False
throwIfFileAlreadyExists :: ( MonadIO m ) =>
FilePath ->

View File

@@ -35,6 +35,7 @@ import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Version
@@ -114,7 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadMask m
)
=> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF = do
@@ -165,7 +166,7 @@ getBase :: ( MonadReader env m
, MonadMask m
)
=> URI
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do
Settings { noNetwork, downloader } <- lift getSettings
@@ -176,7 +177,6 @@ getBase uri = do
then pure Nothing
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. fmap Just
. smartDl
$ uri
@@ -234,6 +234,7 @@ getBase uri = do
-> Excepts
'[ DownloadFailed
, DigestError
, GPGError
]
m1
FilePath
@@ -245,7 +246,7 @@ getBase uri = do
Dirs { cacheDir } <- lift getDirs
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
| e -> do
accessTime <- liftIO $ getAccessTime json_file
@@ -258,7 +259,7 @@ getBase uri = do
where
dlWithMod modTime json_file = do
let (dir, fn) = splitFileName json_file
f <- liftE $ download uri' Nothing dir (Just fn) True
f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
liftIO $ setModificationTime f modTime
liftIO $ setAccessTime f modTime
pure f
@@ -322,16 +323,17 @@ download :: ( MonadReader env m
, MonadIO m
)
=> URI
-> Maybe URI -- ^ URI for gpg sig
-> Maybe T.Text -- ^ expected hash
-> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError , DownloadFailed] m FilePath
download uri eDigest dest mfn etags
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest dest mfn etags
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
@@ -340,115 +342,179 @@ download uri eDigest dest mfn etags
where
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
-- download
flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
(\e' -> do
lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
case e' of
V e@GPGError {} -> throwE e
V e@DigestError {} -> throwE e
_ -> throwE (DownloadFailed e')
) $ do
Settings{ downloader, noNetwork } <- lift getSettings
Settings{ downloader, noNetwork, gpgSetting } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
case downloader of
Curl -> do
o' <- liftIO getCurlOpts
if etags
then do
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
headers <- liftIO $ T.readFile dh
-- this nonsense is necessary, because some older versions of curl would overwrite
-- the destination file when 304 is returned
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
lift $ writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
Wget -> do
destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
o' <- liftIO getWgetOpts
if etags
then do
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ copyFile destFileTemp destFile
downloadAction <- case downloader of
Curl -> do
o' <- liftIO getCurlOpts
if etags
then pure $ curlEtagsDL o'
else pure $ curlDL o'
Wget -> do
o' <- liftIO getWgetOpts
if etags
then pure $ wgetEtagsDL o'
else pure $ wgetDL o'
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFile mempty
Internal -> do
if etags
then pure (\fp -> liftE . internalEtagsDL fp)
else pure (\fp -> liftE . internalDL fp)
#endif
liftE $ downloadAction baseDestFile uri
case (gpgUri, gpgSetting) of
(_, GPGNone) -> pure ()
(Just gpgUri', _) -> do
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
liftE $ flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
) $ do
o' <- liftIO getGpgOpts
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
liftE $ downloadAction gpgDestFile gpgUri'
lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
cp <- lift $ executeOut "gpg" args Nothing
case cp of
CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
lift $ logDebug $ decUTF8Safe' _stdErr
throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
_ -> pure ()
forM_ eDigest (liftE . flip checkDigest destFile)
pure destFile
forM_ eDigest (liftE . flip checkDigest baseDestFile)
pure baseDestFile
curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
liftIO $ renameFile destFileTemp destFile
curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
headers <- liftIO $ T.readFile dh
-- this nonsense is necessary, because some older versions of curl would overwrite
-- the destination file when 304 is returned
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ renameFile destFileTemp destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
lift $ writeEtags destFile (parseEtags headers)
wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ renameFile destFileTemp destFile
wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
#if defined(INTERNAL_DOWNLOADER)
internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFileTemp mempty
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalEtagsDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFileTemp addHeaders
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif
-- Manage to find a file we can write the body into.
getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
getDestFile =
case mfn of
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' =
let path = view pathL' uri'
in case mfn' of
Just fn -> pure (dest </> fn)
Nothing
| let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
, not (null urlBase) -> pure (dest </> urlBase)
-- TODO: remove this once we use hpath again
| otherwise -> throwE $ NoUrlBase uri'
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
| otherwise -> throwE $ NoUrlBase (decUTF8Safe . serializeURIRef' $ uri')
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
@@ -509,14 +575,14 @@ downloadCached :: ( MonadReader env m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
case cache of
True -> downloadCached' dli mfn Nothing
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
downloadCached' :: ( MonadReader env m
@@ -531,7 +597,7 @@ downloadCached' :: ( MonadReader env m
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe cacheDir mDestDir
@@ -542,7 +608,7 @@ downloadCached' dli mfn mDestDir = do
| fileExists -> do
liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile
| otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
@@ -571,7 +637,7 @@ checkDigest eDigest file = do
lift $ logInfo $ "verifying digest of: " <> T.pack p'
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest)
-- | Get additional curl args from env. This is an undocumented option.
@@ -589,6 +655,12 @@ getWgetOpts =
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional gpg args from env. This is an undocumented option.
getGpgOpts :: IO [String]
getGpgOpts =
lookupEnv "GHCUP_GPG_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get the url base name.
--
@@ -610,3 +682,7 @@ urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-- "HTTP/1.1 304 Not Modified\n"
getLastHeader :: T.Text -> T.Text
getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines
tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp")

View File

@@ -188,12 +188,22 @@ instance Pretty TarDirDoesNotExist where
text "Tar directory does not exist:" <+> pPrint dir
-- | File digest verification failed.
data DigestError = DigestError Text Text
data DigestError = DigestError FilePath Text Text
deriving Show
instance Pretty DigestError where
pPrint (DigestError currentDigest expectedDigest) =
text "Digest error: expected" <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest
pPrint (DigestError fp currentDigest expectedDigest) =
text "Digest error for" <+> text (fp <> ": expected")
<+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
"\nConsider removing the file in case it's cached and try again."
-- | File digest verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)

View File

@@ -23,6 +23,7 @@ import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
@@ -138,7 +139,6 @@ getLinuxDistro = do
| hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
| hasWord name ["solus"] -> Solus
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where

View File

@@ -60,9 +60,10 @@ getCommonRequirements pr tr =
prettyRequirements :: Requirements -> T.Text
prettyRequirements Requirements {..} =
let d = if not . null $ _distroPKGs
then
"\n Please install the following distro packages: "
<> T.intercalate " " _distroPKGs
then "\n Please ensure the following distro packages "
<> "are installed before continuing (you can exit ghcup "
<> "and return at any time): "
<> T.intercalate " " _distroPKGs
else ""
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""
in "System requirements " <> d <> n

View File

@@ -223,7 +223,6 @@ data LinuxDistro = Debian
| RedHat
| Alpine
| AmazonLinux
| Solus
-- rolling
| Gentoo
| Exherbo
@@ -243,7 +242,6 @@ distroToString CentOS = "centos"
distroToString RedHat = "redhat"
distroToString Alpine = "alpine"
distroToString AmazonLinux = "amazon"
distroToString Solus = "solus"
distroToString Gentoo = "gentoo"
distroToString Exherbo = "exherbo"
distroToString UnknownLinux = "unknown"
@@ -303,11 +301,12 @@ data UserSettings = UserSettings
, uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
@@ -320,6 +319,7 @@ fromSettings Settings{..} Nothing =
, uNoNetwork = Just noNetwork
, uKeyBindings = Nothing
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
}
fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings
@@ -342,6 +342,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uNoNetwork = Just noNetwork
, uKeyBindings = Just ukb
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
}
data UserKeyBindings = UserKeyBindings
@@ -415,6 +416,7 @@ data Settings = Settings
, verbose :: Bool
, urlSource :: URLSource
, noNetwork :: Bool
, gpgSetting :: GPGSetting
}
deriving (Show, GHC.Generic)
@@ -448,6 +450,13 @@ data Downloader = Curl
instance NFData Downloader
data GPGSetting = GPGStrict
| GPGLax
| GPGNone
deriving (Eq, Show, Ord, GHC.Generic)
instance NFData GPGSetting
data DebugInfo = DebugInfo
{ diBaseDir :: FilePath
, diBinDir :: FilePath
@@ -567,11 +576,12 @@ data LogLevel = Warn
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, consoleOutter :: T.Text -> IO () -- ^ how to write the console output
, fileOutter :: T.Text -> IO () -- ^ how to write the file output
, fancyColors :: Bool
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug
rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)

View File

@@ -24,6 +24,8 @@ module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
-- This is due to the boot file.
import Control.Applicative ( (<|>) )
import Data.Aeson
@@ -54,6 +56,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
instance ToJSON Tag where
toJSON Latest = String "Latest"

View File

@@ -23,12 +23,9 @@ import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics
import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool
makePrisms ''Architecture
@@ -117,80 +114,6 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)

View File

@@ -35,6 +35,7 @@ import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
@@ -250,7 +251,6 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadCatch m
)
@@ -268,7 +268,7 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
@@ -475,7 +475,7 @@ hlsGHCVersions = do
. splitOn "~"
)
bins
pure . rights . concat . maybeToList $ vers
pure . sortBy (flip compare) . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
@@ -843,6 +843,8 @@ runBuildAction :: ( Pretty (V e)
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
@@ -1032,7 +1034,7 @@ ensureGlobalTools :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
@@ -1040,12 +1042,12 @@ ensureGlobalTools = do
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do
void $ (\(DigestError _ _ _) -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
pure ()
#else
pure ()

View File

@@ -38,6 +38,7 @@ import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.MegaParsec
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Control.Exception.Safe

View File

@@ -9,6 +9,8 @@ import GHCup.Utils.Prelude
import Control.Monad.Reader
import Data.Maybe
import Data.Text ( Text )
import Data.Void
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory
@@ -16,7 +18,9 @@ import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified Text.Megaparsec as MP
@@ -101,6 +105,11 @@ findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
findFiles' path parser = do
contents <- listDirectory path
pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists fp = liftIO $ doesFileExist fp

View File

@@ -0,0 +1,5 @@
module GHCup.Utils.File.Common where
import Text.Regex.Posix
findFiles :: FilePath -> Regex -> IO [FilePath]

View File

@@ -17,6 +17,7 @@ module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
import GHCup.Types
import GHCup.Types.Optics

View File

@@ -1,5 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Utils.Logger
@@ -16,21 +18,97 @@ module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.File
import {-# SOURCE #-} GHCup.Utils.File.Common
import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text ( Text )
import Optics
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import qualified Data.ByteString as B
import GHCup.Utils.Prelude
import qualified Data.Text as T
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let color' c = if fancyColors then color c else id
let style' = case logLevel of
Debug -> style Bold . color' Blue
Info -> style Bold . color' Green
Warn -> style Bold . color' Yellow
Error -> style Bold . color' Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ consoleOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ fileOutter outr
initGHCupFileLogging :: ( MonadReader env m

View File

@@ -0,0 +1,21 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Utils.Logger where
import GHCup.Types
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text ( Text )
import Optics
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()

View File

@@ -23,6 +23,7 @@ module GHCup.Utils.Prelude where
import GHCup.Types
#endif
import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger
import Control.Applicative
import Control.Exception.Safe

View File

@@ -28,7 +28,7 @@ import qualified Data.Text as T
-- Note that when updating this, CI requires that the file exsists AND the same file exists at
-- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.7.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.6.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP

View File

@@ -21,7 +21,7 @@
plat="$(uname -s)"
arch=$(uname -m)
ghver="0.1.16.2"
ghver="0.1.17"
base_url="https://downloads.haskell.org/~ghcup"
export GHCUP_SKIP_UPDATE_CHECK=yes
@@ -52,41 +52,57 @@ esac
die() {
(>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
if [ -n "${NO_COLOR}" ] ; then
(>&2 printf "%s\\n" "$1")
else
(>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
fi
exit 2
}
warn() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;35m$1\\033[0m"
;;
*)
printf "\\033[0;35m%s\\033[0m\\n" "$1"
;;
esac
if [ -n "${NO_COLOR}" ] ; then
printf "%s\\n" "$1"
else
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;35m$1\\033[0m"
;;
*)
printf "\\033[0;35m%s\\033[0m\\n" "$1"
;;
esac
fi
}
yellow() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;33m$1\\033[0m"
;;
*)
printf "\\033[0;33m%s\\033[0m\\n" "$1"
;;
esac
if [ -n "${NO_COLOR}" ] ; then
printf "%s\\n" "$1"
else
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;33m$1\\033[0m"
;;
*)
printf "\\033[0;33m%s\\033[0m\\n" "$1"
;;
esac
fi
}
green() {
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;32m$1\\033[0m"
;;
*)
printf "\\033[0;32m%s\\033[0m\\n" "$1"
;;
esac
if [ -n "${NO_COLOR}" ] ; then
printf "%s\\n" "$1"
else
case "${plat}" in
MSYS*|MINGW*)
echo -e "\\033[0;32m$1\\033[0m"
;;
*)
printf "\\033[0;32m%s\\033[0m\\n" "$1"
;;
esac
fi
}
edo() {
@@ -100,7 +116,7 @@ eghcup() {
_eghcup() {
if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then
args="-s ${BOOTSTRAP_HASKELL_YAML}"
fi
fi
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
"${GHCUP_BIN}/ghcup" ${args} "$@"
else
@@ -405,7 +421,7 @@ warn_path() {
echo
[ -n "$1" ] && warn "$1"
yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
yellow "To do so, you may want run 'source $GHCUP_DIR/env' in your current terminal"
yellow "To do so, you may want to run 'source $GHCUP_DIR/env' in your current terminal"
yellow "session as well as your shell configuration (e.g. ~/.bashrc)."
}
@@ -677,4 +693,3 @@ _done
)
# vim: tabstop=4 shiftwidth=4 expandtab

View File

@@ -174,7 +174,17 @@ span.code {
line-height: 2rem;
}
#help {
margin-bottom: 0px !important;
}
#collective {
margin-top: 1em !important;
margin-bottom: 0px !important;
}
#about {
margin-top: 0.5em !important;
font-size: 16px;
line-height: 2em;
}

View File

@@ -137,9 +137,14 @@
</div>
<p>
<p id="help">
Need help? Ask on <a href="https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup"><img src="irc.svg" height="18px" alt="" />IRC</a>, <a href="https://discord.gg/pKYf3zDQU7"><img src="Discord-Logo-Black.svg" height="18px" alt="" />Discord</a>, <a href="https://app.element.io/#/room/#haskell-tooling:matrix.org"><img src="Matrix_logo.svg" height="25px" alt="" style="top:5px;position:relative;" /></a> or <a href="https://gitlab.haskell.org/haskell/ghcup-hs/issues">report a bug <img src="Octicons-bug.svg" height="18px" alt="" /></a>.
</p>
<p id="collective">
<a id="collective" href="https://opencollective.com/ghcup#category-CONTRIBUTE" target="_blank">
<img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" width=200 />
</a>
</p>
<p id="about">
<img src="haskell-logo.svg" alt="" />