Compare commits

..

41 Commits

Author SHA1 Message Date
4be97ffd7c Pad and use hyperlinks 2023-01-03 23:43:46 +08:00
009f9211a9 Integrate with errors.haskell.org
Fixes #434
2023-01-03 23:43:46 +08:00
109187eb6f Merge branch 'issue-367-content-prop' 2023-01-03 23:17:35 +08:00
e881705323 Merge branch 'issue-440' 2023-01-03 22:47:12 +08:00
ea06c155a7 Merge branch 'issue-695' 2023-01-03 22:46:52 +08:00
d4732e15a7 Merge branch 'issue-716' 2023-01-03 22:46:13 +08:00
db6f784a1f Merge branch 'error-handling' 2023-01-03 22:45:25 +08:00
82e3837dd9 Update windows golden test file 2023-01-02 21:42:52 +08:00
957c5918b8 Upload golden files on failure 2023-01-02 20:47:49 +08:00
9d4c923649 Add content-length property to downloads
This is optional for now. Fixes #367
2023-01-02 20:41:42 +08:00
24c36ef856 Fix failure with --isolate=dir --force
Fixes #695
2023-01-02 20:39:27 +08:00
2783b8f693 Fix 'ghcup install hls -u' on windows
Fixes #716
2023-01-02 20:38:58 +08:00
d5a680e3c6 Don't clean up tmp dirs when --keep=always 2023-01-02 20:38:26 +08:00
d1075987de Fix ARM cleanup 2023-01-02 20:35:46 +08:00
e116a2392e Enable arm tests 2023-01-01 21:40:04 +08:00
7dd6f1f4a4 Expose metadata-caching to --help 2023-01-01 19:19:37 +08:00
4d82c37539 Add --metadata-fetching-mode arg, fixes #440 2023-01-01 19:16:32 +08:00
801b1edfa7 Merge remote-tracking branch 'origin/pr/730' 2022-12-31 21:10:59 +08:00
c1b67e1787 Merge branch 'issue-433' 2022-12-27 00:11:23 +08:00
70dd106549 Merge branch 'issue-708' 2022-12-27 00:10:41 +08:00
b098aa4e65 Merge branch 'issue-368' 2022-12-27 00:09:59 +08:00
74b784fcfb Merge branch 'issue-391-gh' 2022-12-27 00:09:39 +08:00
673db344d6 Merge branch 'issue-414' 2022-12-27 00:09:28 +08:00
5594a19c02 Merge branch 'issue-384' 2022-12-27 00:09:05 +08:00
Kristoffer Grundström
a5bc13fe50 Added Mageia
Signed-off-by: Kristoffer Grundström <lovaren@gmail.com>
2022-12-25 08:02:41 +01:00
a5f2067d76 Improve stripping logic 2022-12-21 13:44:31 +08:00
be8fa57be1 Freeze the MSYS2 version we install
Fixes #368
2022-12-20 23:38:48 +08:00
6ad9963889 Allow building newer GHCs from git
The user will have to pass --overwrite-version=<ver> because
we can't discover the GHC version from git anymore.

https://gitlab.haskell.org/ghc/ghc/-/issues/22322
2022-12-20 23:18:44 +08:00
bcddb05b1d Fix bootstrap under windows when msys2 has non-posix login shell 2022-12-20 22:46:58 +08:00
f7d2033e25 Improve postRm message, fixes #384 2022-12-20 22:20:10 +08:00
6ce7649cfe Improve upgrade warning wrt #414 2022-12-20 21:49:26 +08:00
cb0d8b80c3 Merge branch 'retry-cache' 2022-12-20 15:41:25 +08:00
95869f9560 Improve CI 2022-12-20 14:00:26 +08:00
e8586cf993 Improve add-release-channel, fixes #708 2022-12-20 00:57:56 +08:00
d195a3f86c Merge branch 'issue-706' 2022-12-19 02:03:47 +08:00
b171afa09d Document GHCUP_MSYS2, fixes #427 2022-12-19 00:52:11 +08:00
5cf49bffac Improve warning for incompatible HLS/GHC combos 2022-12-19 00:40:07 +08:00
5659de8516 Improve hyperlinks 2022-12-19 00:16:48 +08:00
0cd2b6d549 Improve documentation on stack hooks 2022-12-19 00:10:49 +08:00
ae092de4b6 Update CI 2022-12-18 22:00:33 +08:00
a7e6e7c27d Merge branch 'cirrus' 2022-12-16 19:12:49 +08:00
47 changed files with 8761 additions and 5284 deletions

View File

@@ -10,6 +10,16 @@ ecabal() {
cabal "$@"
}
sync_from_retry() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
else
cabal_store_path="${CABAL_DIR}/store"
fi
sync_from || { sleep 9 ; rm -rf "${cabal_store_path:?}"/* ; sync_from || { sleep 20 ; rm -rf "${cabal_store_path:?}"/* ; sync_from ; } }
}
sync_from() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
@@ -24,6 +34,10 @@ sync_from() {
--archive-uri "s3://ghcup-hs/${RUNNER_OS}-${ARCH}-${DISTRO}"
}
sync_to_retry() {
sync_to || { sleep 9 ; sync_to || { sleep 20 ; sync_to ; } }
}
sync_to() {
if [ "${RUNNER_OS}" != "Windows" ] ; then
cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store"
@@ -73,39 +87,29 @@ download_cabal_cache() {
cd /tmp
case "${RUNNER_OS}" in
"Linux")
case "${DISTRO}" in
"Alpine")
case "${ARCH}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/i386-linux-alpine-cabal-cache-1.0.5.1
;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-linux-alpine-cabal-cache-1.0.5.1
;;
esac
case "${ARCH}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/i386-linux-cabal-cache
;;
*)
case "${ARCH}" in
"64") url=https://github.com/haskell-works/cabal-cache/releases/download/v1.0.5.1/cabal-cache-x86_64-linux.gz
;;
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-linux-cabal-cache-1.0.5.1
;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/armv7-linux-cabal-cache-1.0.5.1
;;
esac
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-linux-cabal-cache
;;
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-linux-cabal-cache
;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/armv7-linux-cabal-cache
;;
esac
;;
"FreeBSD")
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-freebsd-cabal-cache-1.0.5.1
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-portbld-freebsd-cabal-cache
;;
"Windows")
exe=".exe"
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-mingw64-cabal-cache-1.0.5.1.exe
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-mingw64-cabal-cache
;;
"macOS")
case "${ARCH}" in
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-apple-darwin-cabal-cache-1.0.5.1
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-apple-darwin-cabal-cache
;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-apple-darwin-cabal-cache-1.0.5.1
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-apple-darwin-cabal-cache
;;
esac
;;
@@ -120,8 +124,9 @@ download_cabal_cache() {
curl -o cabal-cache${exe} -L "${url}"
;;
esac
chmod +x cabal-cache${exe}
cp "cabal-cache${exe}" "${dest}${exe}"
sha_sum cabal-cache${exe}
mv "cabal-cache${exe}" "${dest}${exe}"
chmod +x "${dest}${exe}"
fi
)
}
@@ -129,11 +134,11 @@ download_cabal_cache() {
build_with_cache() {
ecabal configure "$@"
ecabal build --dependencies-only "$@" --dry-run
sync_from
ecabal build --dependencies-only "$@" || sync_to
sync_to
sync_from_retry
ecabal build --dependencies-only "$@" || sync_to_retry
sync_to_retry
ecabal build "$@"
sync_to
sync_to_retry
}
install_ghcup() {
@@ -153,13 +158,15 @@ install_ghcup() {
strip_binary() {
(
set -e
binary=$1
if [ "${RUNNER_OS}" = "macOS" ] ; then
strip "${binary}"
else
if [ "${RUNNER_OS}" != "Windows" ] ; then
local binary=$1
case "$(uname -s)" in
"Darwin"|"darwin")
;;
MSYS_*|MINGW*)
;;
*)
strip -s "${binary}"
fi
fi
;;
esac
)
}

View File

@@ -57,9 +57,9 @@ eghcup debug-info
cd "haskell-language-server-${HLS_TARGET_VERSION}/"
ecabal configure -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)"
ecabal build --dependencies-only -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)" --dry-run
sync_from
sync_from_retry
ecabal build --dependencies-only -w "ghc-${GHC_VERSION}" --disable-profiling --disable-tests --jobs="$(nproc)" || sync_to
sync_to
sync_to_retry
)
eghcup -v compile hls -j "$(nproc)" -g "${HLS_TARGET_VERSION}" --ghc "${GHC_VERSION}"

37
.github/workflows/cache.yaml vendored Normal file
View File

@@ -0,0 +1,37 @@
name: Cache eviction
on:
workflow_dispatch:
inputs:
key:
description: Which cache to evict
required: true
default: '/'
type: choice
options:
- FreeBSD-64-na
- Linux-32-Alpine
- Linux-64-Alpine
- Linux-64-Ubuntu
- Linux-ARM-Ubuntu
- Linux-ARM64-Ubuntu
- Windows-64-na
- macOS-64-na
- macOS-ARM64-na
- /
jobs:
evict:
runs-on: ubuntu-latest
steps:
- name: Remove from S3
uses: vitorsgomes/s3-rm-action@master
with:
args: --recursive
env:
AWS_S3_ENDPOINT: ${{ secrets.S3_HOST }}
AWS_S3_BUCKET: ghcup-hs
AWS_REGION: us-west-2
AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
PATH_TO_DELETE: ${{ github.event.inputs.key }}

View File

@@ -41,7 +41,8 @@ jobs:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup
with:
args: rm -rf .ghcup/
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: Checkout
uses: actions/checkout@v3
- name: Set up Docker Buildx

View File

@@ -13,8 +13,8 @@ on:
- cron: '0 2 * * *'
jobs:
build-alpine:
name: Build static linux binary
build-linux:
name: Build linux binary
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
@@ -102,7 +102,7 @@ jobs:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux)
with:
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +"
- name: git config
run: |
@@ -203,9 +203,9 @@ jobs:
./out/*
test-alpine:
test-linux:
name: Test linux
needs: "build-alpine"
needs: "build-linux"
runs-on: ${{ matrix.os }}
env:
CABAL_VER: 3.6.2.0
@@ -272,6 +272,14 @@ jobs:
DISTRO: ${{ matrix.DISTRO }}
APT_GET: "sudo apt-get"
- if: failure()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
test-arm:
name: Test ARM
needs: "build-arm"
@@ -297,7 +305,7 @@ jobs:
- uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux)
with:
args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +"
- name: Checkout code
uses: actions/checkout@v3
@@ -311,9 +319,9 @@ jobs:
- if: matrix.ARCH == 'ARM'
uses: docker://hasufell/arm32v7-ubuntu-haskell:focal
name: Run build (armv7 linux)
name: Run test (armv7 linux)
with:
run: sh .github/scripts/test.sh
args: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
@@ -322,15 +330,23 @@ jobs:
- if: matrix.ARCH == 'ARM64'
uses: docker://hasufell/arm64v8-ubuntu-haskell:focal
name: Run build (aarch64 linux)
name: Run test (aarch64 linux)
with:
run: sh .github/scripts/test.sh
args: sh .github/scripts/test.sh
env:
ARTIFACT: ${{ matrix.ARTIFACT }}
ARCH: ${{ matrix.ARCH }}
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Ubuntu
- if: failure()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
test-macwin:
name: Test Mac/Win
needs: "build-macwin"
@@ -377,9 +393,25 @@ jobs:
GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }}
HOMEBREW_CHANGE_ARCH_TO_ARM: 1
- if: failure() && runner.os == 'Windows'
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: testfiles
path: |
./test/golden/windows/GHCupInfo*json
- if: failure() && runner.os != 'Windows'
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
hls:
name: hls
needs: build-alpine
needs: build-linux
runs-on: ubuntu-latest
env:
GHC_VERSION: "8.10.7"
@@ -410,7 +442,7 @@ jobs:
release:
name: release
needs: ["test-alpine", "test-arm", "test-macwin", "hls"]
needs: ["test-linux", "test-arm", "test-macwin", "hls"]
runs-on: ubuntu-latest
if: startsWith(github.ref, 'refs/tags/v')
steps:

View File

@@ -13,6 +13,7 @@ import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.OptParse.Common (logGHCPostRm)
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude.File
import GHCup.Prelude.Logger
@@ -433,6 +434,7 @@ install' _ (_, ListResult {..}) = do
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, DirNotEmpty
@@ -485,7 +487,7 @@ install' _ (_, ListResult {..}) = do
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left $ prettyShow e <> "\n"
VLeft e -> pure $ Left $ prettyHFError e <> "\n"
<> "Also check the logs in ~/.ghcup/logs"
@@ -522,7 +524,7 @@ set' bs input@(_, ListResult {..}) = do
logInfo "Setting now..."
set' bs input
PromptNo -> pure $ Left (prettyShow e)
PromptNo -> pure $ Left (prettyHFError e)
where
userPrompt = L.toStrict . B.toLazyText . B.fromString $
"This Version of "
@@ -530,7 +532,7 @@ set' bs input@(_, ListResult {..}) = do
<> " you are trying to set is not installed.\n"
<> "Would you like to install it first? [Y/N]: "
_ -> pure $ Left (prettyShow e)
_ -> pure $ Left (prettyHFError e)
@@ -554,10 +556,11 @@ del' _ (_, ListResult {..}) = do
)
>>= \case
VRight vi -> do
logGHCPostRm (mkTVer lVer)
forM_ (_viPostRemove =<< vi) $ \msg ->
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
VLeft e -> pure $ Left (prettyHFError e)
changelog' :: (MonadReader AppState m, MonadIO m)
@@ -577,7 +580,7 @@ changelog' _ (_, ListResult {..}) = do
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e
Left e -> pure $ Left $ prettyHFError e
settings' :: IORef AppState
@@ -630,12 +633,12 @@ getGHCupInfo = do
r <-
flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE getDownloadsF
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)
VLeft e -> pure $ Left (prettyHFError e)
getAppData :: Maybe GHCupInfo

View File

@@ -67,13 +67,13 @@ import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
data Options = Options
{
-- global options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optMetaCache :: Maybe Integer
, optMetaMode :: Maybe MetaMode
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
@@ -108,6 +108,7 @@ data Command
| Prefetch PrefetchCommand
| GC GCOptions
| Run RunOptions
| PrintAppErrors
@@ -116,7 +117,8 @@ opts =
Options
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
<*> optional (option auto (long "metadata-caching" <> metavar "SEC" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable"))
<*> optional (option auto (long "metadata-fetching-mode" <> metavar "<Strict|Lax>" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))"))
<*> optional
(option
(eitherReader platformParser)
@@ -340,3 +342,10 @@ com =
<> commandGroup "Nuclear Commands:"
<> hidden
)
<|> subparser
(command
"print-app-errors"
(info (pure PrintAppErrors <**> helper)
(progDesc ""))
<> internal
)

View File

@@ -12,6 +12,7 @@ module GHCup.OptParse.ChangeLog where
import GHCup.Types
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Prelude
import GHCup.Prelude.Logger
@@ -148,6 +149,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyShow e)
Left e -> logError (T.pack $ prettyHFError e)
>> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess

View File

@@ -25,6 +25,7 @@ import Control.DeepSeq
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe
import Control.Monad.Identity (Identity(..))
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
@@ -64,6 +65,7 @@ import qualified Text.Megaparsec as MP
import qualified System.FilePath.Posix as FP
import GHCup.Version
import Control.Exception (evaluate)
import qualified Cabal.Config as CC
-------------
@@ -789,3 +791,12 @@ checkForUpdates = do
pure $ catMaybes (ghcup:otherTools)
where
forMM a f = fmap join $ forM a f
logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m ()
logGHCPostRm ghcVer = do
cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store")
(runIdentity . CC.cfgStoreDir <$> CC.readConfig)
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir

View File

@@ -40,7 +40,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@@ -420,6 +419,7 @@ hlsCompileOpts =
type GHCEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
@@ -443,6 +443,7 @@ type GHCEffects = '[ AlreadyInstalled
type HLSEffects = '[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
@@ -544,14 +545,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
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" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath 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
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@@ -606,12 +607,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath 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
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9

View File

@@ -59,7 +59,7 @@ data ConfigCommand
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
@@ -124,6 +124,7 @@ updateSettings :: UserSettings -> Settings -> Settings
updateSettings UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache
metaMode' = fromMaybe metaMode uMetaMode
noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader
@@ -132,7 +133,7 @@ updateSettings UserSettings{..} Settings{..} =
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
@@ -188,9 +189,15 @@ config configCommand settings keybindings runLogger = case configCommand of
AddSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
pure ExitSuccess
_ -> do
GHCupURL -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ExitSuccess
OwnSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (xs <> [Right uri]) })
pure ExitSuccess
OwnSpec spec -> do
doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource ([Left spec, Right uri]) })
pure ExitSuccess
where
doConfig :: MonadIO m => UserSettings -> m ()

View File

@@ -115,5 +115,5 @@ dinfo runAppState runLogger = do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 8

View File

@@ -27,7 +27,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -139,5 +138,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27

View File

@@ -38,7 +38,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@@ -243,6 +242,7 @@ type InstallEffects = '[ AlreadyInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
@@ -271,6 +271,7 @@ type InstallGHCEffects = '[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, ContentLengthError
, DirNotEmpty
, DownloadFailed
, FileAlreadyExistsError
@@ -332,7 +333,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing)
(_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
@@ -349,10 +350,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
@@ -366,22 +367,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3
@@ -402,7 +403,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "")
(DownloadInfo uri Nothing "" Nothing)
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
@@ -416,14 +417,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
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@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -431,7 +432,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@@ -452,7 +453,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy
liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing)
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
@@ -466,14 +467,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
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@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -481,7 +482,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@@ -501,7 +502,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "")
(DownloadInfo uri Nothing "" Nothing)
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
@@ -515,14 +516,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
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@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -530,6 +531,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4

View File

@@ -26,7 +26,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -95,5 +94,5 @@ nuke appState runLogger = do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

View File

@@ -30,7 +30,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -153,6 +152,7 @@ type PrefetchEffects = '[ TagNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, JSONError
@@ -215,5 +215,5 @@ prefetch prefetchCommand runAppState runLogger =
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

View File

@@ -34,7 +34,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -175,11 +174,11 @@ rm rmCommand runAppState runLogger = case rmCommand of
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
runLogger $ logGHCPostRm ghcVer
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 7
rmCabal' tv =
@@ -191,11 +190,10 @@ rm rmCommand runAppState runLogger = case rmCommand of
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmHLS' tv =
@@ -207,11 +205,10 @@ rm rmCommand runAppState runLogger = case rmCommand of
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmStack' tv =
@@ -223,10 +220,12 @@ rm rmCommand runAppState runLogger = case rmCommand of
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
postRmLog vi =
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg

View File

@@ -40,7 +40,6 @@ import Prelude hiding ( appendFile )
import System.FilePath
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
@@ -177,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
@@ -265,11 +265,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
case r' of
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 28
#endif
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27
where
@@ -343,6 +343,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, DownloadFailed
, DirNotEmpty
, DigestError
, ContentLengthError
, BuildFailed
, ArchiveResult
, AlreadyInstalled

View File

@@ -35,7 +35,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Data.Bifunctor (second)
@@ -286,7 +285,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 5
@@ -307,7 +306,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
setHLS' :: SetOptions
@@ -327,7 +326,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
@@ -348,5 +347,5 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14

View File

@@ -23,7 +23,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import qualified Data.Text.IO as T
@@ -118,5 +117,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 12

View File

@@ -31,7 +31,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -189,7 +188,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
(UnsetCabal (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetCabal)

View File

@@ -28,7 +28,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -88,6 +87,7 @@ upgradeOptsP =
type UpgradeEffects = '[ DigestError
, ContentLengthError
, GPGError
, NoDownload
, NoUpdate
@@ -151,5 +151,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 11

View File

@@ -34,7 +34,6 @@ import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -288,7 +287,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
@@ -302,7 +301,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
@@ -318,7 +317,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do

View File

@@ -79,6 +79,7 @@ toSettings options = do
mergeConf Options{..} UserSettings{..} noColor =
let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache
metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode
noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
@@ -205,19 +206,19 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
ghcupInfo <-
( flip runReaderT leanAppstate
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE getDownloadsF
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
@@ -253,7 +254,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
logWarn ("New "
<> T.pack (prettyShow t)
<> " version available. "
<> "To upgrade, run 'ghcup install "
<> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t)
<> " "
<> prettyVer l
@@ -265,7 +266,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
VRight _ -> pure ()
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 30)
pure s'
@@ -310,6 +311,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess
case res of
ExitSuccess -> pure ()

View File

@@ -40,6 +40,12 @@ key-bindings:
# of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.yaml'.
meta-cache: 300 # in seconds
# When trying to download ghcup metadata, this option decides what to do
# when the download fails:
# 1. Lax: use existing ~/.ghcup/cache/ghcup-<ver>.yaml as fallback (default)
# 2. Strict: fail hard
meta-mode: Lax # Strict | Lax
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code.
url-source:

View File

@@ -23,7 +23,7 @@ RUN apt-get update && \
openssh-client \
xz-utils \
zlib1g-dev \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip patchelf tree \
llvm-9 clang-9 && \
rm -rf /var/lib/apt/lists/*

View File

@@ -23,7 +23,7 @@ RUN apt-get update && \
openssh-client \
xz-utils \
zlib1g-dev \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip \
libnuma-dev libgmp10 libssl-dev liblzma-dev libbz2-dev wget lsb-release software-properties-common apt-transport-https gcc autoconf automake build-essential gzip patchelf tree \
llvm-9 clang-9 && \
rm -rf /var/lib/apt/lists/*

View File

@@ -97,6 +97,10 @@ This is the complete list of env variables that change GHCup behavior:
* `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
On windows, there's additionally:
* `GHCUP_MSYS2`: Has to point to the root of an existing MSYS2 installation (when installed by GHCup, that's e.g. `C:\ghcup\msys64`). GHCup bootstrap takes care of this usually.
### XDG support
To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
@@ -198,6 +202,50 @@ url-source:
- "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
```
## Stack integration
Stack manages GHC versions internally by default. In order to make it use ghcup installed
GHC versions there are two strategies.
### Strategy 1: System GHC (works on all stack versions)
You can instruct stack to use "system" GHC versions (whatever is in PATH). To do so,
run the following commands:
```sh
stack config set install-ghc false --global
stack config set system-ghc true --global
```
### Strategy 2: Stack hooks (new, recommended)
Since stack 2.9.1 you can customize the installation logic of GHC completely, see [https://docs.haskellstack.org/en/stable/yaml_configuration/#ghc-installation-customisation](https://docs.haskellstack.org/en/stable/yaml_configuration/#ghc-installation-customisation).
We can use this to simply invoke ghcup whenever stack is trying to install/discover a GHC versions. This
is done via placing a shell script at `~/.stack/hooks/ghc-install.sh` and making it executable.
The ghcup bootstrap script asks you during installation whether you want to install this shell script. You can also
install/update it manually like so:
```sh
mkdir -p ~/.stack/hooks/
curl https://raw.githubusercontent.com/haskell/ghcup-hs/master/scripts/hooks/stack/ghc-install.sh \
> ~/.stack/hooks/ghc-install.sh
chmod +x ~/.stack/hooks/ghc-install.sh
# hooks are only run when 'system-ghc: false'
stack config set system-ghc false --global
```
By default, when the hook fails for whatever reason, stack will fall back to its own installation logic. To disable
this, run `stack config set install-ghc false --global`.
### Windows
On windows, you may find the following config options useful too:
`skip-msys`, `extra-path`, `extra-include-dirs`, `extra-lib-dirs`.
Also check out: [https://docs.haskellstack.org/en/stable/yaml_configuration](https://docs.haskellstack.org/en/stable/yaml_configuration)
# More on installation
## Customisation of the installation scripts

View File

@@ -48,6 +48,10 @@ The following distro packages are required: `build-essential curl libffi-dev lib
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
### Linux Mageia
The following distro packages are required: `curl gcc gcc-c++ gmp libffi-devel libffi7 libgmp-devel libgmp10 make libncurses-devel libncurses5 xz perl`
### Linux CentOS
The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`

View File

@@ -247,6 +247,7 @@ executable ghcup
, base >=4.12 && <5
, bytestring >=0.10 && <0.12
, cabal-plan ^>=0.7.2
, cabal-install-parsers >=0.4.5
, containers ^>=0.6
, deepseq ^>=1.4
, directory ^>=1.3.6.0

View File

@@ -78,7 +78,6 @@ import Text.Regex.Posix
import qualified Data.Text as T
import qualified Streamly.Prelude as S
import Text.PrettyPrint.HughesPJClass (prettyShow)
@@ -106,6 +105,7 @@ fetchToolBindist :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -288,6 +288,7 @@ upgradeGHCup :: ( MonadMask m
-> Excepts
'[ CopyError
, DigestError
, ContentLengthError
, GPGError
, GPGError
, DownloadFailed
@@ -308,7 +309,7 @@ upgradeGHCup mtarget force' fatal = do
dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- fromGHCupPath <$> lift withGHCupTmpDir
let fn = "ghcup" <> exeExt
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) tmp (Just fn) False
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ logDebug $ "mkdir -p " <> T.pack destDir
@@ -326,7 +327,7 @@ upgradeGHCup mtarget force' fatal = do
Just pa
| fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
| otherwise ->
lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)
lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)
pure latestVer

View File

@@ -50,7 +50,6 @@ import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
@@ -81,6 +80,7 @@ installCabalBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -184,6 +184,7 @@ installCabalBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -233,7 +234,7 @@ setCabal ver = do
liftIO (isShadowed cabalbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa cabalbin ver)
pure ()

View File

@@ -75,7 +75,6 @@ import System.Exit
import System.FilePath
import System.IO.Error
import System.IO.Temp
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
@@ -114,7 +113,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadMask m
)
=> Excepts
'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF = do
@@ -162,17 +161,21 @@ getBase :: ( MonadReader env m
, MonadMask m
)
=> URI
-> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do
Settings { noNetwork, downloader } <- lift getSettings
Settings { noNetwork, downloader, metaMode } <- lift getSettings
-- try to download yaml... usually this writes it into cache dir,
-- but in some cases not (e.g. when using file://), so we honour
-- the return filepath, if any
mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
then pure Nothing
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
else handleIO (\e -> case metaMode of
Strict -> throwIO e
Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of
Strict -> throwE e
Lax -> lift (warnCache (prettyHFError e) downloader) >> pure Nothing)
. fmap Just
. smartDl
$ uri
@@ -184,7 +187,7 @@ getBase uri = do
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
. liftIO
. liftIO
. Y.decodeFileEither
$ actualYaml
where
@@ -229,6 +232,7 @@ getBase uri = do
-> Excepts
'[ DownloadFailed
, DigestError
, ContentLengthError
, GPGError
]
m1
@@ -242,7 +246,7 @@ getBase uri = do
Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True
if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True
| e -> do
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -258,7 +262,7 @@ getBase uri = do
where
dlWithMod modTime json_file = do
let (dir, fn) = splitFileName json_file
f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing dir (Just fn) True
liftIO $ setModificationTime f modTime
liftIO $ setAccessTime f modTime
pure f
@@ -324,13 +328,14 @@ download :: ( MonadReader env m
=> URI
-> Maybe URI -- ^ URI for gpg sig
-> Maybe T.Text -- ^ expected hash
-> Maybe Integer -- ^ expected content length
-> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest dest mfn etags
| scheme == "https" = dl
| scheme == "http" = dl
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl
| scheme == "http" = liftE dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
lift $ logDebug $ "using local file: " <> T.pack destFile'
@@ -351,7 +356,7 @@ download uri gpgUri eDigest dest mfn etags
-- download
flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
(\e' -> do
lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
case e' of
@@ -386,7 +391,7 @@ download uri gpgUri eDigest dest mfn etags
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))
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
) $ do
o' <- liftIO getGpgOpts
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
@@ -401,19 +406,37 @@ download uri gpgUri eDigest dest mfn etags
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
_ -> pure ()
forM_ eCSize (liftE . flip checkCSize baseDestFile)
forM_ eDigest (liftE . flip checkDigest baseDestFile)
pure baseDestFile
curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
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
(o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']
++ maybe [] (\s -> ["--max-filesize", show s]) eCSize
) 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 :: ( 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"
@@ -440,7 +463,14 @@ download uri gpgUri eDigest dest mfn etags
lift $ writeEtags destFile (parseEtags headers)
wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
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
@@ -449,8 +479,16 @@ download uri gpgUri eDigest dest mfn etags
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 :: ( 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
@@ -471,7 +509,10 @@ download uri gpgUri eDigest dest mfn etags
| otherwise -> throwE (NonZeroExit i' "wget" opts)
#if defined(INTERNAL_DOWNLOADER)
internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
internalDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do
let destFileTemp = tmpFile destFile
@@ -481,11 +522,16 @@ download uri gpgUri eDigest dest mfn etags
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFileTemp mempty
$ downloadToFile https host fullPath port destFileTemp mempty eCSize
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
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
@@ -497,7 +543,7 @@ download uri gpgUri eDigest dest mfn etags
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFileTemp addHeaders
r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif
@@ -505,7 +551,7 @@ download uri gpgUri eDigest dest mfn etags
-- Manage to find a file we can write the body into.
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' =
getDestFile uri' mfn' =
let path = view pathL' uri'
in case mfn' of
Just fn -> pure (dest </> fn)
@@ -574,14 +620,14 @@ downloadCached :: ( MonadReader env m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-> Excepts '[DigestError, ContentLengthError, 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) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) mfn False
downloadCached' :: ( MonadReader env m
@@ -596,7 +642,7 @@ downloadCached' :: ( MonadReader env m
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
@@ -605,9 +651,10 @@ downloadCached' dli mfn mDestDir = do
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir mfn False
@@ -638,6 +685,25 @@ checkDigest eDigest file = do
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest)
checkCSize :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, HasLog env
)
=> Integer
-> FilePath
-> Excepts '[ContentLengthError] m ()
checkCSize eCSize file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ logInfo $ "verifying content length of: " <> T.pack p'
cSize <- liftIO $ getFileSize file
when ((eCSize /= cSize) && verify) $ throwE (ContentLengthError (Just file) (Just cSize) eCSize)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [String]

View File

@@ -17,14 +17,12 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.ByteString.Builder
import Data.CaseInsensitive ( CI, original, mk )
import Data.IORef
import Data.Maybe
import Data.Text.Read
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
@@ -33,7 +31,6 @@ import System.ProgressBar
import URI.ByteString
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import qualified System.IO.Streams as Streams
@@ -46,27 +43,6 @@ import qualified System.IO.Streams as Streams
----------------------------
-- | Load the result of this download into memory at once.
downloadBS' :: MonadIO m
=> Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
L.ByteString
downloadBS' https host path port = do
bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
void $ downloadInternal False https host path port stepper (pure ()) mempty
liftIO (readIORef bref <&> toLazyByteString)
downloadToFile :: (MonadMask m, MonadIO m)
=> Bool -- ^ https?
@@ -75,8 +51,9 @@ downloadToFile :: (MonadMask m, MonadIO m)
-> Maybe Int -- ^ optional port (e.g. 3000)
-> FilePath -- ^ destination file to create and write to
-> M.Map (CI ByteString) ByteString -- ^ additional headers
-> Maybe Integer -- ^ expected content length
-> Excepts '[DownloadFailed, HTTPNotModified] m Response
downloadToFile https host fullPath port destFile addHeaders = do
downloadToFile https host fullPath port destFile addHeaders eCSize = do
let stepper = BS.appendFile destFile
setup = BS.writeFile destFile mempty
catchAllE (\case
@@ -84,7 +61,7 @@ downloadToFile https host fullPath port destFile addHeaders = do
| i == 304
, Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e)
v -> throwE $ DownloadFailed v
) $ downloadInternal True https host fullPath port stepper setup addHeaders
) $ downloadInternal True https host fullPath port stepper setup addHeaders eCSize
downloadInternal :: MonadIO m
@@ -96,19 +73,21 @@ downloadInternal :: MonadIO m
-> (ByteString -> IO a) -- ^ the consuming step function
-> IO a -- ^ setup action
-> M.Map (CI ByteString) ByteString -- ^ additional headers
-> Maybe Integer
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
, ContentLengthError
]
m
Response
downloadInternal = go (5 :: Int)
where
go redirs progressBar https host path port consumer setup addHeaders = do
go redirs progressBar https host path port consumer setup addHeaders eCSize = do
r <- liftIO $ withConnection' https host port action
veitherToExcepts r >>= \case
Right r' ->
@@ -138,25 +117,39 @@ downloadInternal = go (5 :: Int)
followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders eCSize
Left e -> throwE e
downloadStream r i' = do
void setup
let size = case getHeader r "Content-Length" of
Just x' -> case decimal $ decUTF8Safe x' of
Left _ -> 0
Right (r', _) -> r'
Nothing -> 0
Left _ -> Nothing
Right (r', _) -> Just r'
Nothing -> Nothing
(mpb :: Maybe (ProgressBar ())) <- if progressBar
then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
else pure Nothing
forM_ size $ \s -> forM_ eCSize $ \es -> when (es /= s) $ throwIO (ContentLengthError Nothing (Just s) es)
let size' = eCSize <|> size
(mpb :: Maybe (ProgressBar ())) <- case (progressBar, size') of
(True, Just size'') -> Just <$> newProgressBar defStyle 10 (Progress 0 (fromInteger size'') ())
_ -> pure Nothing
ior <- liftIO $ newIORef 0
outStream <- liftIO $ Streams.makeOutputStream
(\case
Just bs -> do
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
let len = BS.length bs
forM_ mpb $ \pb -> incProgress pb len
-- check we don't exceed size
forM_ size' $ \s -> do
cs <- readIORef ior
when ((cs + toInteger len) > s) $ throwIO (ContentLengthError Nothing (Just (cs + toInteger len)) s)
modifyIORef ior (+ toInteger len)
void $ consumer bs
Nothing -> pure ()
)

View File

@@ -6,6 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-|
Module : GHCup.Errors
@@ -34,9 +35,150 @@ import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Data (Proxy(..))
allHFError :: String
allHFError = unlines allErrors
where
format p = "GHCup-" <> show (eBase p) <> " " <> eDesc p
format'' e p = "GHCup-" <> show (eNum e) <> " " <> eDesc p
format' e _ = "GHCup-" <> show (eNum e) <> " " <> prettyShow e
format''' e _ str' = "GHCup-" <> show (eNum e) <> " " <> str'
allErrors =
[ "# low level errors (1 to 500)"
, let proxy = Proxy :: Proxy NoCompatiblePlatform in format proxy
, let proxy = Proxy :: Proxy NoDownload in format proxy
, let proxy = Proxy :: Proxy NoUpdate in format proxy
, let proxy = Proxy :: Proxy DistroNotFound in format proxy
, let proxy = Proxy :: Proxy UnknownArchive in format proxy
, let proxy = Proxy :: Proxy UnsupportedScheme in format proxy
, let proxy = Proxy :: Proxy CopyError in format proxy
, let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
, let proxy = Proxy :: Proxy TagNotFound in format proxy
, let proxy = Proxy :: Proxy NextVerNotFound in format proxy
, let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
, let proxy = Proxy :: Proxy DirNotEmpty in format proxy
, let proxy = Proxy :: Proxy NotInstalled in format proxy
, let proxy = Proxy :: Proxy UninstallFailed in format proxy
, let proxy = Proxy :: Proxy NotFoundInPATH in format proxy
, let proxy = Proxy :: Proxy JSONError in format proxy
, let proxy = Proxy :: Proxy FileDoesNotExistError in format proxy
, let proxy = Proxy :: Proxy FileAlreadyExistsError in format proxy
, let proxy = Proxy :: Proxy TarDirDoesNotExist in format proxy
, let proxy = Proxy :: Proxy DigestError in format proxy
, let proxy = Proxy :: Proxy GPGError in format proxy
, let proxy = Proxy :: Proxy HTTPStatusError in format proxy
, let proxy = Proxy :: Proxy MalformedHeaders in format proxy
, let proxy = Proxy :: Proxy HTTPNotModified in format proxy
, let proxy = Proxy :: Proxy NoLocationHeader in format proxy
, let proxy = Proxy :: Proxy TooManyRedirs in format proxy
, let proxy = Proxy :: Proxy PatchFailed in format proxy
, let proxy = Proxy :: Proxy NoToolRequirements in format proxy
, let proxy = Proxy :: Proxy InvalidBuildConfig in format proxy
, let proxy = Proxy :: Proxy NoToolVersionSet in format proxy
, let proxy = Proxy :: Proxy NoNetwork in format proxy
, let proxy = Proxy :: Proxy HadrianNotFound in format proxy
, let proxy = Proxy :: Proxy ToolShadowed in format proxy
, let proxy = Proxy :: Proxy ContentLengthError in format proxy
, ""
, "# high level errors (5000+)"
, let proxy = Proxy :: Proxy DownloadFailed in format proxy
, let proxy = Proxy :: Proxy InstallSetError in format proxy
, let proxy = Proxy :: Proxy BuildFailed in format proxy
, let proxy = Proxy :: Proxy GHCupSetError in format proxy
, ""
, "# true exceptions (500+)"
, let proxy = Proxy :: Proxy ParseError in format proxy
, let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
, let proxy = Proxy :: Proxy NoUrlBase in format proxy
, ""
, "# orphans (800+)"
, let proxy = Proxy :: Proxy URIParseError in format proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedScheme MissingColon
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedUserInfo
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedQuery
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedFragment
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedHost
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedPort
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = MalformedPath
in format' e proxy
, let proxy = Proxy :: Proxy URIParseError
e = OtherError ""
in format'' e proxy
, let proxy = Proxy :: Proxy ArchiveResult in format proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveFatal
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveFailed
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveWarn
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveRetry
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveOk
in format' e proxy
, let proxy = Proxy :: Proxy ArchiveResult
e = ArchiveEOF
in format' e proxy
, let proxy = Proxy :: Proxy ProcessError in format proxy
, let proxy = Proxy :: Proxy ProcessError
e = NonZeroExit 0 "" []
in format''' e proxy "A process returned a non-zero exit code."
, let proxy = Proxy :: Proxy ProcessError
e = PTerminated "" []
in format''' e proxy "A process terminated prematurely."
, let proxy = Proxy :: Proxy ProcessError
e = PStopped "" []
in format''' e proxy "A process stopped prematurely."
, let proxy = Proxy :: Proxy ProcessError
e = NoSuchPid "" []
in format''' e proxy "Could not find PID for this process."
]
prettyHFError :: (Pretty e, HFErrorProject e) => e -> String
prettyHFError e =
let errorCode = "GHCup-" <> padIntAndShow (eNum e)
in ("[" <> linkEscapeCode errorCode (hfErrorLink errorCode) <> "] ") <> prettyShow e
where
linkEscapeCode linkText link = "\ESC]8;;" <> link <> "\ESC\\" <> linkText <> "\ESC]8;;\ESC\\"
hfErrorLink errorCode = "https://errors.haskell.org/messages/" <> errorCode
padIntAndShow i
| i < 10 = "0000" <> show i
| i < 100 = "000" <> show i
| i < 1000 = "00" <> show i
| i < 10000 = "0" <> show i
| otherwise = show i
class HFErrorProject a where
eNum :: a -> Int
eNum _ = eBase (Proxy :: Proxy a)
eBase :: Proxy a -> Int
eDesc :: Proxy a -> String
------------------------
--[ Low-level errors ]--
------------------------
@@ -51,20 +193,32 @@ instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
instance HFErrorProject NoCompatiblePlatform where
eBase _ = 1
eDesc _ = "No compatible platform could be found"
-- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload
deriving Show
instance Pretty NoDownload where
pPrint NoDownload =
text "Unable to find a download for the requested version/distro."
text (eDesc (Proxy :: Proxy NoDownload))
instance HFErrorProject NoDownload where
eBase _ = 10
eDesc _ = "Unable to find a download for the requested version/distro."
-- | No update available or necessary.
data NoUpdate = NoUpdate
deriving Show
instance Pretty NoUpdate where
pPrint NoUpdate = text "No update available or necessary."
pPrint NoUpdate = text (eDesc (Proxy :: Proxy NoUpdate))
instance HFErrorProject NoUpdate where
eBase _ = 20
eDesc _ = "No update available or necessary."
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String
@@ -74,13 +228,21 @@ instance Pretty NoCompatibleArch where
pPrint (NoCompatibleArch arch) =
text ("The Architecture is unknown or unsupported. Got: " ++ arch)
instance HFErrorProject NoCompatibleArch where
eBase _ = 30
eDesc _ = "The Architecture is unknown and unsupported"
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound
deriving Show
instance Pretty DistroNotFound where
pPrint DistroNotFound =
text "Unable to figure out the distribution of the host."
text (eDesc (Proxy :: Proxy DistroNotFound))
instance HFErrorProject DistroNotFound where
eBase _ = 40
eDesc _ = "Unable to figure out the distribution of the host"
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive FilePath
@@ -90,12 +252,21 @@ instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text $ "The archive format is unknown. We don't know how to extract the file " <> file
instance HFErrorProject UnknownArchive where
eBase _ = 50
eDesc _ = "The archive format is unknown. We don't know how to extract it."
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show
instance Pretty UnsupportedScheme where
pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
pPrint UnsupportedScheme =
text (eDesc (Proxy :: Proxy UnsupportedScheme))
instance HFErrorProject UnsupportedScheme where
eBase _ = 60
eDesc _ = "The scheme is not supported (such as ftp)."
-- | Unable to copy a file.
data CopyError = CopyError String
@@ -105,6 +276,10 @@ instance Pretty CopyError where
pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason)
instance HFErrorProject CopyError where
eBase _ = 70
eDesc _ = "Unable to copy a file."
-- | Unable to merge file trees.
data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
deriving Show
@@ -114,6 +289,10 @@ instance Pretty MergeFileTreeError where
text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
<+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."
instance HFErrorProject MergeFileTreeError where
eBase _ = 80
eDesc _ = "Unable to merge file trees during installation"
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
@@ -122,6 +301,10 @@ instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
instance HFErrorProject TagNotFound where
eBase _ = 90
eDesc _ = "Unable to find a tag of a tool"
-- | Unable to find the next version of a tool (the one after the currently
-- set one).
data NextVerNotFound = NextVerNotFound Tool
@@ -131,6 +314,10 @@ instance Pretty NextVerNotFound where
pPrint (NextVerNotFound tool) =
text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
instance HFErrorProject NextVerNotFound where
eBase _ = 100
eDesc _ = "Unable to find the next version of a tool (the one after the currently set one)"
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show
@@ -140,6 +327,9 @@ instance Pretty AlreadyInstalled where
(pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"
<+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")
instance HFErrorProject AlreadyInstalled where
eBase _ = 110
eDesc _ = "The tool (such as GHC) is already installed with that version"
-- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath}
@@ -149,6 +339,10 @@ instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do
text $ "The directory was expected to be empty, but isn't: " <> path
instance HFErrorProject DirNotEmpty where
eBase _ = 120
eDesc _ = "The Directory is supposed to be empty, but wasn't"
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool GHCTargetVersion
@@ -158,6 +352,10 @@ instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
instance HFErrorProject NotInstalled where
eBase _ = 130
eDesc _ = "The required tool is not installed"
data UninstallFailed = UninstallFailed FilePath [FilePath]
deriving Show
@@ -165,6 +363,10 @@ instance Pretty UninstallFailed where
pPrint (UninstallFailed dir files) =
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
instance HFErrorProject UninstallFailed where
eBase _ = 140
eDesc _ = "Uninstallation failed with leftover files"
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show
@@ -175,6 +377,10 @@ instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text $ "The exe " <> exe <> " was not found in PATH."
instance HFErrorProject NotFoundInPATH where
eBase _ = 150
eDesc _ = "An executable was expected to be in PATH, but was not found"
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
@@ -183,6 +389,10 @@ instance Pretty JSONError where
pPrint (JSONDecodeError err) =
text $ "JSON decoding failed with: " <> err
instance HFErrorProject JSONError where
eBase _ = 160
eDesc _ = "JSON decoding failed"
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError FilePath
@@ -192,6 +402,10 @@ instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text $ "File " <> file <> " does not exist."
instance HFErrorProject FileDoesNotExistError where
eBase _ = 170
eDesc _ = "A file that is supposed to exist does not exist (oops)"
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
-- (e.g. This is done to prevent any overwriting)
@@ -202,6 +416,10 @@ instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
text $ "File " <> file <> " Already exists."
instance HFErrorProject FileAlreadyExistsError where
eBase _ = 180
eDesc _ = "A file already exists that wasn't expected to exist"
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@@ -209,6 +427,10 @@ instance Pretty TarDirDoesNotExist where
pPrint (TarDirDoesNotExist dir) =
text "Tar directory does not exist:" <+> pPrint dir
instance HFErrorProject TarDirDoesNotExist where
eBase _ = 190
eDesc _ = "The tar directory (e.g. inside an archive) does not exist"
-- | File digest verification failed.
data DigestError = DigestError FilePath Text Text
deriving Show
@@ -219,7 +441,11 @@ instance Pretty DigestError where
<+> 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.
instance HFErrorProject DigestError where
eBase _ = 200
eDesc _ = "File digest verification failed"
-- | File PGP 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
@@ -227,6 +453,10 @@ deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
instance HFErrorProject GPGError where
eBase _ = 210
eDesc _ = "File PGP verification failed"
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
deriving Show
@@ -235,6 +465,10 @@ instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status _) =
text "Unexpected HTTP status:" <+> pPrint status
instance HFErrorProject HTTPStatusError where
eBase _ = 220
eDesc _ = "Unexpected HTTP status error (e.g. during downloads)"
-- | Malformed headers.
data MalformedHeaders = MalformedHeaders Text
deriving Show
@@ -243,6 +477,10 @@ instance Pretty MalformedHeaders where
pPrint (MalformedHeaders h) =
text "Headers are malformed: " <+> pPrint h
instance HFErrorProject MalformedHeaders where
eBase _ = 230
eDesc _ = "Malformed headers during download"
-- | Unexpected HTTP status.
data HTTPNotModified = HTTPNotModified Text
deriving Show
@@ -251,13 +489,21 @@ instance Pretty HTTPNotModified where
pPrint (HTTPNotModified etag) =
text "Remote resource not modifed, etag was:" <+> pPrint etag
instance HFErrorProject HTTPNotModified where
eBase _ = 240
eDesc _ = "Not modified HTTP status error (e.g. during downloads)."
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text "The 'Location' header was expected during a 3xx redirect, but not found."
text (eDesc (Proxy :: Proxy NoLocationHeader))
instance HFErrorProject NoLocationHeader where
eBase _ = 250
eDesc _ = "The 'Location' header was expected during a 3xx redirect, but not found."
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
@@ -265,7 +511,11 @@ data TooManyRedirs = TooManyRedirs
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text "Too many redirections."
text (eDesc (Proxy :: Proxy TooManyRedirs))
instance HFErrorProject TooManyRedirs where
eBase _ = 260
eDesc _ = "Too many redirections."
-- | A patch could not be applied.
data PatchFailed = PatchFailed
@@ -273,7 +523,11 @@ data PatchFailed = PatchFailed
instance Pretty PatchFailed where
pPrint PatchFailed =
text "A patch could not be applied."
text (eDesc (Proxy :: Proxy PatchFailed))
instance HFErrorProject PatchFailed where
eBase _ = 270
eDesc _ = "A patch could not be applied."
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
@@ -281,7 +535,11 @@ data NoToolRequirements = NoToolRequirements
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text "The Tool requirements could not be found."
text (eDesc (Proxy :: Proxy NoToolRequirements))
instance HFErrorProject NoToolRequirements where
eBase _ = 280
eDesc _ = "The Tool requirements could not be found."
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
@@ -290,6 +548,10 @@ instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text "The build config is invalid. Reason was:" <+> pPrint reason
instance HFErrorProject InvalidBuildConfig where
eBase _ = 290
eDesc _ = "The build config is invalid."
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
@@ -297,19 +559,31 @@ instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text "No version is set for tool" <+> pPrint tool <+> text "."
instance HFErrorProject NoToolVersionSet where
eBase _ = 300
eDesc _ = "No version is set for tool (but was expected)."
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text "A download was required or requested, but '--offline' was specified."
text (eDesc (Proxy :: Proxy NoNetwork))
instance HFErrorProject NoNetwork where
eBase _ = 310
eDesc _ = "A download was required or requested, but '--offline' was specified."
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
text (eDesc (Proxy :: Proxy HadrianNotFound))
instance HFErrorProject HadrianNotFound where
eBase _ = 320
eDesc _ = "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
data ToolShadowed = ToolShadowed
Tool
@@ -332,12 +606,43 @@ instance Pretty ToolShadowed where
<> " in PATH."
)
instance HFErrorProject ToolShadowed where
eBase _ = 330
eDesc _ = "A tool is shadowed in PATH."
-- | File content length verification failed.
data ContentLengthError = ContentLengthError (Maybe FilePath) (Maybe Integer) Integer
deriving Show
instance Pretty ContentLengthError where
pPrint (ContentLengthError Nothing Nothing expectedSize) =
text "Content length exceeded expected size:"
<+> text (show expectedSize)
<+> text "\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError Nothing (Just currentSize) expectedSize) =
text "Content length error. Expected"
<+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
"\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError (Just fp) (Just currentSize) expectedSize) =
text "Content length error for" <+> text (fp <> ": expected")
<+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
"\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError (Just fp) Nothing expectedSize) =
text "Content length error for" <+> text (fp <> ": expected")
<+> text (show expectedSize) <+> text "\nConsider removing the file in case it's cached and try again."
instance Exception ContentLengthError
instance HFErrorProject ContentLengthError where
eBase _ = 340
eDesc _ = "File content length verification failed"
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
data DownloadFailed = forall xs . (HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
@@ -347,7 +652,12 @@ instance Pretty DownloadFailed where
deriving instance Show DownloadFailed
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
instance HFErrorProject DownloadFailed where
eBase _ = 5000
eNum (DownloadFailed xs) = 5000 + eNum xs
eDesc _ = "A download failed."
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1), Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) => InstallSetError (V xs1) (V xs2)
instance Pretty InstallSetError where
pPrint (InstallSetError reason1 reason2) =
@@ -358,9 +668,15 @@ instance Pretty InstallSetError where
deriving instance Show InstallSetError
instance HFErrorProject InstallSetError where
eBase _ = 7000
-- will there be collisions?
eNum (InstallSetError xs1 xs2) = 7000 + eNum xs1 + eNum xs2
eDesc _ = "Installation or setting the tool failed."
-- | A build failed.
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es), HFErrorProject (V es)) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
@@ -370,18 +686,28 @@ instance Pretty BuildFailed where
deriving instance Show BuildFailed
instance HFErrorProject BuildFailed where
eBase _ = 8000
eNum (BuildFailed _ xs2) = 8000 + eNum xs2
eDesc _ = "The build failed."
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
case reason of
VMaybe (_ :: GHCupSetError) -> pPrint reason
_ -> text "Setting the current GHC version failed:" <+> pPrint reason
_ -> text "Setting the current version failed:" <+> pPrint reason
deriving instance Show GHCupSetError
instance HFErrorProject GHCupSetError where
eBase _ = 9000
eNum (GHCupSetError xs) = 9000 + eNum xs
eDesc _ = "Setting the current version failed."
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
@@ -398,6 +724,10 @@ instance Pretty ParseError where
instance Exception ParseError
instance HFErrorProject ParseError where
eBase _ = 500
eDesc _ = "A parse error occured."
data UnexpectedListLength = UnexpectedListLength String
deriving Show
@@ -408,6 +738,10 @@ instance Pretty UnexpectedListLength where
instance Exception UnexpectedListLength
instance HFErrorProject UnexpectedListLength where
eBase _ = 510
eDesc _ = "A list had an unexpected length."
data NoUrlBase = NoUrlBase Text
deriving Show
@@ -417,6 +751,10 @@ instance Pretty NoUrlBase where
instance Exception NoUrlBase
instance HFErrorProject NoUrlBase where
eBase _ = 520
eDesc _ = "URL does not have a base filename."
------------------------
@@ -436,6 +774,23 @@ instance
Right x -> pPrint x
Left xs -> pPrint xs
instance HFErrorProject (V '[]) where
{-# INLINABLE eBase #-}
eBase _ = undefined
{-# INLINABLE eDesc #-}
eDesc _ = undefined
instance
( HFErrorProject x
, HFErrorProject (V xs)
) => HFErrorProject (V (x ': xs))
where
eNum v = case popVariantHead v of
Right x -> eNum x
Left xs -> eNum xs
eDesc _ = undefined
eBase _ = undefined
instance Pretty URIParseError where
pPrint (MalformedScheme reason) =
text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
@@ -454,6 +809,22 @@ instance Pretty URIParseError where
pPrint (OtherError err) =
text "Failed to parse URI:" <+> pPrint err
instance HFErrorProject URIParseError where
eBase _ = 800
eNum (MalformedScheme NonAlphaLeading) = 801
eNum (MalformedScheme InvalidChars) = 802
eNum (MalformedScheme MissingColon) = 803
eNum MalformedUserInfo = 804
eNum MalformedQuery = 805
eNum MalformedFragment = 806
eNum MalformedHost = 807
eNum MalformedPort = 808
eNum MalformedPath = 809
eNum (OtherError _) = 810
eDesc _ = "Failed to parse URI."
instance Pretty ArchiveResult where
pPrint ArchiveFatal = text "Archive result: fatal"
pPrint ArchiveFailed = text "Archive result: failed"
@@ -462,5 +833,37 @@ instance Pretty ArchiveResult where
pPrint ArchiveOk = text "Archive result: Ok"
pPrint ArchiveEOF = text "Archive result: EOF"
instance HFErrorProject ArchiveResult where
eBase _ = 820
eNum ArchiveFatal = 821
eNum ArchiveFailed = 822
eNum ArchiveWarn = 823
eNum ArchiveRetry = 824
eNum ArchiveOk = 825
eNum ArchiveEOF = 826
eDesc _ = "Archive extraction result."
instance Pretty T.Text where
pPrint = text . T.unpack
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
instance HFErrorProject ProcessError where
eBase _ = 840
eNum NonZeroExit{} = 841
eNum (PTerminated _ _) = 842
eNum (PStopped _ _) = 843
eNum (NoSuchPid _ _) = 844
eDesc _ = "A process exited prematurely."

View File

@@ -109,6 +109,7 @@ fetchGHCSrc :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -152,6 +153,7 @@ installGHCBindist :: ( MonadFail m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -357,6 +359,7 @@ installGHCBin :: ( MonadFail m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -456,7 +459,7 @@ setGHC ver sghc mBinDir = do
when (targetFile == "ghc") $
liftIO (isShadowed fullF) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHC pa fullF (_tvVersion ver))
when (isNothing mBinDir) $ do
-- create symlink for share dir
@@ -628,6 +631,7 @@ compileGHC :: ( MonadMask m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
@@ -676,7 +680,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(view dlSubdir dlInfo)
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
pure (workdir, tmpUnpack, tver)
pure (workdir, tmpUnpack, Just tver)
RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
@@ -684,7 +688,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
-- download source tarball
tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
tar <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
(bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do
liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*boot$|] :: B.ByteString
@@ -694,18 +698,19 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
execBlank
regex
)
tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile))
tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer
(appendGHCupPath tmpUnpack (takeDirectory bootFile))
pure (bootFile, tver)
let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, mkTVer tver)
pure (workdir, tmpUnpack, mkTVer <$> tver)
-- clone from git
GitDist GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ]
@@ -715,7 +720,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, fromString rep ]
-- figure out if we can do a shallow clone
remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
$ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
let shallow_clone
| isCommitHash ref = True
@@ -745,20 +750,23 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
-- bootstrap
tver <- liftE $ getGHCVer tmpUnpack
tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer
tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
"GHC version (from Makefile): " <> prettyVer tver <>
"GHC version (from Makefile): " <> T.pack (show (prettyVer <$> tver)) <>
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
pure tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
pure (tmpUnpack, tmpUnpack, mkTVer <$> tver)
-- the version that's installed may differ from the
-- compiled version, so the user can overwrite it
let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov
installVer <- if | Just ov' <- ov -> pure (mkTVer ov')
| Just tver' <- tver -> pure tver'
| otherwise -> fail "Newer GHCs don't support discovering the version in git. Complain to GHC devs: https://gitlab.haskell.org/ghc/ghc/-/issues/22322"
alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)
@@ -781,8 +789,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
tmpUnpack
(do
b <- if hadrian
then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir
else compileMakeBindist tver (fromGHCupPath workdir) ghcdir
-- prefer 'tver', because the real version carries out compatibility checks
-- we don't want the user to do funny things with it
then compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
else compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
pure (b, bmk)
)
@@ -826,14 +836,14 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, MonadThrow m
)
=> GHCupPath
-> Excepts '[ProcessError] m Version
-> Excepts '[ProcessError, ParseError] m Version
getGHCVer tmpUnpack = do
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
ExitSuccess -> either (throwE . ParseError . show) pure . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
defaultConf =

View File

@@ -68,7 +68,6 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import Text.PrettyPrint.HughesPJClass (prettyShow)
data HLSVer = SourceDist Version
@@ -105,6 +104,7 @@ installHLSBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -297,6 +297,7 @@ installHLSBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -344,6 +345,7 @@ compileHLS :: ( MonadMask m
, GPGError
, DownloadFailed
, DigestError
, ContentLengthError
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
@@ -401,7 +403,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball
tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
tar <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
(cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
@@ -481,7 +483,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
liftE $ runBuildAction
tmpUnpack
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, ContentLengthError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
let tmpInstallDir = fromGHCupPath workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
@@ -497,7 +499,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
| otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack' <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
cp <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project"
Nothing
@@ -511,7 +513,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
| otherwise -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do
tmpUnpack' <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
cpl <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
@@ -631,7 +633,7 @@ setHLS ver shls mBinDir = do
liftIO (isShadowed wrapper) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed HLS pa wrapper ver)
unsetHLS :: ( MonadMask m

View File

@@ -41,24 +41,26 @@ import GHCup.Prelude.Posix
import Control.Monad.IO.Class
import Control.Monad.Reader
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import Text.PrettyPrint.HughesPJClass ( Pretty )
import qualified Data.Text as T
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m env . ( Pretty (V es)
, HFErrorProject (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyHFError $ v))
runBothE' :: forall e m a b .
( Monad m
, Show (V e)
, Pretty (V e)
, HFErrorProject (V e)
, PopVariant InstallSetError e
, LiftVariant' e (InstallSetError ': e)
, e :<< (InstallSetError ': e)

View File

@@ -48,6 +48,7 @@ import Streamly.Internal.Data.Unfold.Type
import qualified Streamly.Internal.Data.Unfold as U
import Streamly.Internal.Control.Concurrent ( withRunInIO )
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
import GHC.IO.Exception (IOException(ioe_type), IOErrorType (..))
-- | On unix, we can use symlinks, so we just get the
@@ -116,8 +117,18 @@ copyFile from to fail' = do
let dflags = [ FD.oNofollow
, if fail' then FD.oExcl else FD.oTrunc
]
let openFdHandle' = openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode
bracket
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
(handleIO (\e -> if
-- if we copy from regular file to symlink, we need
-- to delete the symlink
| ioe_type e == InvalidArgument
, not fail' -> do
removeLink to
openFdHandle'
| otherwise -> throwIO e
)
openFdHandle')
(hClose . snd)
$ \(_, tH) -> do
hSetBinaryMode fH True

View File

@@ -50,7 +50,6 @@ import System.FilePath
import System.IO.Error
import qualified Data.Text as T
import Text.PrettyPrint.HughesPJClass (prettyShow)
@@ -82,6 +81,7 @@ installStackBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -120,6 +120,7 @@ installStackBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
@@ -232,7 +233,7 @@ setStack ver = do
liftIO (isShadowed stackbin) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver)
pure ()

View File

@@ -35,7 +35,7 @@ import Data.Text ( Text )
import Data.Versions
import GHC.IO.Exception ( ExitCode )
import Optics ( makeLenses )
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
@@ -262,6 +262,7 @@ data DownloadInfo = DownloadInfo
{ _dlUri :: URI
, _dlSubdir :: Maybe TarDir
, _dlHash :: Text
, _dlCSize :: Maybe Integer
}
deriving (Eq, Ord, GHC.Generic, Show)
@@ -297,10 +298,16 @@ instance NFData URLSource
instance NFData (URIRef Absolute) where
rnf (URI !_ !_ !_ !_ !_) = ()
data MetaMode = Strict
| Lax
deriving (Show, Read, Eq, GHC.Generic)
instance NFData MetaMode
data UserSettings = UserSettings
{ uCache :: Maybe Bool
, uMetaCache :: Maybe Integer
, uMetaMode :: Maybe MetaMode
, uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs
@@ -314,13 +321,14 @@ data UserSettings = UserSettings
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
UserSettings {
uCache = Just cache
, uMetaCache = Just metaCache
, uMetaMode = Just metaMode
, uNoVerify = Just noVerify
, uVerbose = Just verbose
, uKeepDirs = Just keepDirs
@@ -346,6 +354,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
in UserSettings {
uCache = Just cache
, uMetaCache = Just metaCache
, uMetaMode = Just metaMode
, uNoVerify = Just noVerify
, uVerbose = Just verbose
, uKeepDirs = Just keepDirs
@@ -426,6 +435,7 @@ instance NFData LeanAppState
data Settings = Settings
{ cache :: Bool
, metaCache :: Integer
, metaMode :: MetaMode
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
@@ -442,7 +452,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False Nothing
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing
instance NFData Settings
@@ -622,15 +632,7 @@ data ProcessError = NonZeroExit Int FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
pPrint (PTerminated exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
pPrint (PStopped exe args) =
text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
pPrint (NoSuchPid exe args) =
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString

View File

@@ -43,6 +43,7 @@ import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MetaMode
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep

View File

@@ -1035,13 +1035,13 @@ applyAnyPatch :: ( MonadReader env m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
-> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
patch <- liftE $ download uri Nothing Nothing Nothing tmpUnpack Nothing False
liftE $ applyPatch patch workdir
@@ -1172,7 +1172,7 @@ ensureGlobalTools :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
=> Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools
| isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
@@ -1184,8 +1184,8 @@ ensureGlobalTools
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
| otherwise = pure ()
@@ -1270,11 +1270,13 @@ warnAboutHlsCompatibility = do
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)
"GHC-" <> T.pack (prettyShow gv) <> " appears to have no corresponding HLS-" <> T.pack (prettyShow hv) <> " binary." <> "\n" <>
"Haskell IDE support may not work." <> "\n" <>
"You can try to either: " <> "\n" <>
" 1. Install a different HLS version (e.g. downgrade for older GHCs)" <> "\n" <>
" 2. Install and set one of the following GHCs: " <> T.pack (prettyShow supportedGHC) <> "\n" <>
" 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " <> T.pack (prettyShow hv) <> " --ghc " <> T.pack (prettyShow gv) <> " --cabal-update\n" <>
" (see https://www.haskell.org/ghcup/guide/#hls for more information)"
_ -> return ()
@@ -1299,7 +1301,7 @@ gitOut args dir = do
ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
ExitFailure c -> do
let pe = NonZeroExit c "git" args
lift $ logDebug $ T.pack (prettyShow pe)
lift $ logDebug $ T.pack (prettyHFError pe)
throwE pe
processBranches :: T.Text -> [String]

View File

@@ -465,15 +465,22 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadMask m
, MonadIO m)
=> m GHCupPath
withGHCupTmpDir = snd <$> withRunInIO (\run ->
run
$ allocate
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
. removePathForcibly
$ fp))
withGHCupTmpDir = do
Settings{keepDirs} <- getSettings
snd <$> withRunInIO (\run ->
run
$ allocate
(run mkGhcupTmpDir)
(\fp -> if -- we don't know whether there was a failure, so can only
-- decide for 'Always'
| keepDirs == Always -> pure ()
| otherwise -> handleIO (\e -> run
$ logDebug ("Resource cleanup failed for "
<> T.pack (fromGHCupPath fp)
<> ", error was: "
<> T.pack (displayException e)))
. removePathForcibly
$ fp))

View File

@@ -38,9 +38,13 @@ param (
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir,
# Whether to disable use of curl.exe
[switch]$DisableCurl
[switch]$DisableCurl,
# The Msys2 version to download (e.g. 20221216)
[string]$Msys2Version
)
$DefaultMsys2Version = "20221216"
$Silent = !$Interactive
function Print-Msg {
@@ -423,12 +427,15 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Start-Sleep -s 5
# Download the archive
Print-Msg -msg 'Downloading Msys2 archive...'
$archive = 'msys2-x86_64-latest.sfx.exe'
if (!($Msys2Version)) {
$Msys2Version = $DefaultMsys2Version
}
Print-Msg -msg ('Downloading Msys2 archive {0}...' -f $Msys2Version)
$archive = ('msys2-base-x86_64-{0}.sfx.exe' -f $Msys2Version)
$archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive")
if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) {
Exec "curl.exe" '-o' "$archivePath" ('https://repo.msys2.org/distrib/{0}' -f "$archive")
Exec "curl.exe" '-o' "$archivePath" ('https://repo.msys2.org/distrib/x86_64/{0}' -f "$archive")
} else {
Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder ([IO.Path]::GetTempPath()) -includeStats
}
@@ -603,7 +610,7 @@ if ($DisableCurl) {
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript)
Exec "$Msys2Shell" '-mingw64' '-mintty' '-shell' 'bash' '-c' ('{4} {6} {7} {8} {9} {10} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && {11} {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport, $BootstrapDownloader, $DownloadScript)
}

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff