Compare commits

..

1 Commits

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

10
.gitignore vendored
View File

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

View File

@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1" GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images # Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
############################################################ ############################################################
# CI Step # CI Step
@@ -97,7 +97,7 @@ variables:
test:linux:recommended: test:linux:recommended:
extends: .test_ghcup_version:linux extends: .test_ghcup_version:linux
variables: variables:
GHC_VERSION: "8.8.4" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:linux:latest: test:linux:latest:
@@ -113,7 +113,7 @@ test:linux:latest:
test:mac:recommended: test:mac:recommended:
extends: .test_ghcup_version:darwin extends: .test_ghcup_version:darwin
variables: variables:
GHC_VERSION: "8.8.4" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:mac:latest: test:mac:latest:
@@ -129,7 +129,7 @@ test:mac:latest:
test:freebsd:recommended: test:freebsd:recommended:
extends: .test_ghcup_version:freebsd extends: .test_ghcup_version:freebsd
variables: variables:
GHC_VERSION: "8.8.4" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:freebsd:latest: test:freebsd:latest:
@@ -150,7 +150,7 @@ release:linux:64bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh - ./.gitlab/before_script/linux/alpine/install_deps.sh
variables: variables:
ARTIFACT: "x86_64-linux-ghcup" ARTIFACT: "x86_64-linux-ghcup"
GHC_VERSION: "8.8.4" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
@@ -162,7 +162,7 @@ release:linux:32bit:
- ./.gitlab/before_script/linux/alpine/install_deps.sh - ./.gitlab/before_script/linux/alpine/install_deps.sh
variables: variables:
ARTIFACT: "i386-linux-ghcup" ARTIFACT: "i386-linux-ghcup"
GHC_VERSION: "8.8.4" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
@@ -194,5 +194,4 @@ release:freebsd:
variables: variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup" ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.8.3" 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 chmod +x ghcup-bin
./ghcup-bin install ${GHC_VERSION} ./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
./ghcup-bin set ${GHC_VERSION} ./ghcup-bin set ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
exit 0 exit 0

View File

@@ -18,14 +18,29 @@ apk add --no-cache \
tar \ tar \
perl perl
ln -s libncurses.so /usr/lib/libtinfo.so
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
if [ "${BIT}" = "32" ] ; then 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 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 fi
chmod +x ghcup-bin chmod +x ghcup-bin
./ghcup-bin upgrade
./ghcup-bin install ${GHC_VERSION} ./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 # utils
apk add --no-cache \ apk add --no-cache \
@@ -42,6 +57,7 @@ apk add --no-cache \
openssl-dev \ openssl-dev \
openssl-libs-static \ openssl-libs-static \
xz \ xz \
xz-dev \ xz-dev
ncurses-static

View File

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

View File

@@ -11,7 +11,7 @@ ecabal() {
} }
eghcup() { eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@" ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
} }
git describe --always git describe --always
@@ -21,13 +21,11 @@ git describe --always
ecabal update ecabal update
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui ecabal build -w ghc-${GHC_VERSION}
else else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
fi fi
ecabal haddock
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" . cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec --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-gen')" .
@@ -42,10 +40,16 @@ rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing ### manual cli based testing
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml ghcup-gen check -f ghcup-${JSON_VERSION}.json
eghcup --numeric-version 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 install ${GHC_VERSION}
eghcup set ${GHC_VERSION} eghcup set ${GHC_VERSION}
eghcup install-cabal ${CABAL_VERSION} eghcup install-cabal ${CABAL_VERSION}

View File

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

View File

@@ -18,7 +18,7 @@ ghcup set 8.8.3
## install ghcup ## install ghcup
cabal update 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')" . cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
strip ./ghcup strip -s ghcup
cp ghcup "./${ARTIFACT}" cp ghcup "./${ARTIFACT}"

View File

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

View File

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

View File

@@ -1,31 +1,5 @@
# Revision history for ghcup # Revision history for ghcup
## 0.1.8 -- 2020-07-21
* Fix bug in logging thread dying on newlines
* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
## 0.1.7 -- 2020-07-20
* Fix a bug in libarchive not unpacking some uncleanly packed bindists
* Improved fish support in bootstrap-haskell
* Only check for upgrades when not upgrading
* Fix platform detection for i386 docker images
* Improve alpine support
- more/proper bindists
- don't fall back to glibc based bindists
- install bindists with `--disable-ld-override` to avoid ld.gold bugs
## 0.1.6 -- 2020-07-13
* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
* Support multiple installed versions of cabal #23
* Improvements to `ghcup list` (show unavailable bindists for platform)
* Fix redhat downloads #29
* Support for hadrian bindists (fixes alpine-8.10.1) #31
* Add FreeBSD bindists 8.6.5 and 8.8.3
* Fix memory leak during unpack
## 0.1.5 -- 2020-04-30 ## 0.1.5 -- 2020-04-30
* Fix errors when PATH variable contains path components that are actually files * Fix errors when PATH variable contains path components that are actually files

View File

@@ -40,13 +40,7 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See `ghcup --help`. See `ghcup --help`.
For the simple interactive TUI, run: Common use cases are:
```sh
ghcup tui
```
For the full functionality via cli:
```sh ```sh
# list available ghc/cabal versions # list available ghc/cabal versions

View File

@@ -1,19 +1,19 @@
# RELEASING # 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 2. Update version in ghcup.cabal
3. Add ChangeLog entry 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. 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` 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` 9. Update bootstrap-haskell and symlinks on `downloads.haskell.org/ghcup`

View File

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

View File

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

View File

@@ -1,362 +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 Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
type LR = GenericList String Vector ListResult
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
keyHandlers =
[ ('q', "Quit" , halt)
, ('i', "Install" , withIOAction install')
, ('u', "Uninstall", withIOAction del')
, ('s', "Set" , withIOAction set')
, ('c', "ChangeLog", withIOAction changelog')
]
ui :: AppState -> Widget String
ui AppState {..} =
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
where
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
| otherwise -> (withAttr "not-installed" $ str "")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
in dim
( marks
<+> ( padLeft (Pad 2)
$ minHSize 20
$ ((if b then withAttr "active" else id)
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
)
)
<+> (padLeft (Pad 1) $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
)
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const defaultAttributes
, appChooseCursor = neverShowCursor
}
defaultAttributes :: AttrMap
defaultAttributes = attrMap
Vty.defAttr
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
dimAttributes :: AttrMap
dimAttributes = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls pfreq)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls pfreq)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> AppState
-> EventM n (Next AppState)
withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
r <- action as (ix, e)
case r of
Left err -> throwIO $ userError err
Right _ -> do
apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
$ getAppState Nothing (pfreq as)
case apps of
Right nas -> do
putStrLn "Press enter to continue"
_ <- getLine
pure nas
Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
install' AppState {..} (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate]
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}
Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState {..} (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
uri' :: IORef (Maybe URI)
{-# NOINLINE uri' #-}
uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings
{-# NOINLINE settings' #-}
settings' = unsafePerformIO
(newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
}
)
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l av pfreq' = do
writeIORef uri' muri
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> defaultMain app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
where
selectLatest :: AppState -> AppState
selectLatest AppState {..} =
(\ix -> AppState { lr = listMoveTo ix lr, .. })
. fromJust
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
$ (listElements lr)
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]

View File

@@ -10,10 +10,6 @@
module Main where module Main where
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
@@ -25,12 +21,8 @@ import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version import GHCup.Version
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@@ -38,7 +30,6 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Aeson ( eitherDecode )
import Data.Bifunctor import Data.Bifunctor
import Data.Char import Data.Char
import Data.Either import Data.Either
@@ -69,7 +60,6 @@ import URI.ByteString
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8 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 as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
@@ -103,9 +93,6 @@ data Command
| Upgrade UpgradeOpts Bool | Upgrade UpgradeOpts Bool
| ToolRequirements | ToolRequirements
| ChangeLog ChangeLogOptions | ChangeLog ChangeLogOptions
#if defined(BRICK)
| Interactive
#endif
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag | ToolTag Tag
@@ -121,7 +108,6 @@ data InstallCommand = InstallGHC InstallOptions
data InstallOptions = InstallOptions data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest , instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe DownloadInfo
} }
data SetCommand = SetGHC SetOptions data SetCommand = SetGHC SetOptions
@@ -235,20 +221,7 @@ opts =
com :: Parser Command com :: Parser Command
com = com =
subparser subparser
#if defined(BRICK)
( command ( command
"tui"
( (\_ -> Interactive)
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else
( command
#endif
"install" "install"
( Install ( Install
<$> (info <$> (info
@@ -339,32 +312,32 @@ com =
) )
where where
installToolFooter :: String installToolFooter :: String
installToolFooter = [s|Discussion: installToolFooter = [i|Discussion:
Installs GHC or cabal. When no command is given, installs GHC Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag. with the specified version/tag.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|] It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
setFooter :: String setFooter :: String
setFooter = [s|Discussion: setFooter = [i|Discussion:
Sets the currently active GHC or cabal version. When no command is given, 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 defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version). is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand ('ghc' or 'cabal').|] It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
rmFooter :: String rmFooter :: String
rmFooter = [s|Discussion: rmFooter = [i|Discussion:
Remove the given GHC or cabal version. When no command is given, Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version. defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|] It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
changeLogFooter :: String changeLogFooter :: String
changeLogFooter = [s|Discussion: changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release. By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|] Pass '-o' to automatically open via xdg-open.|]
installCabalFooter :: String installCabalFooter :: String
installCabalFooter = [s|Discussion: installCabalFooter = [i|Discussion:
Installs the specified cabal-install version (or a recommended default one) Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by "cabal install cabal-install", which installs into "~/.cabal/bin" by
@@ -400,7 +373,7 @@ installParser =
<|> (Right <$> installOpts) <|> (Right <$> installOpts)
where where
installGHCFooter :: String installGHCFooter :: String
installGHCFooter = [s|Discussion: installGHCFooter = [i|Discussion:
Installs the specified GHC version (or a recommended default one) into Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|] and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
@@ -408,7 +381,7 @@ installParser =
installOpts :: Parser InstallOptions installOpts :: Parser InstallOptions
installOpts = installOpts =
(\p u v -> InstallOptions v p u) (flip InstallOptions)
<$> (optional <$> (optional
(option (option
(eitherReader platformParser) (eitherReader platformParser)
@@ -420,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\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
)
)
)
<*> optional toolVersionArgument <*> optional toolVersionArgument
@@ -462,13 +424,13 @@ setParser =
<|> (Right <$> setOpts) <|> (Right <$> setOpts)
where where
setGHCFooter :: String setGHCFooter :: String
setGHCFooter = [s|Discussion: setGHCFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|] "~/.ghcup/bin/<binary>".|]
setCabalFooter :: String setCabalFooter :: String
setCabalFooter = [s|Discussion: setCabalFooter = [i|Discussion:
Sets the the current Cabal version.|] Sets the the current Cabal version.|]
@@ -568,7 +530,7 @@ compileP = subparser
) )
) )
where where
compileFooter = [s|Discussion: compileFooter = [i|Discussion:
Compiles and installs the specified GHC version into Compiles and installs the specified GHC version into
a self-contained "~/.ghcup/ghc/<ghcver>" directory a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>". and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
@@ -814,8 +776,6 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
pure v pure v
bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString
toSettings :: Options -> Settings toSettings :: Options -> Settings
@@ -824,7 +784,6 @@ toSettings Options {..} =
noVerify = optNoVerify noVerify = optNoVerify
keepDirs = optKeepDirs keepDirs = optKeepDirs
downloader = optsDownloader downloader = optsDownloader
verbose = optVerbose
in Settings { .. } in Settings { .. }
@@ -884,7 +843,7 @@ main = do
<> internal <> internal
) )
let main_footer = [s|Discussion: let main_footer = [i|Discussion:
ghcup installs the Glasgow Haskell Compiler from the official ghcup installs the Glasgow Haskell Compiler from the official
release channels, enabling you to easily switch between different release channels, enabling you to easily switch between different
versions. It maintains a self-contained ~/.ghcup directory. versions. It maintains a self-contained ~/.ghcup directory.
@@ -909,12 +868,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter -- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|] logfile <- initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig let runLogger = myLoggerT LoggerConfig
{ lcPrintDebug = optVerbose { lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = appendFile logfile , rawOutter = appendFile logfile
} }
let runLogger = myLoggerT loggerConfig
------------------------- -------------------------
@@ -928,13 +886,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
, UnknownArchive , UnknownArchive
#if !defined(TAR) , DistroNotFound
, ArchiveResult
#endif
, FileDoesNotExistError , FileDoesNotExistError
, CopyError , CopyError
, NoCompatibleArch
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, NoCompatiblePlatform
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, DigestError , DigestError
@@ -949,6 +907,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
, TagNotFound , TagNotFound
, TagNotFound
] ]
let let
@@ -959,9 +918,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound , TagNotFound
] ]
let runListGHC = runLogger let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runRm = let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
@@ -978,15 +937,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled @'[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, GHCupSetError , GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotFoundInPATH , NotFoundInPATH
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] ]
let runCompileCabal = let runCompileCabal =
@@ -998,14 +957,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed , BuildFailed
, CopyError , CopyError
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] ]
let runUpgrade = let runUpgrade =
@@ -1014,6 +973,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload , NoDownload
, NoUpdate , NoUpdate
, FileDoesNotExistError , FileDoesNotExistError
@@ -1022,19 +984,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
---------------------------------------- ---------------------------
-- Getting download and platform info -- -- Getting download info --
---------------------------------------- ---------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) [i|Error determining Platform: #{e}|])
exitWith (ExitFailure 2)
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
@@ -1049,11 +1001,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger runLogger
($(logError) [i|Error fetching download info: #{e}|]) ($(logError) [i|Error fetching download info: #{e}|])
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
(runLogger
case optCommand of . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
Upgrade _ _ -> pure () )
_ -> runLogger $ checkForUpdates dls pfreq >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) [i|Error checking for upgrades: #{e}|])
----------------------- -----------------------
@@ -1063,9 +1018,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} = let installGHC InstallOptions{..} =
(runInstTool $ do (runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
case instBindist of liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@@ -1099,9 +1052,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} = let installCabal InstallOptions{..} =
(runInstTool $ do (runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
case instBindist of liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@@ -1151,7 +1102,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14 pure $ ExitFailure 14
let rmGHC' RmOptions{..} = let rmGHC' RmOptions{..} =
(runRm $ do (runRmGHC $ do
liftE $ rmGHCVer ghcVer liftE $ rmGHCVer ghcVer
) )
>>= \case >>= \case
@@ -1161,7 +1112,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 7 pure $ ExitFailure 7
let rmCabal' tv = let rmCabal' tv =
(runRm $ do (runSetCabal $ do
liftE $ rmCabalVer tv liftE $ rmCabalVer tv
) )
>>= \case >>= \case
@@ -1173,9 +1124,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
installGHC iopts installGHC iopts
@@ -1193,10 +1141,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List (ListOptions {..}) -> List (ListOptions {..}) ->
(runListGHC $ do (runListGHC $ do
l <- listVersions dls lTool lCriteria pfreq l <- listVersions dls lTool lCriteria
liftIO $ printListResult lRawFormat l pure l
pure ExitSuccess
) )
>>= \case
VRight r -> do
liftIO $ printListResult lRawFormat r
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6
Rm (Right rmopts) -> do Rm (Right rmopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
@@ -1223,7 +1177,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig buildConfig
patchDir patchDir
addConfArgs addConfArgs
pfreq
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@@ -1248,7 +1201,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
Compile (CompileCabal CabalCompileOptions {..}) -> Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do (runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@@ -1279,7 +1232,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
bdir <- liftIO $ ghcupBinDir bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|])) pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case (runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
VRight v' -> do VRight v' -> do
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
runLogger $ $(logInfo) runLogger $ $(logInfo)
@@ -1331,14 +1284,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure ExitSuccess pure ExitSuccess
Just uri -> do Just uri -> do
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
if clOpen if clOpen
then then
exec cmd exec "xdg-open"
True True
[serializeURIRef' uri] [serializeURIRef' uri]
Nothing Nothing
@@ -1430,32 +1378,37 @@ printListResult raw lr = do
checkForUpdates :: (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 => GHCupDownloads
-> PlatformRequest -> Excepts
-> m () '[ NoCompatiblePlatform
checkForUpdates dls pfreq = do , NoCompatibleArch
, DistroNotFound
]
m
()
checkForUpdates dls = do
forM_ (getLatest dls GHCup) $ \l -> do forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ lift $ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do forM_ (getLatest dls GHC) $ \l -> do
mghc_ver <- latestInstalled GHC mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver -> forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ lift $ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|] [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)
$ $(logWarn) $ lift $ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where where
latestInstalled tool = (fmap lVer . lastMay) latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq) <$> (listVersions dls (Just tool) (Just ListInstalled))
prettyDebugInfo :: DebugInfo -> String prettyDebugInfo :: DebugInfo -> String
@@ -1472,13 +1425,6 @@ Version: #{describe_result}|]
prettyArch :: Architecture -> String prettyArch :: Architecture -> String
prettyArch A_64 = "amd64" prettyArch A_64 = "amd64"
prettyArch A_32 = "i386" 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 -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' } prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v' = show plat <> ", " <> show v'

View File

@@ -18,39 +18,26 @@ edo()
} }
eghcup() { eghcup() {
edo _eghcup "$@"
}
_eghcup() {
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
ghcup "$@" edo ghcup "$@"
else else
ghcup --verbose "$@" edo ghcup --verbose "$@"
fi fi
} }
download_ghcup() { download_ghcup() {
_plat="$(uname -s)" _plat="$(uname -s)"
_arch=$(uname -m) _arch=$(uname -m)
_ghver="0.1.8" _ghver="0.1.5"
_base_url="https://downloads.haskell.org/~ghcup"
case "${_plat}" in case "${_plat}" in
"linux"|"Linux") "linux"|"Linux")
case "${_arch}" in case "${_arch}" in
x86_64|amd64) x86_64|amd64)
# we could be in a 32bit docker container, in which _url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-linux-ghcup-${_ghver}
# case uname doesn't give us what we want
if [ "$(getconf LONG_BIT)" = "32" ] ; then
_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
elif [ "$(getconf LONG_BIT)" = "64" ] ; then
_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
else
die "Unknown long bit size: $(getconf LONG_BIT)"
fi
;; ;;
i*86) 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}" *) die "Unknown architecture: ${_arch}"
;; ;;
@@ -66,7 +53,7 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}" *) die "Unknown architecture: ${_arch}"
;; ;;
esac 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") "Darwin"|"darwin")
case "${_arch}" in case "${_arch}" in
@@ -78,23 +65,14 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}" *) die "Unknown architecture: ${_arch}"
;; ;;
esac 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}" *) die "Unknown platform: ${_plat}"
;; ;;
esac esac
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup unset _plat _arch _url _ghver
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
eghcup upgrade
unset _plat _arch _url _ghver _base_url
} }
@@ -123,10 +101,18 @@ edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
if command -V "ghcup" >/dev/null 2>&1 ; then if command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
_eghcup upgrade || download_ghcup eghcup upgrade
fi fi
else else
download_ghcup 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 fi
echo echo
@@ -143,10 +129,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty read -r answer </dev/tty
fi fi
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}" eghcup --cache install "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}" eghcup set "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}" eghcup --cache install-cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
edo cabal new-update edo cabal new-update
@@ -177,9 +163,6 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
exit 0 exit 0
fi fi
;; ;;
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) exit 0 ;; *) exit 0 ;;
esac esac
@@ -195,16 +178,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
case $next_answer in case $next_answer in
[Yy]*) [Yy]*)
case $MY_SHELL in echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
"") break ;;
fish)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env ; and set -gx PATH \$HOME/.cabal/bin \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
break ;;
*)
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
break ;;
esac
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect," printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session." 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;; exit 0;;

View File

@@ -2,12 +2,6 @@ packages: ./ghcup.cabal
optional-packages: ./3rdparty/*/*.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 optimization: 2
package streamly package streamly
@@ -16,9 +10,9 @@ package streamly
package ghcup package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package tar-bytestring
ghc-options: -O2
constraints: http-io-streams -brotli constraints: http-io-streams -brotli
package libarchive allow-newer: base
flags: static
allow-newer: base ghc-prim template-haskell

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 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.8 version: 0.1.5
synopsis: ghc toolchain installer as an exe/library synopsis: ghc toolchain installer as an exe/library
description: description:
A rewrite of the shell script ghcup, for providing A rewrite of the shell script ghcup, for providing
@@ -21,21 +21,11 @@ source-repository head
type: git type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.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 flag internal-downloader
description: Compile the internal downloader, which links against OpenSSL description: Compile the internal downloader, which links against OpenSSL
default: False default: False
manual: True manual: True
flag tar
description: Use tar-bytestring instead of libarchive
default: False
manual: True
common HsOpenSSL common HsOpenSSL
build-depends: HsOpenSSL >=0.11.4.18 build-depends: HsOpenSSL >=0.11.4.18
@@ -60,9 +50,6 @@ common base16-bytestring
common binary common binary
build-depends: binary >=0.8.6.0 build-depends: binary >=0.8.6.0
common brick
build-depends: brick >=0.54
common bytestring common bytestring
build-depends: bytestring >=0.10 build-depends: bytestring >=0.10
@@ -94,13 +81,13 @@ common hpath
build-depends: hpath >=0.11 build-depends: hpath >=0.11
common hpath-directory common hpath-directory
build-depends: hpath-directory >=0.14 build-depends: hpath-directory >=0.13.3
common hpath-filepath common hpath-filepath
build-depends: hpath-filepath >=0.10.3 build-depends: hpath-filepath >=0.10.3
common hpath-io common hpath-io
build-depends: hpath-io >=0.14 build-depends: hpath-io >=0.13.1
common hpath-posix common hpath-posix
build-depends: hpath-posix >=0.13.2 build-depends: hpath-posix >=0.13.2
@@ -111,8 +98,8 @@ common http-io-streams
common io-streams common io-streams
build-depends: io-streams >=1.5 build-depends: io-streams >=1.5
common libarchive common language-bash
build-depends: libarchive >= 2.2.5.2 build-depends: language-bash >=0.9
common lzma common lzma
build-depends: lzma >=0.0.0.3 build-depends: lzma >=0.0.0.3
@@ -171,17 +158,17 @@ common string-interpolate
common table-layout common table-layout
build-depends: table-layout >=0.8 build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
common tar-bytestring common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1 build-depends: tar-bytestring >=0.6.3.1
common template-haskell
build-depends: template-haskell >=2.7
common terminal-progress-bar common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1 build-depends: terminal-progress-bar >=0.4.1
common text common text
build-depends: text >=1.2.4.0 build-depends: text >=1.2
common time common time
build-depends: time >=1.9.3 build-depends: time >=1.9.3
@@ -189,18 +176,12 @@ common time
common transformers common transformers
build-depends: transformers >=0.5 build-depends: transformers >=0.5
common os-release
build-depends: os-release >=1.0.0
common unix common unix
build-depends: unix >=2.7 build-depends: unix >=2.7
common unix-bytestring common unix-bytestring
build-depends: unix-bytestring >=0.3 build-depends: unix-bytestring >=0.3
common unordered-containers
build-depends: unordered-containers >= 0.2.10.0
common uri-bytestring common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2 build-depends: uri-bytestring >=0.3.2.2
@@ -213,15 +194,12 @@ common vector
common versions common versions
build-depends: versions >=3.5 build-depends: versions >=3.5
common vty common waargonaut
build-depends: vty >=5.28.2 build-depends: waargonaut >=0.8
common word8 common word8
build-depends: word8 >=0.1.3 build-depends: word8 >=0.1.3
common yaml
build-depends: yaml >=0.11.4.0
common zlib common zlib
build-depends: zlib >=0.6.2.1 build-depends: zlib >=0.6.2.1
@@ -264,6 +242,7 @@ library
, hpath-filepath , hpath-filepath
, hpath-io , hpath-io
, hpath-posix , hpath-posix
, language-bash
, lzma , lzma
, megaparsec , megaparsec
, monad-logger , monad-logger
@@ -281,24 +260,25 @@ library
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-interpolate , string-interpolate
, tar-bytestring
, template-haskell , template-haskell
, text , text
, time , time
, transformers , transformers
, os-release
, unix , unix
, unix-bytestring , unix-bytestring
, unordered-containers
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
, vector , vector
, versions , versions
, word8 , word8
, yaml
, zlib , zlib
exposed-modules: exposed-modules:
GHCup GHCup
GHCup.Data.GHCupDownloads
GHCup.Data.GHCupInfo
GHCup.Data.ToolRequirements
GHCup.Download GHCup.Download
GHCup.Download.Utils GHCup.Download.Utils
GHCup.Errors GHCup.Errors
@@ -308,6 +288,7 @@ library
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Utils GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs GHCup.Utils.Dirs
GHCup.Utils.File GHCup.Utils.File
GHCup.Utils.Logger GHCup.Utils.Logger
@@ -323,26 +304,17 @@ library
if flag(internal-downloader) if flag(internal-downloader)
import: import:
HsOpenSSL , HsOpenSSL
, http-io-streams , http-io-streams
, io-streams , io-streams
, terminal-progress-bar , terminal-progress-bar
exposed-modules: GHCup.Download.IOStreams exposed-modules: GHCup.Download.IOStreams
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
if flag(tar)
import:
tar-bytestring
cpp-options: -DTAR
else
import:
libarchive
executable ghcup executable ghcup
import: import:
config config
, base , base
, aeson
, bytestring , bytestring
, containers , containers
, haskus-utils-variant , haskus-utils-variant
@@ -376,19 +348,6 @@ executable ghcup
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_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 executable ghcup-gen
import: import:
@@ -414,7 +373,6 @@ executable ghcup-gen
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
, versions , versions
, yaml
-- --
main-is: Main.hs main-is: Main.hs

View File

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

View File

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

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 #-} {-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Module for handling all download related functions.
Generally we support downloading via:
- curl (default)
- wget
- internal downloader (only when compiled)
-}
module GHCup.Download where module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
@@ -52,7 +35,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.Aeson import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI ) import Data.CaseInsensitive ( CI )
@@ -68,7 +50,7 @@ import Data.Versions
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
import HPath.IO as HIO hiding ( hideError ) import HPath.IO as HIO
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
@@ -89,7 +71,6 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
#endif #endif
import qualified Data.Text.Encoding as E 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.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory import qualified System.Posix.RawFilePath.Directory
as RD as RD
@@ -105,7 +86,7 @@ import qualified System.Posix.RawFilePath.Directory
-- | Like 'getDownloads', but tries to fall back to -- | 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 getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
, FromJSON VersionInfo , FromJSON VersionInfo
@@ -137,13 +118,13 @@ getDownloadsF urlSource = do
[i|Could not get download info, trying cached version (this may not be recent!)|] [i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL let path = view pathL' ghcupURL
cacheDir <- liftIO $ ghcupCacheDir cacheDir <- liftIO $ ghcupCacheDir
yaml_file <- (cacheDir </>) <$> urlBaseName path json_file <- (cacheDir </>) <$> urlBaseName path
bs <- bs <-
handleIO' NoSuchThing handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file)) (\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
$ liftIO $ liftIO
$ readFile yaml_file $ readFile json_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) lE' JSONDecodeError $ eitherDecode' bs
-- | Downloads the download information! But only if we need to ;P -- | Downloads the download information! But only if we need to ;P
@@ -164,10 +145,10 @@ getDownloads urlSource = do
case urlSource of case urlSource of
GHCupURL -> do GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do (OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av (OwnSpec av) -> pure $ av
where where
@@ -289,10 +270,7 @@ getDownloadInfo :: Tool
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
(Left NoDownload) (Left NoDownload)
Right Right
(case p of (with_distro <|> without_distro_ver <|> without_distro)
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro)
where where
with_distro = distro_preview id id with_distro = distro_preview id id

View File

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

View File

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

View File

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

View File

@@ -2,15 +2,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types
Description : GHCup types
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Types where module GHCup.Types where
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
@@ -99,12 +90,6 @@ data Tag = Latest
data Architecture = A_64 data Architecture = A_64
| A_32 | A_32
| A_PowerPC
| A_PowerPC64
| A_Sparc
| A_Sparc64
| A_ARM
| A_ARM64
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
@@ -161,7 +146,6 @@ data Settings = Settings
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool
} }
deriving Show deriving Show

View File

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

View File

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

View File

@@ -6,18 +6,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
module GHCup.Utils module GHCup.Utils
( module GHCup.Utils.Dirs ( module GHCup.Utils.Dirs
, module GHCup.Utils , module GHCup.Utils
@@ -35,9 +24,6 @@ import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
@@ -56,7 +42,7 @@ import Data.Versions
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
import HPath.IO hiding ( hideError ) import HPath.IO
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
@@ -72,18 +58,12 @@ import System.Posix.Files.ByteString ( readSymbolicLink )
import Text.Regex.Posix import Text.Regex.Posix
import URI.ByteString import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar as Tar
#endif
import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map 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 Data.Text.Encoding as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
@@ -104,7 +84,7 @@ ghcLinkDestination tool ver =
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool "../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- e.g. ghc-8.6.5
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do rmMinorSymlinks GHCTargetVersion {..} = do
bindir <- liftIO $ ghcupBinDir bindir <- liftIO $ ghcupBinDir
@@ -123,7 +103,7 @@ rmMinorSymlinks GHCTargetVersion {..} = do
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- | Removes the set ghc version for the given target, if any. -- Removes the set ghc version for the given target, if any.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Maybe Text -- ^ target => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@@ -142,7 +122,7 @@ rmPlain target = do
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- e.g. ghc-8.6
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m) rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> m () -> m ()
@@ -173,21 +153,18 @@ rmMajorSymlinks GHCTargetVersion {..} = do
----------------------------------- -----------------------------------
-- | Whethe the given GHC versin is installed.
ghcInstalled :: GHCTargetVersion -> IO Bool ghcInstalled :: GHCTargetVersion -> IO Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: GHCTargetVersion -> IO Bool ghcSrcInstalled :: GHCTargetVersion -> IO Bool
ghcSrcInstalled ver = do ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile) doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadThrow m, MonadIO m) ghcSet :: (MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
@@ -233,7 +210,6 @@ getInstalledGHCs = do
Left _ -> pure $ Left f Left _ -> pure $ Left f
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: IO [Either (Path Rel) Version] getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir bindir <- liftIO $ ghcupBinDir
@@ -248,14 +224,12 @@ getInstalledCabals = do
pure $ maybe vs (\x -> Right x:vs) cs pure $ maybe vs (\x -> Right x:vs) cs
-- | Whether the given cabal version is installed.
cabalInstalled :: Version -> IO Bool cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers pure $ elem ver $ vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet = do cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
@@ -274,13 +248,11 @@ cabalSet = do
----------------------------------------- -----------------------------------------
--[ Major version introspection (X.Y) ]-- --[ Major version introspection (X.Y) ]--
----------------------------------------- -----------------------------------------
-- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int) getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of getMajorMinorV Version {..} = case _vChunks of
([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y) ([Digits x] : [Digits y] : _) -> pure (fromIntegral x, fromIntegral y)
@@ -338,43 +310,25 @@ getLatestGHCFor major' minor' dls = do
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m) unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir => Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path -> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive -> Excepts '[UnknownArchive] m ()
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
unpackToDir dest av = do unpackToDir dest av = do
fp <- (decUTF8Safe . toFilePath) <$> basename av fp <- (decUTF8Safe . toFilePath) <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|] lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av fn <- toFilePath <$> basename av
let untar = Tar.unpack (toFilePath dest) . Tar.read
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
#endif
#if defined(TAR)
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
#else
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
#endif
rf = liftIO . readFile
-- extract, depending on file extension -- extract, depending on file extension
if if
| ".tar.gz" `B.isSuffixOf` fn -> liftE | ".tar.gz" `B.isSuffixOf` fn -> liftIO
(untar . GZip.decompress =<< rf av) (untar . GZip.decompress =<< readFile av)
| ".tar.xz" `B.isSuffixOf` fn -> do | ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftE $ rf av filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed liftIO $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn -> | ".tar.bz2" `B.isSuffixOf` fn -> liftIO
liftE (untar . BZip.decompress =<< rf av) (untar . BZip.decompress =<< readFile av)
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av) | ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn | otherwise -> throwE $ UnknownArchive fn
@@ -434,12 +388,11 @@ urlBaseName :: MonadThrow m
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@ -- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix. -- while ignoring *-<ver> symlinks and accounting for cross triple prefix.
-- --
-- Returns unversioned relative files, e.g.: -- Returns unversioned relative files, e.g.:
-- -- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
@@ -464,42 +417,26 @@ ghcToolFiles ver = do
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString) ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
) )
let ghcbinPath = bindir </> ghcbin (Just symver) <-
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath (B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
onlyUnversioned <- if ghcIsHadrian <$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> ghcbin))
then pure id when (B.null symver)
else do (throwIO $ userError $ "Fatal: ghc symlink target is broken")
(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)
pure $ onlyUnversioned files pure . filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) $ 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
-- | 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. -- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|] ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make. -- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader Settings m) make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|]) has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
let mymake = if has_gmake then "gmake" else "make" let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing execLogged mymake True args [rel|ghc-make|] workdir Nothing
@@ -524,7 +461,6 @@ applyPatches pdir ddir = do
!? PatchFailed !? PatchFailed
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ()) darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec darwinNotarization Darwin path = exec
"xattr" "xattr"

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

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

View File

@@ -1,48 +1,37 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where module GHCup.Utils.File where
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate ) import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable import Data.Foldable
import Data.Functor import Data.Functor
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.Sequence ( Seq, (|>) )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Void import Data.Void
import Data.Word8 import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
import HPath.IO hiding ( hideError ) import HPath.IO
import Optics hiding ((<|), (|>)) import Optics
import Streamly
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.Console.Pretty import System.Console.Pretty
import System.Console.Regions import System.Console.Regions
import System.IO
import System.IO.Error import System.IO.Error
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
import System.Posix.FD as FD import System.Posix.FD as FD
@@ -56,20 +45,31 @@ import Text.Regex.Posix
import qualified Control.Exception as EX import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified System.Posix.Process.ByteString import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import Streamly.External.Posix.DirStream 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 Streamly.Prelude as S
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified "unix-bytestring" System.Posix.IO.ByteString import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB 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] data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString] | PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString] | PStopped ByteString [ByteString]
@@ -87,6 +87,25 @@ data CapturedProcess = CapturedProcess
makeLenses ''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. -- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored. -- Relative paths in PATH are ignored.
-- --
@@ -114,156 +133,110 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) execLogged :: ByteString -- ^ thing to execute
=> ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing -> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing -> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename -> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ()) -> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
Settings {..} <- ask ldir <- ghcupLogsDir
ldir <- liftIO ghcupLogsDir logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log") bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd
(action verbose)
where where
action verbose fd = do action fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout -- start the thread that logs to stdout in a region
pState <- newEmptyMVar done <- newEmptyMVar
done <- newEmptyMVar tid <-
void forkIO
$ forkIO $ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ()) $ flip finally (putMVar done ())
$ (if verbose $ printToRegion fd stdoutRead 6
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
-- fork the subprocess -- fork our subprocess
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite closeFd stdoutWrite
closeFd stdoutRead
-- execute the action -- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env SPPB.executeFile exe spath args env
closeFd stdoutWrite closeFd stdoutWrite
-- wait for the subprocess to finish -- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid e <- SPPB.getProcessStatus True True pid >>= \case
putMVar pState (either (const False) (const True) e) 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 closeFd stdoutRead
pure e pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area -- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file. -- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO () printToRegion fileFd fdIn size = do
printToRegion fileFd fdIn size pState = do ref <- newIORef ([] :: [ByteString])
void $ displayConsoleRegions $ do displayConsoleRegions $ do
rs <- rs <- sequence . replicate size . openConsoleRegion $ Linear
liftIO flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle $ handle
(\(ex :: SomeException) -> do (\(StopThread b) -> do
ps <- liftIO $ takeMVar pState when b (forM_ rs closeConsoleRegion)
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion)) EX.throw (StopThread b)
throw ex
) )
$ readTilEOF (lineAction rs) fdIn $ do
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
-- wait for explicit stop from the parent to signal what cleanup to run
forever (threadDelay 5000)
where where
-- action to perform line by line -- action to perform line by line
-- TODO: do this with vty for efficiency lineAction ref rs bs' = do
lineAction :: (MonadMask m, MonadIO m) modifyIORef' ref (swapRegs bs')
=> Seq ConsoleRegion regs <- readIORef ref
-> ByteString void $ SPIB.fdWrite fileFd (bs' <> "\n")
-> StateT (Seq ByteString) m () forM (zip regs rs) $ \(bs, r) -> do
lineAction rs = \bs' -> do setConsoleRegion r $ do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n") w <- consoleWidth
modify (swapRegs bs') return
regs <- get . T.pack
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do . color Blue
w <- consoleWidth . T.unpack
return . decUTF8Safe
. T.pack . trim w
. color Blue . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
. T.unpack $ bs
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a swapRegs bs regs | length regs < size = regs ++ [bs]
swapRegs bs = \regs -> if | otherwise = tail regs ++ [bs]
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width -- trim output line to terminal width
trim :: Int -> ByteString -> ByteString trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
trim w = \bs -> if | otherwise = bs
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit -- read an entire line from the file descriptor (removes the newline char)
-- newline or EOF. readLine fd' = do
readLine :: MonadIO m bs <- SPIB.fdRead fd' 1
=> Fd -- ^ input file descriptor if
-> ByteString -- ^ rest buffer (read across newline) | bs == "\n" -> pure ""
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof) | bs == "" -> pure ""
readLine fd = \inBs -> go inBs | otherwise -> fmap (bs <>) $ readLine fd'
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m () readTilEOF action' fd' = do
readTilEOF ~action' fd' = go mempty bs <- readLine fd'
where void $ action' bs
go bs' = do readTilEOF action' fd'
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which -- | Capture the stdout and stderr of the given action, which
@@ -300,12 +273,13 @@ captureOutStreams action = do
done <- newEmptyMVar done <- newEmptyMVar
_ <- _ <-
forkIO forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ()) $ flip finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr $ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPPB.getProcessStatus True True pid status <- SPPB.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3)) takeMVar done
case status of case status of
-- readFd will take care of closing the fd -- readFd will take care of closing the fd
@@ -325,13 +299,13 @@ captureOutStreams action = do
void void
$ forkIO $ forkIO
$ hideError eofErrorType $ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ()) $ flip finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout $ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
doneErr <- newEmptyMVar doneErr <- newEmptyMVar
void void
$ forkIO $ forkIO
$ hideError eofErrorType $ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ()) $ flip finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr $ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
takeMVar doneOut takeMVar doneOut
takeMVar doneErr takeMVar doneErr
@@ -384,6 +358,14 @@ toProcessError exe args mps = case mps of
Nothing -> Left $ NoSuchPid 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. -- | Search for a file in the search paths.
-- --
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`. -- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -1,15 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Version
Description : Static version information
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Version where module GHCup.Version where
import GHCup.Utils.Version.QQ import GHCup.Utils.Version.QQ
@@ -20,14 +11,12 @@ import URI.ByteString.QQ
import qualified Data.Text as T 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
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 :: PVP
ghcUpVer = [pver|0.1.8|] ghcUpVer = [pver|0.1.5|]
-- | ghcup version as numeric string.
numericVer :: String numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer numericVer = T.unpack . prettyPVP $ ghcUpVer

View File

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

View File

@@ -46,9 +46,6 @@
<p> <p>
To install Haskell, follow the instructions on To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a> <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>
<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> <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> </div>
@@ -58,9 +55,6 @@
To install Haskell, follow the instructions on To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a> <a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p> </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> <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> </div>
@@ -83,7 +77,7 @@
<!-- duplicate the default cross-platform instructions --> <!-- duplicate the default cross-platform instructions -->
<div> <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> <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> <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> </div>
@@ -101,7 +95,7 @@
<div id="platform-instructions-default" class="instructions"> <div id="platform-instructions-default" class="instructions">
<div> <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> 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> <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> <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 id="platform-instructions-default" class="instructions">
<div> <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> 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> <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> <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>