hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'cabal-install-3.4.0.0-rc1'

This commit is contained in:
Julian Ospald 2020-08-11 21:34:45 +02:00
parent 86a4b10de6 d2c5d4dfd9
commit 80603662b4
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
28 changed files with 638 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

17
.gitlab-ci.yml
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
@ -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 ########

12
.gitlab/script/ghcup_version.sh
View File

@ -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

11
README.md
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.
### 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

15
app/ghcup-gen/Validate.hs
View File

@ -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 ())

38
app/ghcup/BrickMain.hs
View File

@ -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

50
app/ghcup/Main.hs
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 { .. }
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 ()

76
bootstrap-haskell
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,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

4
cabal.project
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

9
ghcup-0.0.2.yaml
View File

@ -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

6
ghcup.cabal
View File

@ -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

196
lib/GHCup.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)
@ -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)

14
lib/GHCup/Download.hs
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
@ -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

5
lib/GHCup/Errors.hs
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

2
lib/GHCup/Platform.hs
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

2
lib/GHCup/Requirements.hs
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

24
lib/GHCup/Types.hs
View File

@ -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

20
lib/GHCup/Types/JSON.hs
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

2
lib/GHCup/Types/Optics.hs
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

207
lib/GHCup/Utils.hs
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
@ -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

160
lib/GHCup/Utils/Dirs.hs
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))

17
lib/GHCup/Utils/File.hs
View File

@ -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

22
lib/GHCup/Utils/Logger.hs
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

2
lib/GHCup/Utils/MegaParsec.hs
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

2
lib/GHCup/Utils/Prelude.hs
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

2
lib/GHCup/Utils/String/QQ.hs
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

2
lib/GHCup/Utils/Version/QQ.hs
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

2
lib/GHCup/Version.hs
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