Compare commits

...

42 Commits

Author SHA1 Message Date
14168a41fe Lala 2020-08-27 23:39:47 +02:00
6342e8edf0 Use 8.10.2 in gitlab CI 2020-08-15 23:54:50 +02:00
bbd8f0c84c Add GHC-8.10.2 for alpine 32big 2020-08-15 23:34:05 +02:00
873c951d6e Refactor chmod +x 2020-08-14 22:27:05 +02:00
d9c864d3c5 Make sure cabal is executable wrt #46 2020-08-14 22:07:39 +02:00
4280d7109a Fix 3.4.0.0-rc1 urls wrt #46 2020-08-14 21:49:01 +02:00
c8855c068f Update version in bootstrap-haskell 2020-08-14 20:36:14 +02:00
90503061e9 Add ghcup-0.1.10 2020-08-14 20:22:27 +02:00
672ebf6426 Bump version 2020-08-14 16:57:15 +02:00
fd76fde23a Add cabal-3.4.0.0-rc1 2020-08-14 16:54:27 +02:00
e24c9a3ffe Show stray cabals, fixes #45 2020-08-14 16:53:32 +02:00
2641d50c21 Update ghcup binaries 2020-08-14 09:42:41 +02:00
202f3ea3ba Fix bug where setting non-installed GHC unsets current one 2020-08-13 20:40:09 +02:00
4f09e3ff7e Update CHANGELOG 2020-08-13 17:01:09 +02:00
1148219130 Fix README 2020-08-12 10:13:18 +02:00
4b47800dfb CHANGELOG fix 2020-08-11 22:38:22 +02:00
e2c4db9132 Rm unneeded note 2020-08-11 22:04:08 +02:00
90af68b211 Pre-release 0.1.9 2020-08-11 21:55:15 +02:00
80603662b4 Merge branch 'cabal-install-3.4.0.0-rc1' 2020-08-11 21:34:45 +02:00
d2c5d4dfd9 Test that we're not missing GHCup alpine 2020-08-11 20:23:15 +02:00
6f1b8b4041 Fix build on 32bit 2020-08-11 19:47:29 +02:00
f63b2bf744 Fix CI 2020-08-11 11:48:42 +02:00
71cb75c170 Update .gitignore 2020-08-10 22:28:02 +02:00
dac64f5718 Make TarDir backwardscompat 2020-08-10 22:28:02 +02:00
27b2d2ac7d Fix cabal.project for cabal-3.4 2020-08-10 22:28:01 +02:00
47142dd376 Test on 32bit 2020-08-10 22:28:01 +02:00
d071a7e51b Avoid duplicate edits to .bashrc etc 2020-08-10 22:28:01 +02:00
5c45884f5f Allow to specify regex for subdir 2020-08-10 22:27:50 +02:00
cafedd73a2 Use Settings to avoid querying dirs every time 2020-08-10 21:52:30 +02:00
7163b77837 Only query directories once 2020-08-10 21:51:31 +02:00
122c54b51e Refactor 2020-08-10 21:51:31 +02:00
b9d7d7d007 Fix licences in module haddock 2020-08-10 21:51:29 +02:00
9050c9792a Improve bootstrap-haskell 2020-08-10 21:51:20 +02:00
aac8f760ad Add xdg support wrt #39 2020-08-10 21:51:19 +02:00
7d334c18f5 Don't stop TUI on subcommand failure 2020-08-10 21:51:19 +02:00
86b0e4b31b Fix cabalSet for pre-release versions 2020-08-10 21:51:19 +02:00
af811f3dbc nub result in getInstalledCabals 2020-08-10 21:51:19 +02:00
d30d2ac8a5 Add cabal-install-3.4.0.0-rc1 2020-08-10 21:51:00 +02:00
86a4b10de6 Merge branch 'yaml' 2020-08-10 08:58:55 +02:00
cfa7049ab9 Merge branch 'CI' 2020-08-09 22:11:48 +02:00
391676e90a Use yaml instead of pesky json 2020-08-09 21:56:11 +02:00
a046f16308 Remove libtinfo compat symlinks 2020-07-21 00:36:31 +02:00
37 changed files with 2375 additions and 5467 deletions

1
.gitignore vendored
View File

@@ -12,3 +12,4 @@ tags
TAGS
/tmp/
.entangled
release/

View File

@@ -14,6 +14,7 @@ variables:
- x86_64-linux
variables:
OS: "LINUX"
BIT: "64"
.alpine:64bit:
image: "alpine:edge"
@@ -36,12 +37,14 @@ variables:
- x86_64-darwin
variables:
OS: "DARWIN"
BIT: "64"
.freebsd:
tags:
- x86_64-freebsd
variables:
OS: "FREEBSD"
BIT: "64"
.root_cleanup:
after_script:
@@ -66,6 +69,13 @@ variables:
before_script:
- ./.gitlab/before_script/linux/install_deps.sh
.test_ghcup_version:linux32:
extends:
- .test_ghcup_version
- .alpine:32bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
.test_ghcup_version:darwin:
extends:
- .test_ghcup_version
@@ -103,10 +113,17 @@ test:linux:recommended:
test:linux:latest:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
######## linux 32bit test ########
test:linux:recommended:32bit:
extends: .test_ghcup_version:linux32
variables:
GHC_VERSION: "8.8.4"
CABAL_VERSION: "3.2.0.0"
######## darwin test ########
@@ -119,7 +136,7 @@ test:mac:recommended:
test:mac:latest:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -135,7 +152,7 @@ test:freebsd:recommended:
test:freebsd:latest:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true

View File

@@ -18,10 +18,6 @@ apk add --no-cache \
tar \
perl
ln -sf libncurses.so /usr/lib/libtinfo.so
ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6
ln -sf libtinfow.so.6 /usr/lib/libtinfow.so
if [ "${BIT}" = "32" ] ; then
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
else
@@ -49,5 +45,3 @@ apk add --no-cache \
xz-dev \
ncurses-static
ln -sf libncursesw.a /usr/lib/libtinfow.a

View File

@@ -11,7 +11,7 @@ ecabal() {
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
@@ -22,14 +22,20 @@ ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
ecabal haddock
ecabal haddock -w ghc-${GHC_VERSION} -ftar
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 -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
@@ -42,7 +48,7 @@ rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
### manual cli based testing
ghcup-gen check -f ghcup-${JSON_VERSION}.json
ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
eghcup --numeric-version

View File

@@ -1,5 +1,21 @@
# Revision history for ghcup
## 0.1.10 -- 2020-08-14
* Show stray Cabals (useful for pre-releases or compiled ones)
## 0.1.9 -- 2020-08-14
* Fix bug when uninstalling all cabal versions
* Fix bug when setting a non-installed ghc version as current default
* Use yaml instead of generated json for download info for ease of adding new GHC versions #44
* Allow pre-release versions of GHC/cabal
* Add XDG dirs support (set `GHCUP_USE_XDG_DIRS`) wrt #39
* Allow to specify regex for tarball subdir (e.g. `ghc-.*`)
* Allow installing arbitrary bindists more seamlessly:
- e.g. installing GHC HEAD: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head`
* Avoid duplicate edits to .bashrc/.zshrc wrt #43
## 0.1.8 -- 2020-07-21
* Fix bug in logging thread dying on newlines

View File

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

View File

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

View File

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

View File

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

View File

@@ -14,8 +14,10 @@ import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Brick
import Brick.BChan
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
@@ -23,11 +25,14 @@ import Brick.Widgets.List
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.ByteString ( ByteString )
import Data.Functor
import Data.List
import Data.Maybe
@@ -37,22 +42,40 @@ import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import HPath
import HPath.IO hiding ( hideError )
import Prelude hiding ( abs, appendFile, writeFile )
import System.Exit
import System.IO.Unsafe
import System.Posix.Types
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data SubProcess = SubProcess {
procName :: String
, exited :: Maybe (Either ProcessError ())
, procId :: Maybe ProcessID
, logLine :: Maybe ByteString
}
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
, mproc :: Maybe SubProcess
}
data MyAppEvent = LogLine ByteString
| StartProc String
| GotProcId ProcessID
| EndProc (Either ProcessError ())
type LR = GenericList String Vector ListResult
@@ -68,21 +91,28 @@ keyHandlers =
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)
)
case mproc of
Just _ -> logDialog
Nothing ->
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
where
logDialog = case mproc of
Nothing -> emptyWidget
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ ""
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
@@ -112,6 +142,7 @@ ui AppState {..} =
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
@@ -120,7 +151,7 @@ minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String
app :: App AppState MyAppEvent String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
@@ -137,6 +168,7 @@ defaultAttributes = attrMap
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
@@ -150,19 +182,33 @@ dimAttributes = attrMap
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls pfreq)
continue (AppState (listMoveUp lr) dls pfreq mproc)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls pfreq)
continue (AppState (listMoveDown lr) dls pfreq mproc)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
eventHandler st (AppEvent (StartProc str')) = continue st
{ mproc = Just SubProcess { procName = str'
, exited = Nothing
, procId = Nothing
, logLine = Nothing
}
}
eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) =
continue st { mproc = Just sp { procId = Just pid } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) =
continue st { mproc = Just sp { exited = Just exited, procId = Nothing } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) =
continue st { mproc = Just sp { logLine = Just bs } }
eventHandler st (AppEvent _) = error "noes" -- TODO
eventHandler st _ = continue st
-- | Suspend the current UI and run an IO action in terminal. If the
@@ -172,20 +218,18 @@ withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> 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
Just (ix, e) -> do
liftIO $ forkIO $ void $ action as (ix, e)
continue as
-- apps <- (fmap . fmap)
-- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
-- $ getAppState Nothing (pfreq as)
-- case apps of
-- Right nas -> do
-- putStrLn "Press enter to continue"
-- _ <- getLine
-- pure nas
-- Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
@@ -213,7 +257,9 @@ install' AppState {..} (_, ListResult {..}) = do
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate]
, NoUpdate
, TarDirDoesNotExist
]
(run $ do
case lTool of
@@ -296,14 +342,16 @@ uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings
{-# NOINLINE settings' #-}
settings' = unsafePerformIO
(newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
}
)
settings' = unsafePerformIO $ do
dirs <- getDirs
newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
, execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'")
, ..
}
logger' :: IORef LoggerConfig
@@ -317,16 +365,22 @@ logger' = unsafePerformIO
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l av pfreq' = do
brickMain _ muri _ av pfreq' = do
writeIORef uri' muri
writeIORef settings' s
s <- readIORef settings'
-- logger interpreter
writeIORef logger' l
-- writeIORef logger' l
l <- readIORef logger'
let runLogger = myLoggerT l
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> defaultMain app (selectLatest as) $> ()
Right as -> do
eventChan <- newBChan 1000
let builder = Vty.mkVty Vty.defaultConfig
initialVty <- builder
writeIORef settings' s{ execCb = brickExecCb eventChan }
customMain initialVty builder (Just eventChan) app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
@@ -355,8 +409,25 @@ getAppState mg pfreq' = 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')
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]
brickExecCb :: BChan MyAppEvent -> ExecCb
brickExecCb chan _ fileFd stdoutRead pState lfile = do
liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb"
writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile)
readLineTilEOF lineAction stdoutRead
takeMVar pState >>= \case
PExited e@(Left _) -> writeBChan chan (EndProc e)
_ -> error "no"
where
lineAction bs = do
void $ SPIB.fdWrite fileFd (bs <> "\n")
error "blah"
writeBChan chan (LogLine bs)

View File

@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -403,7 +404,11 @@ installParser =
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install GHC head
ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head|]
installOpts :: Parser InstallOptions
@@ -427,7 +432,7 @@ installOpts =
<> long "url"
<> metavar "BINDIST_URL"
<> help
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
)
)
)
@@ -818,14 +823,15 @@ bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString
toSettings :: Options -> Settings
toSettings Options {..} =
toSettings :: Options -> IO Settings
toSettings Options {..} = do
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
in Settings { .. }
dirs <- getDirs
pure $ Settings { execCb = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..}
upgradeOptsP :: Parser UpgradeOpts
@@ -901,14 +907,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
let settings@Settings{..} = toSettings opt
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir
ghcdir <- ghcupBaseDir
createDirIfMissing newDirPerms ghcdir
createDirRecursive newDirPerms baseDir
-- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|]
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
@@ -939,6 +944,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
, DigestError
, DownloadFailed
, TarDirDoesNotExist
]
let
@@ -954,12 +960,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runSetCabal =
runLogger
. flip runReaderT settings
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runLogger
let runListGHC = runLogger . flip runReaderT settings
let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -984,6 +991,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -1003,6 +1011,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -1052,7 +1061,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case optCommand of
Upgrade _ _ -> pure ()
_ -> runLogger $ checkForUpdates dls pfreq
_ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq
@@ -1079,7 +1088,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
@@ -1092,7 +1101,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 3
@@ -1121,7 +1130,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
@@ -1237,9 +1246,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs|])
Check the logs at #{logsDir}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 9
VLeft e -> do
@@ -1261,7 +1270,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 10
VLeft e -> do
@@ -1275,9 +1284,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|]))
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do
@@ -1422,13 +1429,14 @@ printListResult raw lr = do
where
printTag Recommended = color' Green "recommended"
printTag Latest = color' Yellow "latest"
printTag Prerelease = color' Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
color' = case raw of
True -> flip const
False -> color
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> PlatformRequest
-> m ()

View File

@@ -4,6 +4,17 @@
(
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
export GHCUP_USE_XDG_DIRS
if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local}/ghcup
GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
else
GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
fi
: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
@@ -29,10 +40,26 @@ _eghcup() {
fi
}
_done() {
echo
echo "All done!"
echo
echo "To start a simple repl, run:"
echo " ghci"
echo
echo "To start a new haskell project in the current directory, run:"
echo " cabal init --interactive"
echo
echo "To install other GHC versions, run:"
echo " ghcup tui"
exit 0
}
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.8"
_ghver="0.1.10"
_base_url="https://downloads.haskell.org/~ghcup"
case "${_plat}" in
@@ -83,15 +110,15 @@ download_ghcup() {
;;
esac
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
edo chmod +x "${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"
cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
EOF
# shellcheck disable=SC1090
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
edo . "${GHCUP_DIR}"/env
eghcup upgrade
unset _plat _arch _url _ghver _base_url
@@ -102,12 +129,19 @@ echo
echo "Welcome to Haskell!"
echo
echo "This script will download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer (for managing GHC/cabal versions)"
echo " * ghcup - The Haskell toolchain installer"
echo " (for managing GHC/cabal versions)"
echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool"
echo
echo "ghcup installs only into the following directory, which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo "ghcup installs only into the following directory,"
echo "which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
else
echo "ghcup installs into XDG directories as long as"
echo "'GHCUP_USE_XDG_DIRS' is set."
fi
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
@@ -119,7 +153,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
edo mkdir -p "${GHCUP_BIN}"
if command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
@@ -156,7 +190,7 @@ printf "\\033[0;35m%s\\033[0m\\n" ""
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
echo "You may want to source '$GHCUP_DIR/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
case $SHELL in
@@ -174,13 +208,13 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh"
else
exit 0
_done
fi
;;
*/fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;;
*) exit 0 ;;
*) _done ;;
esac
@@ -198,18 +232,24 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
case $MY_SHELL in
"") break ;;
fish)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env ; and set -gx PATH \$HOME/.cabal/bin \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
*)
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
esac
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
exit 0;;
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
_done
;;
[Nn]*)
exit 0;;
_done ;;
*)
echo "Please type YES or NO and press enter.";;
esac

View File

@@ -19,6 +19,6 @@ package ghcup
constraints: http-io-streams -brotli
package libarchive
flags: static
flags: +static
allow-newer: base ghc-prim template-haskell
allow-newer: base, ghc-prim, template-haskell

File diff suppressed because it is too large Load Diff

1354
ghcup-0.0.2.yaml Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.8
version: 0.1.10
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -112,7 +112,7 @@ common io-streams
build-depends: io-streams >=1.5
common libarchive
build-depends: libarchive >= 2.2.5.2
build-depends: libarchive >= 2.2.5.0
common lzma
build-depends: lzma >=0.0.0.3
@@ -153,6 +153,9 @@ common safe
common safe-exceptions
build-depends: safe-exceptions >=0.1
common split
build-depends: split >=0.2.3.4
common streamly
build-depends: streamly >=0.7.1
@@ -219,6 +222,9 @@ common vty
common word8
build-depends: word8 >=0.1.3
common yaml
build-depends: yaml >=0.11.4.0
common zlib
build-depends: zlib >=0.6.2.1
@@ -273,6 +279,7 @@ library
, resourcet
, safe
, safe-exceptions
, split
, streamly
, streamly-posix
, streamly-bytestring
@@ -291,13 +298,11 @@ library
, vector
, versions
, word8
, yaml
, zlib
exposed-modules:
GHCup
GHCup.Data.GHCupDownloads
GHCup.Data.GHCupInfo
GHCup.Data.ToolRequirements
GHCup.Download
GHCup.Download.Utils
GHCup.Errors
@@ -359,6 +364,7 @@ executable ghcup
, table-layout
, template-haskell
, text
, unix-bytestring
, uri-bytestring
, utf8-string
, versions
@@ -413,6 +419,7 @@ executable ghcup-gen
, uri-bytestring
, utf8-string
, versions
, yaml
--
main-is: Main.hs

View File

@@ -15,7 +15,7 @@
Module : GHCup
Description : GHCup installation functions
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -112,6 +112,7 @@ installGHCBindist :: ( MonadFail m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -121,7 +122,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ ghcInstalled tver)
whenM (lift $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version)
@@ -133,10 +134,10 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
ghcdir <- liftIO $ ghcupGHCDir tver
ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
@@ -153,7 +154,6 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ make ["install"] (Just path)
@@ -189,6 +189,7 @@ installGHCBin :: ( MonadFail m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -221,6 +222,7 @@ installCabalBindist :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -230,14 +232,14 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
Settings {dirs = Dirs {..}} <- lift ask
whenM
(liftIO $ cabalInstalled ver >>= \a ->
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal ver)
@@ -250,12 +252,12 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installCabal' workdir bindir
liftE $ installCabal' workdir binDir
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
@@ -270,12 +272,14 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
liftIO $ createDirIfMissing newDirPerms inst
liftIO $ createDirRecursive newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> destFileName)
(destPath)
Overwrite
lift $ chmod_777 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
@@ -300,6 +304,7 @@ installCabalBin :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -328,17 +333,25 @@ installCabalBin bDls ver pfreq = do
--
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
setGHC :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion
-> SetGHC
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver)
ghcdir <- liftIO $ ghcupGHCDir ver
ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
@@ -350,19 +363,26 @@ setGHC ver sghc = do
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do
targetFile <- case sghc of
SetGHCOnly -> pure file
mTargetFile <- case sghc of
SetGHCOnly -> pure $ Just file
SetGHC_XY -> do
major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi)
<$> getMajorMinorV (_tvVersion ver)
parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM v' $ \(mj, mi) ->
let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
in parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ ->
fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-- create symlink
let fullF = bindir </> targetFile
let destL = ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
forM mTargetFile $ \targetFile -> do
let fullF = binDir </> targetFile
destL <- lift $ ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
@@ -371,12 +391,13 @@ setGHC ver sghc = do
where
symlinkShareDir :: (MonadIO m, MonadLogger m)
symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m)
=> Path Abs
-> ByteString
-> m ()
symlinkShareDir ghcdir verBS = do
destdir <- liftIO $ ghcupBaseDir
Settings { dirs = Dirs {..} } <- ask
let destdir = baseDir
case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|]
@@ -393,7 +414,7 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
@@ -401,14 +422,14 @@ setCabal ver = do
targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
Settings {dirs = Dirs {..}} <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile))
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE
$ NotInstalled Cabal (prettyVer ver)
let cabalbin = bindir </> [rel|cabal|]
let cabalbin = binDir </> [rel|cabal|]
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
@@ -467,6 +488,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader Settings m
)
=> GHCupDownloads
-> Maybe Tool
@@ -478,13 +500,16 @@ listVersions av lt criteria pfreq = do
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq
@@ -493,7 +518,7 @@ listVersions av lt criteria pfreq = do
pure (ghcvers <> cabalvers <> ghcupvers)
where
strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m)
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
@@ -504,7 +529,7 @@ listVersions av lt criteria pfreq = do
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- liftIO $ ghcSrcInstalled tver
fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -517,7 +542,7 @@ listVersions av lt criteria pfreq = do
}
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- liftIO $ ghcSrcInstalled tver
fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -533,8 +558,35 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayCabals avTools = do
cabals <- getInstalledCabals
fmap catMaybes $ forM cabals $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== ver)) $ cabalSet
pure $ Just $ ListResult
{ lTool = Cabal
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
@@ -587,64 +639,73 @@ listVersions av lt criteria pfreq = do
-- 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 :: ( MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadFail m
, MonadCatch m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir
isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
dir <- lift $ ghcupGHCDir ver
if exists
then do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain (_tvTarget ver)
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
(mj, mi) <- getMajorMinorV (_tvVersion ver)
getGHCForMajor mj mi (_tvTarget ver) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
liftIO
$ ghcupBaseDir
>>= hideError doesNotExistErrorType
. deleteFile
. (</> [rel|share|])
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
Settings { dirs = Dirs {..} } <- lift ask
liftIO
$ hideError doesNotExistErrorType
$ deleteFile
$ (baseDir </> [rel|share|])
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled GHC (prettyVer ver))
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver))
cSet <- liftIO cabalSet
cSet <- lift $ cabalSet
Settings {dirs = Dirs {..}} <- lift ask
bindir <- liftIO ghcupBinDir
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals
cVers <- lift $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> [rel|cabal|])
(binDir </> [rel|cabal|])
@@ -653,18 +714,19 @@ rmCabalVer ver = do
------------------
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
diBaseDir <- liftIO $ ghcupBaseDir
diBinDir <- liftIO $ ghcupBinDir
diGHCDir <- liftIO $ ghcupGHCBaseDir
diCacheDir <- liftIO $ ghcupCacheDir
diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
Settings {dirs = Dirs {..}} <- lift ask
let diBaseDir = baseDir
let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir
let diCacheDir = cacheDir
diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
pure $ DebugInfo { .. }
@@ -703,6 +765,7 @@ compileGHC :: ( MonadMask m
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -711,7 +774,7 @@ compileGHC :: ( MonadMask m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver)
whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
-- download source tarball
@@ -728,8 +791,8 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction
tmpUnpack
@@ -793,7 +856,6 @@ Stage1Only = YES|]
)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
@@ -809,7 +871,6 @@ Stage1Only = YES|]
)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just cEnv)
@@ -883,6 +944,7 @@ compileCabal :: ( MonadReader Settings m
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -892,14 +954,14 @@ compileCabal :: ( MonadReader Settings m
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir
Settings {dirs = Dirs {..}} <- lift ask
whenM
(liftIO $ cabalInstalled tver >>= \a ->
(lift (cabalInstalled tver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal tver)
@@ -912,18 +974,18 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin
(bindir </> destFileName)
(binDir </> destFileName)
Overwrite
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
@@ -966,7 +1028,6 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap|]
(Just workdir)
(Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])
@@ -1004,6 +1065,7 @@ upgradeGHCup :: ( MonadMask m
m
Version
upgradeGHCup dls mtarget force pfreq = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
@@ -1011,18 +1073,12 @@ upgradeGHCup dls mtarget force pfreq = do
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
p <- liftE $ download dli tmp (Just fn)
let fileMode' =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
binDir <- liftIO $ ghcupBinDir
let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
lift $ chmod_777 fullDest
pure latestVer
@@ -1034,13 +1090,24 @@ upgradeGHCup dls mtarget force pfreq = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
postGHCInstall :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion{..} = do
postGHCInstall ver@GHCTargetVersion {..} = do
void $ liftE $ setGHC ver SetGHC_XYZ
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
(mj, mi) <- getMajorMinorV _tvVersion
getGHCForMajor mj mi _tvTarget >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
v' <-
handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

File diff suppressed because it is too large Load Diff

View File

@@ -1,20 +0,0 @@
{-|
Module : GHCup.Data.GHCupInfo
Description :
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
module GHCup.Data.GHCupInfo where
import GHCup.Data.GHCupDownloads
import GHCup.Data.ToolRequirements
import GHCup.Types
ghcupInfo :: GHCupInfo
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
, _ghcupDownloads = ghcupDownloads
}

View File

@@ -1,156 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Data.ToolRequirements
Description : Tool requirements
Copyright : (c) Julian Ospald, 2020
License : GPL-3
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
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

@@ -13,7 +13,7 @@
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -52,6 +52,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
@@ -88,6 +89,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
@@ -103,7 +105,7 @@ import qualified System.Posix.RawFilePath.Directory
-- | Like 'getDownloads', but tries to fall back to
-- cached ~/.ghcup/cache/ghcup-<format-ver>.json
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
@@ -131,17 +133,17 @@ getDownloadsF urlSource = do
(OwnSpec _) -> liftE $ getDownloads urlSource
where
readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path
yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO
$ readFile json_file
lE' JSONDecodeError $ eitherDecode' bs
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
-- | Downloads the download information! But only if we need to ;P
@@ -162,10 +164,10 @@ getDownloads urlSource = do
case urlSource of
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure $ av
where
@@ -198,8 +200,8 @@ getDownloads urlSource = do
m1
L.ByteString
smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file
if e
@@ -224,7 +226,7 @@ getDownloads urlSource = do
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do
liftIO $ createDirIfMissing newDirPerms cacheDir
liftIO $ createDirRecursive newDirPerms cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Nothing -> do
@@ -390,15 +392,15 @@ downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> do
cachedir <- liftIO $ ghcupCacheDir
Settings {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cachedir </> fn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure $ cachfile
| otherwise -> liftE $ download dli cachedir mfn
| otherwise -> liftE $ download dli cacheDir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn

View File

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

View File

@@ -7,7 +7,7 @@
Module : GHCup.Errors
Description : GHCup error types
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -89,6 +89,9 @@ data JSONError = JSONDecodeError String
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show

View File

@@ -10,7 +10,7 @@
Module : GHCup.Plaform
Description : Retrieving platform information
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -4,7 +4,7 @@
Module : GHCup.Requirements
Description : Requirements utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

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

View File

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

View File

@@ -4,7 +4,7 @@
Module : GHCup.Types.Optics
Description : GHCup optics
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -10,7 +10,7 @@
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -48,7 +48,9 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Split
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
@@ -97,20 +99,24 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion
-> ByteString
ghcLinkDestination tool ver =
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
-> m ByteString
ghcLinkDestination tool ver = do
Settings {dirs = Dirs {..}} <- ask
t <- parseRel tool
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do
bindir <- liftIO $ ghcupBinDir
Settings {dirs = Dirs {..}} <- ask
files <- liftIO $ findFiles'
bindir
binDir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
*> (MP.chunk $ prettyVer _tvVersion)
@@ -118,42 +124,41 @@ rmMinorSymlinks GHCTargetVersion {..} = do
)
forM_ files $ \f -> do
let fullF = (bindir </> f)
let fullF = (binDir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- | Removes the set ghc version for the given target, if any.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
rmPlain target = do
mtv <- ghcSet target
Settings {dirs = Dirs {..}} <- lift ask
mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do
let fullF = (bindir </> f)
let fullF = (binDir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (bindir </> [rel|haddock-ghc|])
let hdc_file = (binDir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion
-> m ()
rmMajorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ findFiles'
bindir
binDir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v')
*> MP.chunk v'
@@ -161,7 +166,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do
)
forM_ files $ \f -> do
let fullF = (bindir </> f)
let fullF = (binDir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@@ -174,59 +179,61 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-- | Whethe the given GHC versin is installed.
ghcInstalled :: GHCTargetVersion -> IO Bool
ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadThrow m, MonadIO m)
ghcSet :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
Settings {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
ghcBin <- (</> ghc) <$> liftIO ghcupBinDir
let ghcBin = binDir </> ghc
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "ghcLinkVersion" t
where
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "../ghc/"
*> (do
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
parser =
(do
_ <- parseUntil1 (MP.chunk "/ghc/")
_ <- MP.chunk "/ghc/"
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- liftIO $ ghcupGHCBaseDir
ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
@@ -234,43 +241,64 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir
Settings {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
bindir
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
pure $ maybe vs (\x -> Right x:vs) cs
pure $ maybe vs (\x -> nub $ Right x:vs) cs
-- | Whether the given cabal version is installed.
cabalInstalled :: Version -> IO Bool
cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c))
, _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
Settings {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink cabalbin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath cabalbin
Just <$> linkVersion link
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "cabal-" *> version'
@@ -295,7 +323,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadIO m, MonadThrow m)
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
@@ -352,17 +380,16 @@ unpackToDir dest av = do
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
rf = liftIO . readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
#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
#endif
-- extract, depending on file extension
if
@@ -378,6 +405,28 @@ unpackToDir dest av = do
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
RegexDir r -> do
let rs = splitOn "/" r
foldlM
(\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
------------
@@ -440,11 +489,11 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Returns unversioned relative files, e.g.:
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver
ghcdir <- lift $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed
@@ -501,7 +550,7 @@ make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing
execLogged mymake True args workdir Nothing
-- | Try to apply patches in order. Fails with 'PatchFailed'
@@ -553,24 +602,18 @@ runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
Settings {..} <- lift ask
v <- flip
onException
(do
let exAction = do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
)
v <-
flip onException exAction
$ catchAllE
(\es -> do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
exAction
throwE (BuildFailed bdir es)
)
$ action

View File

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

View File

@@ -2,12 +2,13 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -17,7 +18,6 @@ Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Types
@@ -26,6 +26,7 @@ import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
@@ -34,6 +35,7 @@ import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Void
import Data.Word8
@@ -47,6 +49,7 @@ import System.IO.Error
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
@@ -69,14 +72,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
@@ -118,31 +113,31 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
Settings {..} <- ask
ldir <- liftIO ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
execLogged exe spath args chdir env = do
Settings {dirs = Dirs {..}, ..} <- ask
logfile <- (logsDir </>) <$> parseRel (lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd
(action verbose)
(action verbose execCb)
where
action verbose fd = do
lfile = fromMaybe exe $ BS.stripPrefix "./" exe
action verbose cb fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
pState <- newEmptyMVar
done <- newEmptyMVar
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1"
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ (if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
$ (do
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
cb verbose fd stdoutRead pState lfile)
-- fork the subprocess
pid <- SPPB.forkProcess $ do
@@ -155,115 +150,57 @@ execLogged exe spath args lfile chdir env = do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env
putMVar pState (PRunning pid)
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
putMVar pState (either (const False) (const True) e)
void $ swapMVar pState (PExited e)
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readLineTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
printToRegion fileFd fdIn size pState = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
@@ -377,7 +314,7 @@ toProcessError :: ByteString
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
@@ -427,3 +364,97 @@ findFiles' path parser = do
Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream
pure $ join $ fmap parseRel f
isBrokenSymlink :: Path Abs -> IO Bool
isBrokenSymlink p =
handleIO
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
$ do
_ <- canonicalizePath p
pure False
chmod_777 :: (MonadLogger m, MonadIO m) => Path a -> m ()
chmod_777 (toFilePath -> fp) = do
let exe_mode =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
$(logDebug) [i|chmod 777 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- | The default callback for logging/printing on 'execLogged'.
defExecCb :: ExecCb
defExecCb verbose fd stdoutRead pState lfile = if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6
where
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readLineTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> IO ()
printToRegion fileFd fdIn size = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
let closeEventually = readMVar pState >>= \case
PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion)
_ -> threadDelay 500 >> closeEventually
void $ liftIO $ race closeEventually (threadDelay (1000000 * 3))
throw ex
)
$ readLineTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> lfile <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs

View File

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

View File

@@ -5,7 +5,7 @@
Module : GHCup.Utils.MegaParsec
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -12,7 +12,7 @@
Module : GHCup.Utils.Prelude
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -4,7 +4,7 @@
Module : GHCup.Utils.String.QQ
Description : String quasi quoters
Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -11,7 +11,7 @@
Module : GHCup.Utils.Version.QQ
Description : Version quasi-quoters
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX

View File

@@ -5,7 +5,7 @@
Module : GHCup.Version
Description : Static version information
Copyright : (c) Julian Ospald, 2020
License : GPL-3
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
@@ -20,13 +20,13 @@ import URI.ByteString.QQ
import qualified Data.Text as T
-- | This reflects the API version of the JSON.
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
-- | The curren ghcup version.
-- | The current ghcup version.
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.8|]
ghcUpVer = [pver|0.1.10|]
-- | ghcup version as numeric string.
numericVer :: String