Compare commits

..

1 Commits

Author SHA1 Message Date
939ebdee0e Update travis 2020-06-14 12:36:13 +02:00
47 changed files with 5400 additions and 3541 deletions

11
.gitignore vendored
View File

@@ -1,15 +1,4 @@
.ghci
.vim
codex.tags
dist-newstyle/
cabal.project.local
.stack-work/
bin/
/*.prof
/*.ps
/*.hp
tags
TAGS
/tmp/
.entangled
release/

View File

@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
############################################################
# CI Step
@@ -14,7 +14,6 @@ variables:
- x86_64-linux
variables:
OS: "LINUX"
BIT: "64"
.alpine:64bit:
image: "alpine:edge"
@@ -37,14 +36,12 @@ variables:
- x86_64-darwin
variables:
OS: "DARWIN"
BIT: "64"
.freebsd:
tags:
- x86_64-freebsd
variables:
OS: "FREEBSD"
BIT: "64"
.root_cleanup:
after_script:
@@ -69,13 +66,6 @@ variables:
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
.test_ghcup_version:linux32:
extends:
- .test_ghcup_version
- .alpine:32bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
.test_ghcup_version:darwin:
extends:
- .test_ghcup_version
@@ -107,36 +97,29 @@ variables:
test:linux:recommended:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.8.4"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:linux:latest:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.2"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
######## linux 32bit test ########
test:linux:recommended:32bit:
extends: .test_ghcup_version:linux32
variables:
GHC_VERSION: "8.8.4"
CABAL_VERSION: "3.2.0.0"
######## darwin test ########
test:mac:recommended:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.8.4"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:mac:latest:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.10.2"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -146,13 +129,13 @@ test:mac:latest:
test:freebsd:recommended:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.8.4"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:freebsd:latest:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.2"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -167,7 +150,7 @@ release:linux:64bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.8.4"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
@@ -179,7 +162,7 @@ release:linux:32bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
variables:
ARTIFACT: "i386-linux-ghcup"
GHC_VERSION: "8.8.4"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
@@ -211,5 +194,4 @@ release:freebsd:
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"

View File

@@ -12,7 +12,7 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
chmod +x ghcup-bin
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
exit 0

View File

@@ -18,14 +18,29 @@ apk add --no-cache \
tar \
perl
ln -s libncurses.so /usr/lib/libtinfo.so
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
if [ "${BIT}" = "32" ] ; then
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
else
curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
fi
chmod +x ghcup-bin
./ghcup-bin upgrade
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION}
# install cabal-3.2.0.0
if [ "${BIT}" = "32" ] ; then
curl -sSfL -o cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-i386-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
else
curl -sSfL -o cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-x86_64-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
fi
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
# utils
apk add --no-cache \
@@ -42,6 +57,7 @@ apk add --no-cache \
openssl-dev \
openssl-libs-static \
xz \
xz-dev \
ncurses-static
xz-dev

View File

@@ -16,24 +16,16 @@ git describe
ecabal update
if [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
fi
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
fi
mkdir out
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version)
if [ "${OS}" = "DARWIN" ] ; then
strip ./ghcup
else
strip -s ./ghcup
fi
strip -s ./ghcup
cp ghcup out/${ARTIFACT}-${ver}

View File

@@ -11,7 +11,7 @@ ecabal() {
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
}
git describe --always
@@ -21,21 +21,13 @@ git describe --always
ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal build -w ghc-${GHC_VERSION}
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
@@ -48,10 +40,16 @@ rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
ghcup-gen check -f ghcup-${JSON_VERSION}.json
eghcup --numeric-version
# TODO: rm once we have tarballs
if [ "${OS}" = "FREEBSD" ] ; then
GHC_VERSION=8.6.3
CABAL_VERSION=2.4.1.0
fi
eghcup install ${GHC_VERSION}
eghcup set ${GHC_VERSION}
eghcup install-cabal ${CABAL_VERSION}

View File

@@ -1,10 +1,5 @@
jobs:
include:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
- os: osx
osx_image: xcode10.1
language: generic
@@ -15,13 +10,6 @@ jobs:
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
allow_failures:
- os: osx
osx_image: xcode8
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.11-ghcup
script: ".travis/build.sh"
deploy:

View File

@@ -18,7 +18,7 @@ ghcup set 8.8.3
## install ghcup
cabal update
cabal build --constraint="zlib static" --constraint="lzma static" -ftui
cabal build --constraint="zlib static" --constraint="lzma static"
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
strip ./ghcup
strip -s ghcup
cp ghcup "./${ARTIFACT}"

View File

@@ -86,7 +86,7 @@ test-suite lzma-tests
-- additional dependencies that require version bounds
build-depends: HUnit >= 1.2 && <1.7
, QuickCheck >= 2.8 && <2.14
, tasty >= 0.10 && <1.4
, tasty >= 0.10 && <1.3
, tasty-hunit >= 0.9 && <0.11
, tasty-quickcheck >= 0.8.3.2 && <0.11

View File

@@ -110,7 +110,7 @@ test-suite tests
default-language: Haskell2010
build-depends: base, bytestring, zlib,
QuickCheck == 2.*,
tasty >= 0.8 && < 1.4,
tasty >= 0.8 && < 1.3,
tasty-quickcheck >= 0.8 && < 0.11,
tasty-hunit >= 0.8 && < 0.11
ghc-options: -Wall

View File

@@ -1,47 +1,5 @@
# Revision history for ghcup
## 0.1.10 -- 2020-08-14
* Show stray Cabals (useful for pre-releases or compiled ones)
## 0.1.9 -- 2020-08-14
* Fix bug when uninstalling all cabal versions
* Fix bug when setting a non-installed ghc version as current default
* Use yaml instead of generated json for download info for ease of adding new GHC versions #44
* Allow pre-release versions of GHC/cabal
* Add XDG dirs support (set `GHCUP_USE_XDG_DIRS`) wrt #39
* Allow to specify regex for tarball subdir (e.g. `ghc-.*`)
* Allow installing arbitrary bindists more seamlessly:
- e.g. installing GHC HEAD: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head`
* Avoid duplicate edits to .bashrc/.zshrc wrt #43
## 0.1.8 -- 2020-07-21
* Fix bug in logging thread dying on newlines
* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
## 0.1.7 -- 2020-07-20
* Fix a bug in libarchive not unpacking some uncleanly packed bindists
* Improved fish support in bootstrap-haskell
* Only check for upgrades when not upgrading
* Fix platform detection for i386 docker images
* Improve alpine support
- more/proper bindists
- don't fall back to glibc based bindists
- install bindists with `--disable-ld-override` to avoid ld.gold bugs
## 0.1.6 -- 2020-07-13
* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
* Support multiple installed versions of cabal #23
* Improvements to `ghcup list` (show unavailable bindists for platform)
* Fix redhat downloads #29
* Support for hadrian bindists (fixes alpine-8.10.1) #31
* Add FreeBSD bindists 8.6.5 and 8.8.3
* Fix memory leak during unpack
## 0.1.5 -- 2020-04-30
* Fix errors when PATH variable contains path components that are actually files

View File

@@ -13,7 +13,6 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Design goals](#design-goals)
* [How](#how)
* [Known users](#known-users)
@@ -41,13 +40,7 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See `ghcup --help`.
For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
Common use cases are:
```sh
# list available ghc/cabal versions
@@ -97,16 +90,6 @@ For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information.
### XDG support
To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
Then you can control the locations via XDG environment variables as such:
* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
## Design goals
1. simplicity

View File

@@ -1,19 +1,19 @@
# RELEASING
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the YAML representation of it. The version of the YAML represents the change increments. `ghcUpVer` is the current application version.
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the JSON representation of it. The version of the json represents the change increments. `ghcUpVer` is the current application version.
2. Update version in ghcup.cabal
3. Add ChangeLog entry
4. Add/fix downloads in `ghcup-<ver>.yaml`, then verify with `ghcup-gen check -f ghcup-<ver>.yaml`
4. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
6. Download release artifacts and upload them `downloads.haskell.org/ghcup`
7. Add release artifacts to yaml file (see point 4.)
7. Add release artifacts to GHCupDownloads (see point 4.)
8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
8. Upload the final `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`

View File

@@ -10,10 +10,13 @@
module Main where
import GHCup.Data.GHCupInfo
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Data.Aeson ( eitherDecode, encode )
import Data.Aeson.Encode.Pretty
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
@@ -24,15 +27,48 @@ import System.IO ( stdout )
import Validate
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
import qualified Data.ByteString.Lazy as L
data Options = Options
{ optCommand :: Command
}
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts
data Command = GenJSON GenJSONOpts
| ValidateJSON ValidateJSONOpts
| ValidateTarballs ValidateJSONOpts
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdOutput
fileOutput :: Parser Output
fileOutput =
FileOutput
<$> (strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Output to a file"
)
)
stdOutput :: Parser Output
stdOutput = flag'
StdOutput
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
outputP :: Parser Output
outputP = fileOutput <|> stdOutput
data GenJSONOpts = GenJSONOpts
{ output :: Maybe Output
, pretty :: Bool
}
genJSONOpts :: Parser GenJSONOpts
genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
(short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
)
data Input
@@ -56,12 +92,12 @@ stdInput = flag'
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateYAMLOpts = ValidateYAMLOpts
{ vInput :: Maybe Input
data ValidateJSONOpts = ValidateJSONOpts
{ input :: Maybe Input
}
validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
validateJSONOpts :: Parser ValidateJSONOpts
validateJSONOpts = ValidateJSONOpts <$> optional inputP
opts :: Parser Options
opts = Options <$> com
@@ -69,10 +105,18 @@ opts = Options <$> com
com :: Parser Command
com = subparser
( (command
"gen"
( GenJSON
<$> (info (genJSONOpts <**> helper)
(progDesc "Generate the json downloads file")
)
)
)
<> (command
"check"
( ValidateYAML
<$> (info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
( ValidateJSON
<$> (info (validateJSONOpts <**> helper)
(progDesc "Validate the JSON")
)
)
)
@@ -80,7 +124,7 @@ com = subparser
"check-tarballs"
( ValidateTarballs
<$> (info
(validateYAMLOpts <**> helper)
(validateJSONOpts <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
@@ -91,27 +135,38 @@ com = subparser
main :: IO ()
main = do
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate
GenJSON gopts -> do
let bs True =
encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
bs False = encode ghcupInfo
case gopts of
GenJSONOpts { output = Nothing, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just StdOutput, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just (FileOutput file), pretty } ->
L.writeFile file (bs pretty)
ValidateJSON vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validate
ValidateTarballs vopts -> case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validateTarballs
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validateTarballs
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validateTarballs
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validateTarballs
pure ()
where
valAndExit f contents = do
(GHCupInfo _ av) <- case Y.decodeEither' contents of
(GHCupInfo _ av) <- case eitherDecode contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)

View File

@@ -7,10 +7,7 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Control.Exception.Safe
import Control.Monad
@@ -91,15 +88,6 @@ validate dls = do
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (not $ any (== Linux Alpine) pspecs) $
case t of
GHCup -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
Cabal | v > [vver|2.4.1.0|] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool
let nonUnique =
@@ -123,7 +111,6 @@ validate dls = do
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
@@ -192,8 +179,7 @@ validateTarballs dls = do
where
downloadAll dli = do
dirs <- liftIO getDirs
let settings = Settings True False Never Curl False dirs defExecCb
let settings = Settings True False Never Curl
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

View File

@@ -1,433 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Brick
import Brick.BChan
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.ByteString ( ByteString )
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO hiding ( hideError )
import Prelude hiding ( abs, appendFile, writeFile )
import System.Exit
import System.IO.Unsafe
import System.Posix.Types
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data SubProcess = SubProcess {
procName :: String
, exited :: Maybe (Either ProcessError ())
, procId :: Maybe ProcessID
, logLine :: Maybe ByteString
}
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
, mproc :: Maybe SubProcess
}
data MyAppEvent = LogLine ByteString
| StartProc String
| GotProcId ProcessID
| EndProc (Either ProcessError ())
type LR = GenericList String Vector ListResult
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
keyHandlers =
[ ('q', "Quit" , halt)
, ('i', "Install" , withIOAction install')
, ('u', "Uninstall", withIOAction del')
, ('s', "Set" , withIOAction set')
, ('c', "ChangeLog", withIOAction changelog')
]
ui :: AppState -> Widget String
ui AppState {..} =
case mproc of
Just _ -> logDialog
Nothing ->
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
where
logDialog = case mproc of
Nothing -> emptyWidget
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ ""
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
| otherwise -> (withAttr "not-installed" $ str "")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
in dim
( marks
<+> ( padLeft (Pad 2)
$ minHSize 20
$ ((if b then withAttr "active" else id)
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
)
)
<+> (padLeft (Pad 1) $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
)
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState MyAppEvent String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const defaultAttributes
, appChooseCursor = neverShowCursor
}
defaultAttributes :: AttrMap
defaultAttributes = attrMap
Vty.defAttr
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
dimAttributes :: AttrMap
dimAttributes = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls pfreq mproc)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls pfreq mproc)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st (AppEvent (StartProc str')) = continue st
{ mproc = Just SubProcess { procName = str'
, exited = Nothing
, procId = Nothing
, logLine = Nothing
}
}
eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) =
continue st { mproc = Just sp { procId = Just pid } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) =
continue st { mproc = Just sp { exited = Just exited, procId = Nothing } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) =
continue st { mproc = Just sp { logLine = Just bs } }
eventHandler st (AppEvent _) = error "noes" -- TODO
eventHandler st _ = continue st
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> AppState
-> EventM n (Next AppState)
withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as
Just (ix, e) -> do
liftIO $ forkIO $ void $ action as (ix, e)
continue as
-- apps <- (fmap . fmap)
-- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
-- $ getAppState Nothing (pfreq as)
-- case apps of
-- Right nas -> do
-- putStrLn "Press enter to continue"
-- _ <- getLine
-- pure nas
-- Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
install' AppState {..} (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate
, TarDirDoesNotExist
]
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}
Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState {..} (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
uri' :: IORef (Maybe URI)
{-# NOINLINE uri' #-}
uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getDirs
newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'")
, ..
}
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain _ muri _ av pfreq' = do
writeIORef uri' muri
s <- readIORef settings'
-- logger interpreter
-- writeIORef logger' l
l <- readIORef logger'
let runLogger = myLoggerT l
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> do
eventChan <- newBChan 1000
let builder = Vty.mkVty Vty.defaultConfig
initialVty <- builder
writeIORef settings' s{ execCb = brickExecCb eventChan }
customMain initialVty builder (Just eventChan) app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
where
selectLatest :: AppState -> AppState
selectLatest AppState {..} =
(\ix -> AppState { lr = listMoveTo ix lr, .. })
. fromJust
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
$ (listElements lr)
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]
brickExecCb :: BChan MyAppEvent -> ExecCb
brickExecCb chan _ fileFd stdoutRead pState lfile = do
liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb"
writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile)
readLineTilEOF lineAction stdoutRead
takeMVar pState >>= \case
PExited e@(Left _) -> writeBChan chan (EndProc e)
_ -> error "no"
where
lineAction bs = do
void $ SPIB.fdWrite fileFd (bs <> "\n")
error "blah"
writeBChan chan (LogLine bs)

View File

@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -11,10 +10,6 @@
module Main where
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
import GHCup
import GHCup.Download
import GHCup.Errors
@@ -26,12 +21,8 @@ import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
@@ -39,7 +30,6 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( eitherDecode )
import Data.Bifunctor
import Data.Char
import Data.Either
@@ -70,7 +60,6 @@ import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as BLU
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
@@ -104,9 +93,6 @@ data Command
| Upgrade UpgradeOpts Bool
| ToolRequirements
| ChangeLog ChangeLogOptions
#if defined(BRICK)
| Interactive
#endif
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag
@@ -122,7 +108,6 @@ data InstallCommand = InstallGHC InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe DownloadInfo
}
data SetCommand = SetGHC SetOptions
@@ -236,20 +221,7 @@ opts =
com :: Parser Command
com =
subparser
#if defined(BRICK)
( command
"tui"
( (\_ -> Interactive)
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else
( command
#endif
"install"
( Install
<$> (info
@@ -340,32 +312,32 @@ com =
)
where
installToolFooter :: String
installToolFooter = [s|Discussion:
installToolFooter = [i|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
setFooter :: String
setFooter = [s|Discussion:
setFooter = [i|Discussion:
Sets the currently active GHC or cabal version. When no command is given,
defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
rmFooter :: String
rmFooter = [s|Discussion:
rmFooter = [i|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
changeLogFooter :: String
changeLogFooter = [s|Discussion:
changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
installCabalFooter :: String
installCabalFooter = [s|Discussion:
installCabalFooter = [i|Discussion:
Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by
@@ -401,19 +373,15 @@ installParser =
<|> (Right <$> installOpts)
where
installGHCFooter :: String
installGHCFooter = [s|Discussion:
installGHCFooter = [i|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install GHC head
ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head|]
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
installOpts :: Parser InstallOptions
installOpts =
(\p u v -> InstallOptions v p u)
(flip InstallOptions)
<$> (optional
(option
(eitherReader platformParser)
@@ -425,17 +393,6 @@ installOpts =
)
)
)
<*> (optional
(option
(eitherReader bindistParser)
( short 'u'
<> long "url"
<> metavar "BINDIST_URL"
<> help
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
)
)
)
<*> optional toolVersionArgument
@@ -467,13 +424,13 @@ setParser =
<|> (Right <$> setOpts)
where
setGHCFooter :: String
setGHCFooter = [s|Discussion:
setGHCFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
setCabalFooter :: String
setCabalFooter = [s|Discussion:
setCabalFooter = [i|Discussion:
Sets the the current Cabal version.|]
@@ -573,7 +530,7 @@ compileP = subparser
)
)
where
compileFooter = [s|Discussion:
compileFooter = [i|Discussion:
Compiles and installs the specified GHC version into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
@@ -819,19 +776,15 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
pure v
bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString
toSettings :: Options -> IO Settings
toSettings Options {..} = do
toSettings :: Options -> Settings
toSettings Options {..} =
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
dirs <- getDirs
pure $ Settings { execCb = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..}
in Settings { .. }
upgradeOptsP :: Parser UpgradeOpts
@@ -890,7 +843,7 @@ main = do
<> internal
)
let main_footer = [s|Discussion:
let main_footer = [i|Discussion:
ghcup installs the Glasgow Haskell Compiler from the official
release channels, enabling you to easily switch between different
versions. It maintains a self-contained ~/.ghcup directory.
@@ -907,19 +860,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
let settings@Settings{..} = toSettings opt
-- create ~/.ghcup dir
createDirRecursive newDirPerms baseDir
ghcdir <- ghcupBaseDir
createDirIfMissing newDirPerms ghcdir
-- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig
logfile <- initGHCupFileLogging [rel|ghcup.log|]
let runLogger = myLoggerT LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
let runLogger = myLoggerT loggerConfig
-------------------------
@@ -933,18 +886,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE
@'[ AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
, DistroNotFound
, FileDoesNotExistError
, CopyError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, TarDirDoesNotExist
]
let
@@ -955,20 +907,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, TagNotFound
]
let
runSetCabal =
runLogger
. flip runReaderT settings
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runLogger . flip runReaderT settings
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runRm =
let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
@@ -985,16 +937,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
let runCompileCabal =
@@ -1006,15 +957,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
let runUpgrade =
@@ -1023,6 +973,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, NoUpdate
, FileDoesNotExistError
@@ -1031,19 +984,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) [i|Error determining Platform: #{e}|])
exitWith (ExitFailure 2)
---------------------------
-- Getting download info --
---------------------------
(GHCupInfo treq dls) <-
( runLogger
@@ -1058,11 +1001,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger
($(logError) [i|Error fetching download info: #{e}|])
exitWith (ExitFailure 2)
case optCommand of
Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq
(runLogger
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
)
>>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) [i|Error checking for upgrades: #{e}|])
-----------------------
@@ -1072,9 +1018,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
case instBindist of
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
@@ -1088,7 +1032,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
@@ -1101,16 +1045,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in #{logsDir}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
case instBindist of
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
@@ -1130,7 +1072,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in #{logsDir}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
@@ -1160,7 +1102,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRm $ do
(runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
@@ -1170,7 +1112,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 7
let rmCabal' tv =
(runRm $ do
(runSetCabal $ do
liftE $ rmCabalVer tv
)
>>= \case
@@ -1182,9 +1124,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of
#if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
installGHC iopts
@@ -1202,10 +1141,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List (ListOptions {..}) ->
(runListGHC $ do
l <- listVersions dls lTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
l <- listVersions dls lTool lCriteria
pure l
)
>>= \case
VRight r -> do
liftIO $ printListResult lRawFormat r
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6
Rm (Right rmopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
@@ -1232,7 +1177,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig
patchDir
addConfArgs
pfreq
)
>>= \case
VRight _ -> do
@@ -1246,9 +1190,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir}|])
Check the logs at ~/.ghcup/logs|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 9
VLeft e -> do
@@ -1257,7 +1201,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
)
>>= \case
VRight _ -> do
@@ -1270,7 +1214,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 10
VLeft e -> do
@@ -1284,9 +1228,11 @@ Make sure to clean up #{tmpdir} afterwards.|])
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
UpgradeGHCupDir -> do
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
runLogger $ $(logInfo)
@@ -1338,14 +1284,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure ExitSuccess
Just uri -> do
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
if clOpen
then
exec cmd
exec "xdg-open"
True
[serializeURIRef' uri]
Nothing
@@ -1429,41 +1370,45 @@ printListResult raw lr = do
where
printTag Recommended = color' Green "recommended"
printTag Latest = color' Yellow "latest"
printTag Prerelease = color' Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
color' = case raw of
True -> flip const
False -> color
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
()
checkForUpdates dls = do
forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ $(logWarn)
$ lift $ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do
mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn)
$ lift $ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn)
$ lift $ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
<$> (listVersions dls (Just tool) (Just ListInstalled))
prettyDebugInfo :: DebugInfo -> String
@@ -1480,13 +1425,6 @@ Version: #{describe_result}|]
prettyArch :: Architecture -> String
prettyArch A_64 = "amd64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "PowerPC"
prettyArch A_PowerPC64 = "PowerPC64"
prettyArch A_Sparc = "Sparc"
prettyArch A_Sparc64 = "Sparc64"
prettyArch A_ARM = "ARM"
prettyArch A_ARM64 = "ARM64"
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'

View File

@@ -4,17 +4,6 @@
(
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
export GHCUP_USE_XDG_DIRS
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
@@ -29,55 +18,26 @@ edo()
}
eghcup() {
edo _eghcup "$@"
}
_eghcup() {
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
ghcup "$@"
edo ghcup "$@"
else
ghcup --verbose "$@"
edo ghcup --verbose "$@"
fi
}
_done() {
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions, run:"
echo " ghcup tui"
exit 0
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.10"
_base_url="https://downloads.haskell.org/~ghcup"
_ghver="0.1.5"
case "${_plat}" in
"linux"|"Linux")
case "${_arch}" in
x86_64|amd64)
# we could be in a 32bit docker container, in which
# case uname doesn't give us what we want
if [ "$(getconf LONG_BIT)" = "32" ] ; then
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-linux-ghcup-${_ghver}
;;
i*86)
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
_url=https://downloads.haskell.org/~ghcup/${_ghver}/i386-linux-ghcup-${_ghver}
;;
*) die "Unknown architecture: ${_arch}"
;;
@@ -93,7 +53,7 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
;;
"Darwin"|"darwin")
case "${_arch}" in
@@ -105,23 +65,14 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
_url=https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2 ;;
*) die "Unknown platform: ${_plat}"
;;
esac
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
edo chmod +x "${GHCUP_BIN}"/ghcup
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_DIR}"/env
eghcup upgrade
unset _plat _arch _url _ghver _base_url
unset _plat _arch _url _ghver
}
@@ -129,19 +80,12 @@ echo
echo "Welcome to Haskell!"
echo
echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer"
echo " (for managing GHC/cabal versions)"
echo " * ghcup - The Haskell toolchain installer (for managing GHC/cabal versions)"
echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool"
echo
if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo "ghcup installs only into the following directory,"
echo "which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
else
echo "ghcup installs into XDG directories as long as"
echo "'GHCUP_USE_XDG_DIRS' is set."
fi
echo "ghcup installs only into the following directory, which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
@@ -153,14 +97,22 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
edo mkdir -p "${GHCUP_BIN}"
edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
if command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
_eghcup upgrade || download_ghcup
eghcup upgrade
fi
else
download_ghcup
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
eghcup upgrade
fi
echo
@@ -177,10 +129,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
eghcup set "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install-cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
edo cabal new-update
@@ -190,7 +142,7 @@ printf "\\033[0;35m%s\\033[0m\\n" ""
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_DIR/env' in your shell"
echo "You may want to source '$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
case $SHELL in
@@ -208,13 +160,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh"
else
_done
exit 0
fi
;;
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) _done ;;
*) exit 0 ;;
esac
@@ -229,27 +178,12 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
case $next_answer in
[Yy]*)
case $MY_SHELL in
"") break ;;
fish)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
*)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
esac
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
_done
;;
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
exit 0;;
[Nn]*)
_done ;;
exit 0;;
*)
echo "Please type YES or NO and press enter.";;
esac

View File

@@ -2,12 +2,6 @@ packages: ./ghcup.cabal
optional-packages: ./3rdparty/*/*.cabal
source-repository-package
type: git
location: https://github.com/haskus/packages.git
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types
optimization: 2
package streamly
@@ -16,9 +10,9 @@ package streamly
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package tar-bytestring
ghc-options: -O2
constraints: http-io-streams -brotli
package libarchive
flags: +static
allow-newer: base, ghc-prim, template-haskell
allow-newer: base

2299
ghcup-0.0.2.json Normal file

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.10
version: 0.1.5
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -21,21 +21,11 @@ source-repository head
type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui
description: Build the brick powered tui (ghcup tui)
default: False
manual: True
flag internal-downloader
description: Compile the internal downloader, which links against OpenSSL
default: False
manual: True
flag tar
description: Use tar-bytestring instead of libarchive
default: False
manual: True
common HsOpenSSL
build-depends: HsOpenSSL >=0.11.4.18
@@ -60,9 +50,6 @@ common base16-bytestring
common binary
build-depends: binary >=0.8.6.0
common brick
build-depends: brick >=0.54
common bytestring
build-depends: bytestring >=0.10
@@ -94,13 +81,13 @@ common hpath
build-depends: hpath >=0.11
common hpath-directory
build-depends: hpath-directory >=0.14
build-depends: hpath-directory >=0.13.3
common hpath-filepath
build-depends: hpath-filepath >=0.10.3
common hpath-io
build-depends: hpath-io >=0.14
build-depends: hpath-io >=0.13.1
common hpath-posix
build-depends: hpath-posix >=0.13.2
@@ -111,8 +98,8 @@ common http-io-streams
common io-streams
build-depends: io-streams >=1.5
common libarchive
build-depends: libarchive >= 2.2.5.0
common language-bash
build-depends: language-bash >=0.9
common lzma
build-depends: lzma >=0.0.0.3
@@ -153,9 +140,6 @@ common safe
common safe-exceptions
build-depends: safe-exceptions >=0.1
common split
build-depends: split >=0.2.3.4
common streamly
build-depends: streamly >=0.7.1
@@ -174,17 +158,17 @@ common string-interpolate
common table-layout
build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1
common template-haskell
build-depends: template-haskell >=2.7
common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1
common text
build-depends: text >=1.2.4.0
build-depends: text >=1.2
common time
build-depends: time >=1.9.3
@@ -192,18 +176,12 @@ common time
common transformers
build-depends: transformers >=0.5
common os-release
build-depends: os-release >=1.0.0
common unix
build-depends: unix >=2.7
common unix-bytestring
build-depends: unix-bytestring >=0.3
common unordered-containers
build-depends: unordered-containers >= 0.2.10.0
common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2
@@ -216,15 +194,12 @@ common vector
common versions
build-depends: versions >=3.5
common vty
build-depends: vty >=5.28.2
common waargonaut
build-depends: waargonaut >=0.8
common word8
build-depends: word8 >=0.1.3
common yaml
build-depends: yaml >=0.11.4.0
common zlib
build-depends: zlib >=0.6.2.1
@@ -267,6 +242,7 @@ library
, hpath-filepath
, hpath-io
, hpath-posix
, language-bash
, lzma
, megaparsec
, monad-logger
@@ -279,30 +255,30 @@ library
, resourcet
, safe
, safe-exceptions
, split
, streamly
, streamly-posix
, streamly-bytestring
, strict-base
, string-interpolate
, tar-bytestring
, template-haskell
, text
, time
, transformers
, os-release
, unix
, unix-bytestring
, unordered-containers
, uri-bytestring
, utf8-string
, vector
, versions
, word8
, yaml
, zlib
exposed-modules:
GHCup
GHCup.Data.GHCupDownloads
GHCup.Data.GHCupInfo
GHCup.Data.ToolRequirements
GHCup.Download
GHCup.Download.Utils
GHCup.Errors
@@ -312,6 +288,7 @@ library
GHCup.Types.JSON
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.Logger
@@ -327,26 +304,17 @@ library
if flag(internal-downloader)
import:
HsOpenSSL
, HsOpenSSL
, http-io-streams
, io-streams
, terminal-progress-bar
exposed-modules: GHCup.Download.IOStreams
cpp-options: -DINTERNAL_DOWNLOADER
if flag(tar)
import:
tar-bytestring
cpp-options: -DTAR
else
import:
libarchive
executable ghcup
import:
config
, base
, aeson
, bytestring
, containers
, haskus-utils-variant
@@ -364,7 +332,6 @@ executable ghcup
, table-layout
, template-haskell
, text
, unix-bytestring
, uri-bytestring
, utf8-string
, versions
@@ -381,19 +348,6 @@ executable ghcup
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if flag(tui)
import:
brick
, vector
, vty
other-modules: BrickMain
cpp-options: -DBRICK
if flag(tar)
cpp-options: -DTAR
else
import:
libarchive
executable ghcup-gen
import:
@@ -419,7 +373,6 @@ executable ghcup-gen
, uri-bytestring
, utf8-string
, versions
, yaml
--
main-is: Main.hs

View File

@@ -1,4 +0,0 @@
cradle:
cabal:
- path: "."
component: "ghcup:lib:ghcup"

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

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

View File

@@ -0,0 +1,147 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Data.ToolRequirements where
import GHCup.Types
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import qualified Data.Map as M
-- | Currently 'GHC' is used for both GHC and cabal to simplify
-- this, until we need actual separation.
toolRequirements :: ToolRequirements
toolRequirements = M.fromList
[ ( GHC
, M.fromList
[ ( Nothing
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, Requirements
[]
[s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
)
]
)
, ( Linux Alpine
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "g++"
, "gmp-dev"
, "ncurses-dev"
, "libffi-dev"
, "make"
, "xz"
, "tar"
, "perl"
]
""
)
]
)
, ( Linux Ubuntu
, M.fromList
[ ( Nothing
, Requirements
[ "build-essential"
, "curl"
, "libffi-dev"
, "libffi6"
, "libgmp-dev"
, "libgmp10"
, "libncurses-dev"
, "libncurses5"
, "libtinfo5"
]
""
)
]
)
, ( Linux Debian
, M.fromList
[ ( Nothing
, Requirements
[ "build-essential"
, "curl"
, "libffi-dev"
, "libffi6"
, "libgmp-dev"
, "libgmp10"
, "libncurses-dev"
, "libncurses5"
, "libtinfo5"
]
""
)
]
)
, ( Linux CentOS
, M.fromList
[ ( Nothing
, Requirements
[ "gcc"
, "gcc-c++"
, "gmp"
, "gmp-devel"
, "make"
, "ncurses"
, "ncurses-compat-libs"
, "xz"
, "perl"
]
""
),
( Just [vers|7|]
, Requirements
[ "gcc"
, "gcc-c++"
, "gmp"
, "gmp-devel"
, "make"
, "ncurses"
, "xz"
, "perl"
]
""
)
]
)
, ( Darwin
, M.fromList
[ ( Nothing
, Requirements
[]
"On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
)
]
)
, ( FreeBSD
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "gmp"
, "gmake"
, "ncurses"
, "perl5"
, "libffi"
, "libiconv"
]
""
)
]
)
]
)
]
)
]

View File

@@ -9,23 +9,6 @@
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Module for handling all download related functions.
Generally we support downloading via:
- curl (default)
- wget
- internal downloader (only when compiled)
-}
module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER)
@@ -52,7 +35,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
@@ -68,7 +50,7 @@ import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO hiding ( hideError )
import HPath.IO as HIO
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
@@ -89,7 +71,6 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
@@ -105,7 +86,7 @@ import qualified System.Posix.RawFilePath.Directory
-- | Like 'getDownloads', but tries to fall back to
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
-- cached ~/.ghcup/cache/ghcup-<format-ver>.json
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
@@ -133,17 +114,17 @@ getDownloadsF urlSource = do
(OwnSpec _) -> liftE $ getDownloads urlSource
where
readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
yaml_file <- (cacheDir </>) <$> urlBaseName path
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
(\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
$ liftIO
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
$ readFile json_file
lE' JSONDecodeError $ eitherDecode' bs
-- | Downloads the download information! But only if we need to ;P
@@ -164,10 +145,10 @@ getDownloads urlSource = do
case urlSource of
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
where
@@ -200,8 +181,8 @@ getDownloads urlSource = do
m1
L.ByteString
smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file
if e
@@ -226,7 +207,7 @@ getDownloads urlSource = do
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do
liftIO $ createDirRecursive newDirPerms cacheDir
liftIO $ createDirIfMissing newDirPerms cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Nothing -> do
@@ -289,10 +270,7 @@ getDownloadInfo :: Tool
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
(Left NoDownload)
Right
(case p of
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro)
(with_distro <|> without_distro_ver <|> without_distro)
where
with_distro = distro_preview id id
@@ -392,15 +370,15 @@ downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> do
Settings {dirs = Dirs {..}} <- lift ask
cachedir <- liftIO $ ghcupCacheDir
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cacheDir </> fn
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure $ cachfile
| otherwise -> liftE $ download dli cacheDir mfn
| otherwise -> liftE $ download dli cachedir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn

View File

@@ -13,7 +13,6 @@ module GHCup.Download.IOStreams where
import GHCup.Download.Utils
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File

View File

@@ -3,15 +3,6 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-|
Module : GHCup.Errors
Description : GHCup error types
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Errors where
import GHCup.Types
@@ -89,9 +80,6 @@ data JSONError = JSONDecodeError String
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show

View File

@@ -6,21 +6,13 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Plaform
Description : Retrieving platform information
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
@@ -44,7 +36,6 @@ import Prelude hiding ( abs
, writeFile
)
import System.Info
import System.OsRelease
import Text.Regex.Posix
import qualified Data.Text as T
@@ -57,7 +48,10 @@ import qualified Data.Text as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
PlatformRequest
platformRequest = do
@@ -68,21 +62,15 @@ platformRequest = do
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
"powerpc" -> Right A_PowerPC
"powerpc64" -> Right A_PowerPC64
"powerpc64le" -> Right A_PowerPC64
"sparc" -> Right A_Sparc
"sparc64" -> Right A_Sparc64
"arm" -> Right A_ARM
"aarch64" -> Right A_ARM64
what -> Left (NoCompatibleArch what)
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
'[NoCompatiblePlatform , DistroNotFound]
m
PlatformResult
getPlatform = do
@@ -94,7 +82,6 @@ getPlatform = do
ver <-
( either (const Nothing) Just
. versioning
-- TODO: maybe do this somewhere else
. getMajorVersion
. decUTF8Safe
)
@@ -124,6 +111,7 @@ getLinuxDistro = do
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
@@ -148,6 +136,10 @@ getLinuxDistro = do
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
@@ -157,9 +149,9 @@ getLinuxDistro = do
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
Just (OsRelease { name = name, version_id = version_id }) <-
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
@@ -168,6 +160,12 @@ getLinuxDistro = do
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap decUTF8Safe' $ readFile redhat_release

View File

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

View File

@@ -1,30 +1,14 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module : GHCup.Types
Description : GHCup types
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Types where
import Control.Concurrent.MVar
import Data.ByteString ( ByteString )
import Data.Map.Strict ( Map )
import Data.Text ( Text )
import Data.Versions
import HPath
import URI.ByteString
import System.Posix.Types
import qualified GHC.Generics as GHC
@@ -99,7 +83,6 @@ data VersionInfo = VersionInfo
-- | A tag. These are currently attached to a version of a tool.
data Tag = Latest
| Recommended
| Prerelease
| Base PVP
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
@@ -107,12 +90,6 @@ data Tag = Latest
data Architecture = A_64
| A_32
| A_PowerPC
| A_PowerPC64
| A_Sparc
| A_Sparc64
| A_ARM
| A_ARM64
deriving (Eq, GHC.Generic, Ord, Show)
@@ -144,7 +121,7 @@ data LinuxDistro = Debian
-- to download, extract and install a tool.
data DownloadInfo = DownloadInfo
{ _dlUri :: URI
, _dlSubdir :: Maybe TarDir
, _dlSubdir :: Maybe (Path Rel)
, _dlHash :: Text
}
deriving (Eq, Show)
@@ -157,12 +134,6 @@ data DownloadInfo = DownloadInfo
--------------
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Show)
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
@@ -170,48 +141,14 @@ data URLSource = GHCupURL
deriving Show
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving (Eq, Show)
data ProcState = PRunning ProcessID
| PExited (Either ProcessError ())
deriving Eq
type ExecCb = Bool -- verbose
-> Fd -- log file fd
-> Fd -- input fd to read from
-> MVar ProcState -- state of the producing process
-> ByteString -- log filename
-> IO ()
instance Show ExecCb where
show _ = "**ExecCb**"
data Settings = Settings
{ -- set by user
cache :: Bool
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
-- set on app start
, dirs :: Dirs
, execCb :: ExecCb
}
deriving Show
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
}
deriving Show
data KeepDirs = Always
| Errors

View File

@@ -10,21 +10,11 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Types.JSON
Description : GHCup JSON types/instances
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.Prelude
import Control.Applicative ( (<|>) )
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
@@ -54,7 +44,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
instance ToJSON Tag where
toJSON Latest = String "Latest"
toJSON Recommended = String "Recommended"
toJSON Prerelease = String "Prerelease"
toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'')
toJSON (UnknownTag x ) = String (T.pack x)
@@ -62,7 +51,6 @@ instance FromJSON Tag where
parseJSON = withText "Tag" $ \t -> case T.unpack t of
"Latest" -> pure Latest
"Recommended" -> pure Recommended
"Prerelease" -> pure Prerelease
('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
Right x -> pure $ Base x
Left e -> fail . show $ e
@@ -194,18 +182,3 @@ instance FromJSON (Path Rel) where
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p
toJSON (RegexDir r) = object ["RegexDir" .= r]
instance FromJSON TarDir where
parseJSON v = realDir v <|> regexDir v
where
realDir = withText "TarDir" $ \t -> do
fp <- parseJSON (String t)
pure (RealDir fp)
regexDir = withObject "TarDir" $ \o -> do
r <- o .: "RegexDir"
pure $ RegexDir r

View File

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

View File

@@ -6,18 +6,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
@@ -35,9 +24,6 @@ import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -48,9 +34,7 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Split
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
@@ -58,7 +42,7 @@ import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
@@ -74,18 +58,12 @@ import System.Posix.Files.ByteString ( readSymbolicLink )
import Text.Regex.Posix
import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#endif
import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
#if !defined(TAR)
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
@@ -99,24 +77,20 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion
-> m ByteString
ghcLinkDestination tool ver = do
Settings {dirs = Dirs {..}} <- ask
t <- parseRel tool
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
-> ByteString
ghcLinkDestination tool ver =
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
-- e.g. ghc-8.6.5
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask
bindir <- liftIO $ ghcupBinDir
files <- liftIO $ findFiles'
binDir
bindir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
*> (MP.chunk $ prettyVer _tvVersion)
@@ -124,41 +98,42 @@ rmMinorSymlinks GHCTargetVersion {..} = do
)
forM_ files $ \f -> do
let fullF = (binDir </> f)
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- | Removes the set ghc version for the given target, if any.
rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
-- Removes the set ghc version for the given target, if any.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
rmPlain target = do
Settings {dirs = Dirs {..}} <- lift ask
mtv <- lift $ ghcSet target
mtv <- ghcSet target
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do
let fullF = (binDir </> f)
let fullF = (bindir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (binDir </> [rel|haddock-ghc|])
let hdc_file = (bindir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
-- e.g. ghc-8.6
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion
-> m ()
rmMajorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ findFiles'
binDir
bindir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v')
*> MP.chunk v'
@@ -166,7 +141,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do
)
forM_ files $ \f -> do
let fullF = (binDir </> f)
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@@ -178,128 +153,98 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-----------------------------------
-- | Whethe the given GHC versin is installed.
ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled :: GHCTargetVersion -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader Settings m, MonadThrow m, MonadIO m)
ghcSet :: (MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
Settings {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc
ghcBin <- (</> ghc) <$> liftIO ghcupBinDir
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "ghcLinkVersion" t
where
parser =
(do
_ <- parseUntil1 (MP.chunk "/ghc/")
_ <- MP.chunk "/ghc/"
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "../ghc/"
*> (do
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
ghcdir <- liftIO $ ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do
Settings {dirs = Dirs {..}} <- ask
bindir <- liftIO $ ghcupBinDir
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
bindir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
pure $ maybe vs (\x -> nub $ Right x:vs) cs
pure $ maybe vs (\x -> Right x:vs) cs
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet = do
Settings {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink cabalbin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath cabalbin
Just <$> linkVersion link
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "cabal-" *> version'
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c))
, _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
@@ -308,7 +253,6 @@ cabalSet = do
-----------------------------------------
-- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of
([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y)
@@ -323,7 +267,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m)
getGHCForMajor :: (MonadIO m, MonadThrow m)
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
@@ -366,67 +310,28 @@ getLatestGHCFor major' minor' dls = do
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
-> Excepts '[UnknownArchive] m ()
unpackToDir dest av = do
fp <- (decUTF8Safe . toFilePath) <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
rf = liftIO . readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
#endif
let untar = Tar.unpack (toFilePath dest) . Tar.read
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
(untar . GZip.decompress =<< rf av)
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
(untar . GZip.decompress =<< readFile av)
| ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftE $ rf av
filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
liftIO $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
(untar . BZip.decompress =<< readFile av)
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
RegexDir r -> do
let rs = splitOn "/" r
foldlM
(\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
------------
@@ -483,17 +388,16 @@ urlBaseName :: MonadThrow m
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
-- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
-- while ignoring *-<ver> symlinks and accounting for cross triple prefix.
--
-- Returns unversioned relative files, e.g.:
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m)
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
ghcdir <- liftIO $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed
@@ -513,44 +417,28 @@ ghcToolFiles ver = do
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
)
let ghcbinPath = bindir </> ghcbin
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
onlyUnversioned <- if ghcIsHadrian
then pure id
else do
(Just symver) <-
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
(Just symver) <-
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> ghcbin))
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ onlyUnversioned files
where
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
isHadrian :: Path Abs -- ^ ghcbin path
-> IO Bool
isHadrian = fmap (/= SymbolicLink) . getFileType
pure . filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) $ files
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader Settings m)
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args workdir Nothing
execLogged mymake True args [rel|ghc-make|] workdir Nothing
-- | Try to apply patches in order. Fails with 'PatchFailed'
@@ -573,7 +461,6 @@ applyPatches pdir ddir = do
!? PatchFailed
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
@@ -602,18 +489,24 @@ runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
Settings {..} <- lift ask
let exAction = do
v <- flip
onException
(do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
v <-
flip onException exAction
)
$ catchAllE
(\es -> do
exAction
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
throwE (BuildFailed bdir es)
)
$ action

69
lib/GHCup/Utils/Bash.hs Normal file
View File

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

View File

@@ -1,27 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.Dirs
Description : Definition of GHCup directories
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupGHCBaseDir
, ghcupGHCDir
, parseGHCupGHCDir
, mkGhcupTmpDir
, withGHCupTmpDir
, relativeSymlink
)
where
module GHCup.Utils.Dirs where
import GHCup.Types
@@ -34,7 +15,6 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.ByteString ( ByteString )
import Data.Maybe
import HPath
import HPath.IO
@@ -46,7 +26,6 @@ import Prelude hiding ( abs
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.UTF8 as UTF8
@@ -57,117 +36,33 @@ import qualified Text.Megaparsec as MP
------------------------------
--[ GHCup base directories ]--
------------------------------
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_DATA_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/share|])
pure (bdir </> [rel|ghcup|])
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = do
xdg <- useXDG
if xdg
then do
getEnv "XDG_BIN_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/bin|])
else ghcupBaseDir <&> (</> [rel|bin|])
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup|])
else ghcupBaseDir <&> (</> [rel|cache|])
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup/logs|])
else ghcupBaseDir <&> (</> [rel|logs|])
getDirs :: IO Dirs
getDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
pure Dirs { .. }
-------------------------
--[ GHCup directories ]--
-------------------------
-- | ~/.ghcup by default
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs)
ghcupGHCBaseDir = do
Settings {..} <- ask
pure (baseDir dirs </> [rel|ghc|])
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4
ghcupGHCDir :: (MonadReader Settings m, MonadThrow m)
=> GHCTargetVersion
-> m (Path Abs)
ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
pure (ghcbasedir </> verdir)
@@ -178,6 +73,16 @@ parseGHCupGHCDir (toFilePath -> f) = do
throwEither $ MP.parse ghcTargetVerP "" fp
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> [rel|bin|])
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> [rel|cache|])
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
@@ -189,8 +94,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
--[ Others ]--
--------------
@@ -204,23 +107,3 @@ getHomeDirectory = do
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
useXDG :: IO Bool
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
-> Path Abs -- ^ the symlink destination
-> ByteString
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
let d1 = splitDirectories p1
d2 = splitDirectories p2
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : (drop (length common) d2))

View File

@@ -1,55 +1,41 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Void
import Data.Word8
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import Optics hiding ((<|), (|>))
import HPath.IO
import Optics
import Streamly
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.Console.Pretty
import System.Console.Regions
import System.IO
import System.IO.Error
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
@@ -59,19 +45,38 @@ import Text.Regex.Posix
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process.ByteString
as SPPB
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Text.Megaparsec as MP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Bool signals whether the regions should be cleaned.
data StopThread = StopThread Bool
deriving Show
instance Exception StopThread
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
@@ -82,6 +87,25 @@ data CapturedProcess = CapturedProcess
makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
-- | Read the lines of a file into a stream. The stream holds
-- a file handle as a resource and will close it once the stream
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream p
pure
. (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n')
. (fmap toArray)
$ stream
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
@@ -109,98 +133,110 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> ByteString -- ^ thing to execute
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe spath args chdir env = do
Settings {dirs = Dirs {..}, ..} <- ask
logfile <- (logsDir </>) <$> parseRel (lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd
(action verbose execCb)
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
lfile = fromMaybe exe $ BS.stripPrefix "./" exe
action verbose cb fd = do
action fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1"
void
$ forkIO
-- start the thread that logs to stdout in a region
done <- newEmptyMVar
tid <-
forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ (do
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
cb verbose fd stdoutRead pState lfile)
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
-- fork the subprocess
-- fork our subprocess
pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
closeFd stdoutRead
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env
putMVar pState (PRunning pid)
SPPB.executeFile exe spath args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
void $ swapMVar pState (PExited e)
e <- SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- make sure the logging thread stops
case e of
Left _ -> EX.throwTo tid (StopThread False)
Right _ -> EX.throwTo tid (StopThread True)
takeMVar done
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do
ref <- newIORef ([] :: [ByteString])
displayConsoleRegions $ do
rs <- sequence . replicate size . openConsoleRegion $ Linear
flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
$ handle
(\(StopThread b) -> do
when b (forM_ rs closeConsoleRegion)
EX.throw (StopThread b)
)
$ do
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
-- wait for explicit stop from the parent to signal what cleanup to run
forever (threadDelay 5000)
readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readLineTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
where
-- action to perform line by line
lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs')
regs <- readIORef ref
void $ SPIB.fdWrite fileFd (bs' <> "\n")
forM (zip regs rs) $ \(bs, r) -> do
setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
swapRegs bs regs | length regs < size = regs ++ [bs]
| otherwise = tail regs ++ [bs]
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
-- trim output line to terminal width
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
-- | Capture the stdout and stderr of the given action, which
@@ -237,12 +273,13 @@ captureOutStreams action = do
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ flip finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPPB.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
takeMVar done
case status of
-- readFd will take care of closing the fd
@@ -262,13 +299,13 @@ captureOutStreams action = do
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ flip finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ flip finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
takeMVar doneOut
takeMVar doneErr
@@ -314,13 +351,21 @@ toProcessError :: ByteString
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
unsafePathToString p = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
@@ -364,97 +409,3 @@ findFiles' path parser = do
Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream
pure $ join $ fmap parseRel f
isBrokenSymlink :: Path Abs -> IO Bool
isBrokenSymlink p =
handleIO
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
$ do
_ <- canonicalizePath p
pure False
chmod_777 :: (MonadLogger m, MonadIO m) => Path a -> m ()
chmod_777 (toFilePath -> fp) = do
let exe_mode =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
$(logDebug) [i|chmod 777 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- | The default callback for logging/printing on 'execLogged'.
defExecCb :: ExecCb
defExecCb verbose fd stdoutRead pState lfile = if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6
where
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readLineTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> IO ()
printToRegion fileFd fdIn size = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
let closeEventually = readMVar pState >>= \case
PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion)
_ -> threadDelay 500 >> closeEventually
void $ liftIO $ race closeEventually (threadDelay (1000000 * 3))
throw ex
)
$ readLineTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> lfile <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs

View File

@@ -1,24 +1,10 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
Module : GHCup.Utils.Logger
Description : logger definition
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import HPath
import HPath.IO
@@ -64,12 +50,11 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs)
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
Settings {dirs = Dirs {..}} <- ask
let logfile = logsDir </> context
liftIO $ do
createDirRecursive newDirPerms logsDir
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

View File

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

View File

@@ -8,17 +8,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module : GHCup.Utils.Prelude
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Utils.Prelude where
import Control.Applicative
@@ -176,11 +165,6 @@ liftIOException errType ex =
. lift
-- | Uses safe-exceptions.
hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
hideErrorDef errs def =
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)

View File

@@ -1,35 +1,25 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.String.QQ
Description : String quasi quoters
Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
QuasiQuoter for non-interpolated strings, texts and bytestrings.
The "s" quoter contains a multi-line string with no interpolation at all,
except that the leading newline is trimmed and carriage returns stripped.
@
{-\# LANGUAGE QuasiQuotes #-}
import Data.Text (Text)
import Data.String.QQ
foo :: Text -- "String", "ByteString" etc also works
foo = [s|
Well here is a
multi-line string!
|]
@
Any instance of the IsString type is permitted.
(For GHC versions 6, write "[$s||]" instead of "[s||]".)
-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
-- The "s" quoter contains a multi-line string with no interpolation at all,
-- except that the leading newline is trimmed and carriage returns stripped.
--
-- @
-- {-\# LANGUAGE QuasiQuotes #-}
-- import Data.Text (Text)
-- import Data.String.QQ
-- foo :: Text -- "String", "ByteString" etc also works
-- foo = [s|
-- Well here is a
-- multi-line string!
-- |]
-- @
--
-- Any instance of the IsString type is permitted.
--
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
--
module GHCup.Utils.String.QQ
( s
)

View File

@@ -7,15 +7,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Version.QQ
Description : Version quasi-quoters
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Utils.Version.QQ where
import Data.Data
@@ -51,6 +42,7 @@ deriving instance Data VUnit
#if !MIN_VERSION_base(4,13,0)
deriving instance Lift (NonEmpty Word)
instance Lift Text
#endif
qq :: (Text -> Q Exp) -> QuasiQuoter

View File

@@ -1,15 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Version
Description : Static version information
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Version where
import GHCup.Utils.Version.QQ
@@ -20,14 +11,12 @@ import URI.ByteString.QQ
import qualified Data.Text as T
-- | This reflects the API version of the YAML.
-- | This reflects the API version of the JSON.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
-- | The current ghcup version.
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.10|]
ghcUpVer = [pver|0.1.5|]
-- | ghcup version as numeric string.
numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer

View File

@@ -101,7 +101,6 @@ body#idx p.other-help {
.instructions div.command-button {
display: flex;
align-items: center;
}
.instructions div.command-button button {
@@ -112,7 +111,7 @@ body#idx p.other-help {
border-style: solid;
border-radius: 3px;
margin-left: 0.5rem;
margin-left: 1rem;
margin-right: auto;
margin-top: 25px;
margin-bottom: 25px;
@@ -135,21 +134,20 @@ hr {
#platform-instructions-linux > div > pre,
#platform-instructions-mac > div > pre,
#platform-instructions-freebsd > div > pre,
#platform-instructions-win32 > div > pre,
#platform-instructions-win64 > div > pre,
#platform-instructions-win32 > pre,
#platform-instructions-win64 > pre,
#platform-instructions-default > div > div > pre,
#platform-instructions-unknown > div > div > pre {
background-color: #515151;
color: white;
margin-left: auto;
margin-right: auto;
padding-top: 1rem;
padding-bottom: 1rem;
padding-right: 1rem;
text-align: center;
border-radius: 3px;
box-shadow: inset 0px 0px 20px 0px #333333;
font-size: 0.6em;
width: 40rem;
}
#platform-instructions-win32 a.windows-download,

View File

@@ -46,9 +46,6 @@
<p>
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
</p>
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -58,9 +55,6 @@
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -83,7 +77,7 @@
<!-- duplicate the default cross-platform instructions -->
<div>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<p>If you are running Linux, macOS or FreeBSD,<br/>run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
@@ -101,7 +95,7 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
@@ -146,7 +140,7 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>