diff --git a/.gitignore b/.gitignore
index 505a0dcca87da35d574e07b270aef55ba22e1599..7e8c03cb09301dec4fdac01a915e6a02b34b4498 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,3 +12,4 @@ tags
TAGS
/tmp/
.entangled
+release/
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 5495d6d011e9f23598afe53e69273d592963d0b6..d5c46ace1bc80e0b64089c325475f849da7ceb97 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -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
@@ -107,6 +117,13 @@ test:linux:latest:
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 ########
diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh
index 1c410a8b2d9cc9cbc062767489cbfb6f29d03326..baf3c555bee32155e8c7753f95a48d07cc753f50 100755
--- a/.gitlab/script/ghcup_version.sh
+++ b/.gitlab/script/ghcup_version.sh
@@ -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
diff --git a/README.md b/README.md
index 1f6cfc2a39334559381aee4656f1ad21f1509dea..a726d17955a090015ce69670d60e7260f7eadd64 100644
--- a/README.md
+++ b/README.md
@@ -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.
+### Cross 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
diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs
index bd1ee0e72c8009c9e751bd3bc2103cc2663e598a..9c4b7d0d9f7a7dfc8620e43451077189d3b4abbe 100644
--- a/app/ghcup-gen/Validate.hs
+++ b/app/ghcup-gen/Validate.hs
@@ -7,7 +7,9 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Types
+import GHCup.Utils.Dirs
import GHCup.Utils.Logger
+import GHCup.Utils.Version.QQ
import Control.Exception.Safe
import Control.Monad
@@ -88,6 +90,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 +122,7 @@ validate dls = do
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
+ isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
@@ -179,7 +191,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
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs
index 67eea69d5ec9eee8397c5886f324e6e2b12afeaf..b84397680a92297fe57548784b92b028dfc9b520 100644
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@@ -112,6 +112,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
@@ -137,6 +138,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)
]
@@ -173,19 +175,18 @@ withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
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
+ action as (ix, e) >>= \case
+ Left err -> putStrLn $ ("Error: " <> err)
+ Right _ -> putStrLn "Success"
+ 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 +214,9 @@ install' AppState {..} (_, ListResult {..}) = do
, TagNotFound
, DigestError
, DownloadFailed
- , NoUpdate]
+ , NoUpdate
+ , TarDirDoesNotExist
+ ]
(run $ do
case lTool of
@@ -296,14 +299,15 @@ uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings
{-# NOINLINE settings' #-}
-settings' = unsafePerformIO
- (newIORef Settings { cache = True
+settings' = unsafePerformIO $ do
+ dirs <- getDirs
+ newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
+ , ..
}
- )
logger' :: IORef LoggerConfig
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
index 7cb639d6d752eff0b20194dc7d97eb50ae9dd4ca..9116ae877803a7dca745149582f140afcfc30f40 100644
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -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 { .. }
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 ()
diff --git a/bootstrap-haskell b/bootstrap-haskell
index e968d2967367244d1b2450a3ca1f4ea1048c7f49..9afac86892f61fe399f81463319330ac28f48773 100755
--- a/bootstrap-haskell
+++ b/bootstrap-haskell
@@ -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,6 +40,22 @@ _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)
@@ -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
diff --git a/cabal.project b/cabal.project
index 4cd11a6b24b2050b012b380bf038beedb792f5bd..8412ed73c7bfb1591a19a078e12382aed352355b 100644
--- a/cabal.project
+++ b/cabal.project
@@ -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
diff --git a/ghcup-0.0.2.yaml b/ghcup-0.0.2.yaml
index cbf278aeb1201f173ebdaa29ce18db53fb3b7ba7..82eb2cac4a750678ddac99b7f1f2f36b9f8edfd3 100644
--- a/ghcup-0.0.2.yaml
+++ b/ghcup-0.0.2.yaml
@@ -1,3 +1,4 @@
+# !!! if you use RegexDir, then the version must be bumped !!!
---
toolRequirements:
GHC:
@@ -1304,7 +1305,7 @@ ghcupDownloads:
viArch:
A_64:
Linux_UnknownLinux:
- unknown_versioning:
+ unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-linux-ghcup-0.1.8
dlHash: 7ffcd4c3de156e895b648c75a36c762be2a4932883f3cd598f7a483c97d4a8a9
Darwin:
@@ -1315,8 +1316,12 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-portbld-freebsd-ghcup-0.1.8
dlHash: 442cdfe1b4525a327d9566e6270f909f7deba21c16dd4c7912537cf67e6cd521
+ Linux_Alpine:
+ unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
- unknown_versioning:
+ unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/i386-linux-ghcup-0.1.8
dlHash: 18ab162920cea662feae4b08f39d3879e9e416fde7b734afd8072c39d3c43cde
+ Linux_Alpine:
+ unknown_versioning: *ghcup-32
diff --git a/ghcup.cabal b/ghcup.cabal
index cca484f553fb994da67b3d838cc79c28943abca2..546420930a4186de38b838249581ac82154160c3 100644
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -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
@@ -276,6 +279,7 @@ library
, resourcet
, safe
, safe-exceptions
+ , split
, streamly
, streamly-posix
, streamly-bytestring
diff --git a/lib/GHCup.hs b/lib/GHCup.hs
index 8c55626bb9011bd2490e28e027c35de045062a22..0271bc2a0cf2113dfc44108dbeeffd6cf2007f35 100644
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -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)
@@ -189,6 +190,7 @@ installGHCBin :: ( MonadFail m
, NoDownload
, NotInstalled
, UnknownArchive
+ , TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -221,6 +223,7 @@ installCabalBindist :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
+ , TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -230,14 +233,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 +253,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,7 +273,7 @@ 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)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
@@ -300,6 +303,7 @@ installCabalBin :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
+ , TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -328,17 +332,23 @@ 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
-- 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 +360,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 +388,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 +411,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 +419,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 +485,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m
+ , MonadReader Settings m
)
=> GHCupDownloads
-> Maybe Tool
@@ -478,7 +497,7 @@ 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
@@ -493,7 +512,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 +523,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 +536,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
@@ -534,7 +553,7 @@ listVersions av lt criteria pfreq = do
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,12 +606,18 @@ 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
+ isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
+ dir <- lift $ ghcupGHCDir ver
let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir
@@ -612,39 +637,46 @@ rmGHCVer ver = do
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
- lift $ rmMajorSymlinks ver
+ handle (\(_ :: ParseError) -> pure ()) $ 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)
+ 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)
+
+ Settings { dirs = Dirs {..} } <- lift ask
liftIO
- $ ghcupBaseDir
- >>= hideError doesNotExistErrorType
- . deleteFile
- . (</> [rel|share|])
+ $ hideError doesNotExistErrorType
+ $ deleteFile
+ $ (baseDir </> [rel|share|])
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | 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 +685,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 +736,7 @@ compileGHC :: ( MonadMask m
, NotFoundInPATH
, PatchFailed
, UnknownArchive
+ , TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -711,7 +745,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 +762,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
@@ -883,6 +917,7 @@ compileCabal :: ( MonadReader Settings m
, NotInstalled
, PatchFailed
, UnknownArchive
+ , TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -892,14 +927,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 +947,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
@@ -1004,6 +1039,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
@@ -1016,7 +1052,6 @@ upgradeGHCup dls mtarget force pfreq = do
`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
@@ -1034,13 +1069,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)
+
diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs
index bf9f4f15d45cba932cf20a5c6f58a9a9e21518ff..ea5955197e035100bfe35a6edebe041333511560 100644
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -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
@@ -133,10 +133,10 @@ 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
yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
@@ -200,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
@@ -226,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
@@ -392,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
diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs
index 410812177301857c9a82ec936cca33601c256271..fdf54b0e477c3960cedf32043ff5548364fde736 100644
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@@ -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
diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs
index 6f69eef69faba0d55becbea2e473fc80c9f2ba03..1fa8c14989ef90a2d19706a54b319eb352ad48f8 100644
--- a/lib/GHCup/Platform.hs
+++ b/lib/GHCup/Platform.hs
@@ -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
diff --git a/lib/GHCup/Requirements.hs b/lib/GHCup/Requirements.hs
index 24f476106bd6282abdf63f1725ea0d929b759731..83753f8b945d13827d09675d257332583ee4e72e 100644
--- a/lib/GHCup/Requirements.hs
+++ b/lib/GHCup/Requirements.hs
@@ -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
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
index df6a8e5d15e074e418e905c4ec66cd9b42e9c5ea..acdd4824df1b21f198a5b51c0a2191665cc04ff1 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -6,7 +6,7 @@
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
@@ -92,6 +92,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 +137,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 +150,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
@@ -157,14 +164,25 @@ data URLSource = GHCupURL
data Settings = Settings
- { cache :: Bool
+ { -- set by user
+ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
+
+ -- set on app start
+ , dirs :: Dirs
}
deriving Show
+data Dirs = Dirs
+ { baseDir :: Path Abs
+ , binDir :: Path Abs
+ , cacheDir :: Path Abs
+ , logsDir :: Path Abs
+ }
+ deriving Show
data KeepDirs = Always
| Errors
diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs
index c87e33dd8e65b971505091ce817241eb031b631b..c271a08e1cb012d1b0102e0f0ab6e6ca3ba7ad1e 100644
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@@ -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
diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs
index 5fb344ef33d8992c959aa5aa09e6bd811d65716e..2486175c281d1c4edfd1d085f50f7e999a63792f 100644
--- a/lib/GHCup/Types/Optics.hs
+++ b/lib/GHCup/Types/Optics.hs
@@ -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
diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs
index 0f0486764c9d9b10702811a53a0fd04dcf917648..e06e87619bfa6019f9e89d54514b35769f714667 100644
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -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
@@ -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
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index f3c0b1213d47bf0488054af0713423096b85cbcc..2704e4237d1137dd0b2ff09893cb5742776b75aa 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -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 directories ]--
- -------------------------
+ ------------------------------
+ --[ 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
- bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
- Just r -> parseAbs r
- Nothing -> liftIO getHomeDirectory
- pure (bdir </> [rel|.ghcup|])
+ 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/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))
+
+
+
+
diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs
index eec83629a8c13224e01a5760dd9249b641f89d5b..8ddae18bfa238756acc17f6ee9a62c97c8c2b6f8 100644
--- a/lib/GHCup/Utils/File.hs
+++ b/lib/GHCup/Utils/File.hs
@@ -7,7 +7,7 @@
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 +17,6 @@ Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where
-import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Types
@@ -123,9 +122,8 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
-> 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")
+ Settings {dirs = Dirs {..}, ..} <- ask
+ logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd
(action verbose)
@@ -427,3 +425,12 @@ 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
diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs
index 45f49dcbfebe93aeed413fb37aea318be7a58a4b..0ff00042abc3f20c3940a260c471d46768e19ad6 100644
--- a/lib/GHCup/Utils/Logger.hs
+++ b/lib/GHCup/Utils/Logger.hs
@@ -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
diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Utils/MegaParsec.hs
index d6523619dfe02a65204c3bc7186871c6a396731a..ac379fea76c0cc41c0dfb6c8eb59b8ca0e733018 100644
--- a/lib/GHCup/Utils/MegaParsec.hs
+++ b/lib/GHCup/Utils/MegaParsec.hs
@@ -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
diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs
index 20fd8969a32e01bd1ed4dd74b86b37587e4527cb..6bd913b60ce28c6bbbe90c1de656e59f218a80f1 100644
--- a/lib/GHCup/Utils/Prelude.hs
+++ b/lib/GHCup/Utils/Prelude.hs
@@ -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
diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Utils/String/QQ.hs
index 6cff357b978dc8de2ea8bf340248a3985037e13f..85f566f7ce1ad877605cca396e9893f4ffe8694c 100644
--- a/lib/GHCup/Utils/String/QQ.hs
+++ b/lib/GHCup/Utils/String/QQ.hs
@@ -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
diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Utils/Version/QQ.hs
index 663460ed97f5025f3b3b670ed929473ca07f3448..73912ccea196f1a18ee8d34d33e6be1cdf39a165 100644
--- a/lib/GHCup/Utils/Version/QQ.hs
+++ b/lib/GHCup/Utils/Version/QQ.hs
@@ -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
diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs
index 55a923ef6ae4fe03b2e00e6d185c864ed01d3b21..24d4ad774a5acc0308405cde610a2741ebfb33fe 100644
--- a/lib/GHCup/Version.hs
+++ b/lib/GHCup/Version.hs
@@ -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