Merge branch 'cabal-install-3.4.0.0-rc1'

This commit is contained in:
Julian Ospald 2020-08-11 21:34:45 +02:00
commit 80603662b4
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
28 changed files with 638 additions and 282 deletions

1
.gitignore vendored
View File

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

View File

@ -14,6 +14,7 @@ variables:
- x86_64-linux - x86_64-linux
variables: variables:
OS: "LINUX" OS: "LINUX"
BIT: "64"
.alpine:64bit: .alpine:64bit:
image: "alpine:edge" image: "alpine:edge"
@ -36,12 +37,14 @@ variables:
- x86_64-darwin - x86_64-darwin
variables: variables:
OS: "DARWIN" OS: "DARWIN"
BIT: "64"
.freebsd: .freebsd:
tags: tags:
- x86_64-freebsd - x86_64-freebsd
variables: variables:
OS: "FREEBSD" OS: "FREEBSD"
BIT: "64"
.root_cleanup: .root_cleanup:
after_script: after_script:
@ -66,6 +69,13 @@ variables:
before_script: before_script:
- ./.gitlab/before_script/linux/install_deps.sh - ./.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: .test_ghcup_version:darwin:
extends: extends:
- .test_ghcup_version - .test_ghcup_version
@ -107,6 +117,13 @@ test:linux:latest:
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
allow_failure: true 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 ######## ######## darwin test ########

View File

@ -22,14 +22,20 @@ ecabal update
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui 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 else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi 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 -w ghc-${GHC_VERSION} --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-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen

View File

@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Manpages](#manpages) * [Manpages](#manpages)
* [Shell-completion](#shell-completion) * [Shell-completion](#shell-completion)
* [Cross support](#cross-support) * [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Design goals](#design-goals) * [Design goals](#design-goals)
* [How](#how) * [How](#how)
* [Known users](#known-users) * [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. libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information. 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 ## Design goals
1. simplicity 1. simplicity

View File

@ -7,7 +7,9 @@ module Validate where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Types import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
@ -88,6 +90,15 @@ validate dls = do
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn) when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|] [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 checkUniqueTags tool = do
let allTags = join $ M.elems $ availableToolVersions dls tool let allTags = join $ M.elems $ availableToolVersions dls tool
let nonUnique = let nonUnique =
@ -111,6 +122,7 @@ validate dls = do
where where
isUniqueTag Latest = True isUniqueTag Latest = True
isUniqueTag Recommended = True isUniqueTag Recommended = True
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False isUniqueTag (UnknownTag _) = False
@ -179,7 +191,8 @@ validateTarballs dls = do
where where
downloadAll dli = do 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 let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ()) , rawOutter = (\_ -> pure ())

View File

@ -112,6 +112,7 @@ ui AppState {..} =
printTag Recommended = withAttr "recommended" $ str "recommended" printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest" printTag Latest = withAttr "latest" $ str "latest"
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t printTag (UnknownTag t ) = str t
@ -137,6 +138,7 @@ defaultAttributes = attrMap
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow) , ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic) , ("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 withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do Just (ix, e) -> suspendAndResume $ do
r <- action as (ix, e) action as (ix, e) >>= \case
case r of Left err -> putStrLn $ ("Error: " <> err)
Left err -> throwIO $ userError err Right _ -> putStrLn "Success"
Right _ -> do apps <- (fmap . fmap)
apps <- (fmap . fmap) (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) $ getAppState Nothing (pfreq as)
$ getAppState Nothing (pfreq as) case apps of
case apps of Right nas -> do
Right nas -> do putStrLn "Press enter to continue"
putStrLn "Press enter to continue" _ <- getLine
_ <- getLine pure nas
pure nas Left err -> throwIO $ userError err
Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ()) install' :: AppState -> (Int, ListResult) -> IO (Either String ())
@ -213,7 +214,9 @@ install' AppState {..} (_, ListResult {..}) = do
, TagNotFound , TagNotFound
, DigestError , DigestError
, DownloadFailed , DownloadFailed
, NoUpdate] , NoUpdate
, TarDirDoesNotExist
]
(run $ do (run $ do
case lTool of case lTool of
@ -296,14 +299,15 @@ uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings settings' :: IORef Settings
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO settings' = unsafePerformIO $ do
(newIORef Settings { cache = True dirs <- getDirs
newIORef Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, ..
} }
)
logger' :: IORef LoggerConfig logger' :: IORef LoggerConfig

View File

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

View File

@ -4,6 +4,17 @@
( (
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}" : "${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_GHC_VERSION:=recommended}"
: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}" : "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
@ -29,6 +40,22 @@ _eghcup() {
fi 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() { download_ghcup() {
_plat="$(uname -s)" _plat="$(uname -s)"
_arch=$(uname -m) _arch=$(uname -m)
@ -83,15 +110,15 @@ download_ghcup() {
;; ;;
esac 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" cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH" export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
EOF EOF
# shellcheck disable=SC1090 # shellcheck disable=SC1090
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env edo . "${GHCUP_DIR}"/env
eghcup upgrade eghcup upgrade
unset _plat _arch _url _ghver _base_url unset _plat _arch _url _ghver _base_url
@ -102,12 +129,19 @@ echo
echo "Welcome to Haskell!" echo "Welcome to Haskell!"
echo echo
echo "This script will download and install the following binaries:" 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 " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool" echo " * cabal - The Cabal build tool"
echo echo
echo "ghcup installs only into the following directory, which can be removed anytime:" if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup" 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 echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
@ -119,7 +153,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty read -r answer </dev/tty
fi 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 command -V "ghcup" >/dev/null 2>&1 ; then
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; 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 if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
echo "In order to run ghc and cabal, you need to adjust your PATH variable." 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)." echo "configuration to do so (e.g. ~/.bashrc)."
case $SHELL in case $SHELL in
@ -174,13 +208,13 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
GHCUP_PROFILE_FILE="$HOME/.zshrc" GHCUP_PROFILE_FILE="$HOME/.zshrc"
MY_SHELL="zsh" MY_SHELL="zsh"
else else
exit 0 _done
fi fi
;; ;;
*/fish) # login shell is fish */fish) # login shell is fish
GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish" GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
MY_SHELL="fish" ;; MY_SHELL="fish" ;;
*) exit 0 ;; *) _done ;;
esac esac
@ -198,18 +232,24 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
case $MY_SHELL in case $MY_SHELL in
"") break ;; "") break ;;
fish) fish)
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}" if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
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}" 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 ;; 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 ;; break ;;
esac esac
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect," printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session." printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
exit 0;; _done
;;
[Nn]*) [Nn]*)
exit 0;; _done ;;
*) *)
echo "Please type YES or NO and press enter.";; echo "Please type YES or NO and press enter.";;
esac esac

View File

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

View File

@ -1,3 +1,4 @@
# !!! if you use RegexDir, then the version must be bumped !!!
--- ---
toolRequirements: toolRequirements:
GHC: GHC:
@ -1304,7 +1305,7 @@ ghcupDownloads:
viArch: viArch:
A_64: A_64:
Linux_UnknownLinux: Linux_UnknownLinux:
unknown_versioning: unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-linux-ghcup-0.1.8 dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-linux-ghcup-0.1.8
dlHash: 7ffcd4c3de156e895b648c75a36c762be2a4932883f3cd598f7a483c97d4a8a9 dlHash: 7ffcd4c3de156e895b648c75a36c762be2a4932883f3cd598f7a483c97d4a8a9
Darwin: Darwin:
@ -1315,8 +1316,12 @@ ghcupDownloads:
unknown_versioning: unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-portbld-freebsd-ghcup-0.1.8 dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-portbld-freebsd-ghcup-0.1.8
dlHash: 442cdfe1b4525a327d9566e6270f909f7deba21c16dd4c7912537cf67e6cd521 dlHash: 442cdfe1b4525a327d9566e6270f909f7deba21c16dd4c7912537cf67e6cd521
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32: A_32:
Linux_UnknownLinux: Linux_UnknownLinux:
unknown_versioning: unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/i386-linux-ghcup-0.1.8 dlUri: https://downloads.haskell.org/~ghcup/0.1.8/i386-linux-ghcup-0.1.8
dlHash: 18ab162920cea662feae4b08f39d3879e9e416fde7b734afd8072c39d3c43cde dlHash: 18ab162920cea662feae4b08f39d3879e9e416fde7b734afd8072c39d3c43cde
Linux_Alpine:
unknown_versioning: *ghcup-32

View File

@ -112,7 +112,7 @@ common io-streams
build-depends: io-streams >=1.5 build-depends: io-streams >=1.5
common libarchive common libarchive
build-depends: libarchive >= 2.2.5.2 build-depends: libarchive >= 2.2.5.0
common lzma common lzma
build-depends: lzma >=0.0.0.3 build-depends: lzma >=0.0.0.3
@ -153,6 +153,9 @@ common safe
common safe-exceptions common safe-exceptions
build-depends: safe-exceptions >=0.1 build-depends: safe-exceptions >=0.1
common split
build-depends: split >=0.2.3.4
common streamly common streamly
build-depends: streamly >=0.7.1 build-depends: streamly >=0.7.1
@ -276,6 +279,7 @@ library
, resourcet , resourcet
, safe , safe
, safe-exceptions , safe-exceptions
, split
, streamly , streamly
, streamly-posix , streamly-posix
, streamly-bytestring , streamly-bytestring

View File

@ -15,7 +15,7 @@
Module : GHCup Module : GHCup
Description : GHCup installation functions Description : GHCup installation functions
Copyright : (c) Julian Ospald, 2020 Copyright : (c) Julian Ospald, 2020
License : GPL-3 License : LGPL-3.0
Maintainer : hasufell@hasufell.de Maintainer : hasufell@hasufell.de
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
@ -112,6 +112,7 @@ installGHCBindist :: ( MonadFail m
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -121,7 +122,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver (PlatformRequest {..}) = do installGHCBindist dlinfo ver (PlatformRequest {..}) = do
let tver = (mkTVer ver) let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ ghcInstalled tver) whenM (lift $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver) $ (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version) -- download (or use cached version)
@ -133,10 +134,10 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths -- prepare paths
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work -- 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) liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
@ -189,6 +190,7 @@ installGHCBin :: ( MonadFail m
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -221,6 +223,7 @@ installCabalBindist :: ( MonadMask m
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -230,14 +233,14 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
whenM whenM
(liftIO $ cabalInstalled ver >>= \a -> (lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False) handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x) $ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink) -- 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) $ (throwE $ AlreadyInstalled Cabal ver)
@ -250,12 +253,12 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work -- 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 -- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
@ -270,7 +273,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
installCabal' path inst = do installCabal' path inst = do
lift $ $(logInfo) "Installing cabal" lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|] let cabalFile = [rel|cabal|]
liftIO $ createDirIfMissing newDirPerms inst liftIO $ createDirRecursive newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver) destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile) (path </> cabalFile)
@ -300,6 +303,7 @@ installCabalBin :: ( MonadMask m
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -328,17 +332,23 @@ installCabalBin bDls ver pfreq = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) setGHC :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion => GHCTargetVersion
-> SetGHC -> SetGHC
-> Excepts '[NotInstalled] m GHCTargetVersion -> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver) let verBS = verToBS (_tvVersion ver)
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
-- symlink destination -- symlink destination
bindir <- liftIO $ ghcupBinDir Settings { dirs = Dirs {..} } <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup) -- with old ghcup)
@ -350,19 +360,26 @@ setGHC ver sghc = do
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do forM_ verfiles $ \file -> do
targetFile <- case sghc of mTargetFile <- case sghc of
SetGHCOnly -> pure file SetGHCOnly -> pure $ Just file
SetGHC_XY -> do SetGHC_XY -> do
major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi) v' <-
<$> getMajorMinorV (_tvVersion ver) handle
parseRel (toFilePath file <> B.singleton _hyphen <> major') (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) $ 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 -- create symlink
let fullF = bindir </> targetFile forM mTargetFile $ \targetFile -> do
let destL = ghcLinkDestination (toFilePath file) ver let fullF = binDir </> targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|] destL <- lift $ ghcLinkDestination (toFilePath file) ver
liftIO $ createSymlink fullF destL lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir -- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
@ -371,12 +388,13 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadIO m, MonadLogger m) symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m)
=> Path Abs => Path Abs
-> ByteString -> ByteString
-> m () -> m ()
symlinkShareDir ghcdir verBS = do symlinkShareDir ghcdir verBS = do
destdir <- liftIO $ ghcupBaseDir Settings { dirs = Dirs {..} } <- ask
let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
let sharedir = [rel|share|] let sharedir = [rel|share|]
@ -393,7 +411,7 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setCabal ver = do setCabal ver = do
@ -401,14 +419,14 @@ setCabal ver = do
targetFile <- parseRel ("cabal-" <> verBS) targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination -- symlink destination
bindir <- liftIO $ ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile)) whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE $ throwE
$ NotInstalled Cabal (prettyVer ver) $ NotInstalled Cabal (prettyVer ver)
let cabalbin = bindir </> [rel|cabal|] let cabalbin = binDir </> [rel|cabal|]
-- delete old file (may be binary or symlink) -- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|] lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
@ -467,6 +485,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m
) )
=> GHCupDownloads => GHCupDownloads
-> Maybe Tool -> Maybe Tool
@ -478,7 +497,7 @@ listVersions av lt criteria pfreq = do
Just t -> do Just t -> do
-- get versions from GHCupDownloads -- get versions from GHCupDownloads
let avTools = availableToolVersions av t let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t) lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of case t of
-- append stray GHCs -- append stray GHCs
@ -493,7 +512,7 @@ listVersions av lt criteria pfreq = do
pure (ghcvers <> cabalvers <> ghcupvers) pure (ghcvers <> cabalvers <> ghcupvers)
where where
strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m) strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -504,7 +523,7 @@ listVersions av lt criteria pfreq = do
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- liftIO $ ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
@ -517,7 +536,7 @@ listVersions av lt criteria pfreq = do
} }
Right tver@GHCTargetVersion{ .. } -> do Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- liftIO $ ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
@ -534,7 +553,7 @@ listVersions av lt criteria pfreq = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of toListResult t (v, tags) = case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
@ -587,12 +606,18 @@ listVersions av lt criteria pfreq = do
-- This may leave GHCup without a "set" version. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- 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 => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmGHCVer ver = do rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
dir <- liftIO $ ghcupGHCDir ver dir <- lift $ ghcupGHCDir ver
let d' = toFilePath dir let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
@ -612,39 +637,46 @@ rmGHCVer ver = do
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|] lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove -- first remove
lift $ rmMajorSymlinks ver handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version) -- then fix them (e.g. with an earlier version)
(mj, mi) <- getMajorMinorV (_tvVersion ver) v' <-
getGHCForMajor mj mi (_tvTarget ver) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) 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 liftIO
$ ghcupBaseDir $ hideError doesNotExistErrorType
>>= hideError doesNotExistErrorType $ deleteFile
. deleteFile $ (baseDir </> [rel|share|])
. (</> [rel|share|])
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)) else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- 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 => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmCabalVer ver = do 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) cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
when (maybe False (== ver) cSet) $ do when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile 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 => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
diBaseDir <- liftIO $ ghcupBaseDir Settings {dirs = Dirs {..}} <- lift ask
diBinDir <- liftIO $ ghcupBinDir let diBaseDir = baseDir
diGHCDir <- liftIO $ ghcupGHCBaseDir let diBinDir = binDir
diCacheDir <- liftIO $ ghcupCacheDir diGHCDir <- lift ghcupGHCBaseDir
diArch <- lE getArchitecture let diCacheDir = cacheDir
diPlatform <- liftE $ getPlatform diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
pure $ DebugInfo { .. } pure $ DebugInfo { .. }
@ -703,6 +736,7 @@ compileGHC :: ( MonadMask m
, NotFoundInPATH , NotFoundInPATH
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -711,7 +745,7 @@ compileGHC :: ( MonadMask m
() ()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver) whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
-- download source tarball -- download source tarball
@ -728,8 +762,8 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
bghc <- case bstrap of bghc <- case bstrap of
Right g -> pure $ Right g Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction liftE $ runBuildAction
tmpUnpack tmpUnpack
@ -883,6 +917,7 @@ compileCabal :: ( MonadReader Settings m
, NotInstalled , NotInstalled
, PatchFailed , PatchFailed
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -892,14 +927,14 @@ compileCabal :: ( MonadReader Settings m
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir Settings {dirs = Dirs {..}} <- lift ask
whenM whenM
(liftIO $ cabalInstalled tver >>= \a -> (lift (cabalInstalled tver) >>= \a -> liftIO $
handleIO (\_ -> pure False) handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x) $ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink) -- 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) $ (throwE $ AlreadyInstalled Cabal tver)
@ -912,18 +947,18 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack 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) cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver) destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin cbin
(bindir </> destFileName) (binDir </> destFileName)
Overwrite Overwrite
-- create symlink if this is the latest version -- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
@ -1004,6 +1039,7 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup dls mtarget force pfreq = do upgradeGHCup dls mtarget force pfreq = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
@ -1016,7 +1052,6 @@ upgradeGHCup dls mtarget force pfreq = do
`unionFileModes` ownerExecuteMode `unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode `unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode `unionFileModes` otherExecuteMode
binDir <- liftIO $ ghcupBinDir
let fullDest = fromMaybe (binDir </> fn) mtarget let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p 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 -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) postGHCInstall :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion{..} = do postGHCInstall ver@GHCTargetVersion {..} = do
void $ liftE $ setGHC ver SetGHC_XYZ void $ liftE $ setGHC ver SetGHC_XYZ
-- Create ghc-x.y symlinks. This may not be the current -- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless. -- version, create it regardless.
(mj, mi) <- getMajorMinorV _tvVersion v' <-
getGHCForMajor mj mi _tvTarget >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) 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)

View File

@ -13,7 +13,7 @@
Module : GHCup.Download Module : GHCup.Download
Description : Downloading Description : Downloading
Copyright : (c) Julian Ospald, 2020 Copyright : (c) Julian Ospald, 2020
License : GPL-3 License : LGPL-3.0
Maintainer : hasufell@hasufell.de Maintainer : hasufell@hasufell.de
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
@ -133,10 +133,10 @@ getDownloadsF urlSource = do
(OwnSpec _) -> liftE $ getDownloads urlSource (OwnSpec _) -> liftE $ getDownloads urlSource
where where
readFromCache = do readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn) lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|] [i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL let path = view pathL' ghcupURL
cacheDir <- liftIO $ ghcupCacheDir
yaml_file <- (cacheDir </>) <$> urlBaseName path yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <- bs <-
handleIO' NoSuchThing handleIO' NoSuchThing
@ -200,8 +200,8 @@ getDownloads urlSource = do
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri' let path = view pathL' uri'
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
if e if e
@ -226,7 +226,7 @@ getDownloads urlSource = do
else -- access in less than 5 minutes, re-use file else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file liftIO $ readFile json_file
else do else do
liftIO $ createDirIfMissing newDirPerms cacheDir liftIO $ createDirRecursive newDirPerms cacheDir
getModTime >>= \case getModTime >>= \case
Just modTime -> dlWithMod modTime json_file Just modTime -> dlWithMod modTime json_file
Nothing -> do Nothing -> do
@ -392,15 +392,15 @@ downloadCached dli mfn = do
cache <- lift getCache cache <- lift getCache
case cache of case cache of
True -> do True -> do
cachedir <- liftIO $ ghcupCacheDir Settings {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cachedir </> fn let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> do | fileExists -> do
liftE $ checkDigest dli cachfile liftE $ checkDigest dli cachfile
pure $ cachfile pure $ cachfile
| otherwise -> liftE $ download dli cachedir mfn | otherwise -> liftE $ download dli cacheDir mfn
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn liftE $ download dli tmp mfn

View File

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

View File

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

View File

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

View File

@ -6,7 +6,7 @@
Module : GHCup.Types Module : GHCup.Types
Description : GHCup types Description : GHCup types
Copyright : (c) Julian Ospald, 2020 Copyright : (c) Julian Ospald, 2020
License : GPL-3 License : LGPL-3.0
Maintainer : hasufell@hasufell.de Maintainer : hasufell@hasufell.de
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
@ -92,6 +92,7 @@ data VersionInfo = VersionInfo
-- | A tag. These are currently attached to a version of a tool. -- | A tag. These are currently attached to a version of a tool.
data Tag = Latest data Tag = Latest
| Recommended | Recommended
| Prerelease
| Base PVP | Base PVP
| UnknownTag String -- ^ used for upwardscompat | UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
@ -136,7 +137,7 @@ data LinuxDistro = Debian
-- to download, extract and install a tool. -- to download, extract and install a tool.
data DownloadInfo = DownloadInfo data DownloadInfo = DownloadInfo
{ _dlUri :: URI { _dlUri :: URI
, _dlSubdir :: Maybe (Path Rel) , _dlSubdir :: Maybe TarDir
, _dlHash :: Text , _dlHash :: Text
} }
deriving (Eq, Show) 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. -- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource URI
@ -157,14 +164,25 @@ data URLSource = GHCupURL
data Settings = Settings data Settings = Settings
{ cache :: Bool { -- set by user
cache :: Bool
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
-- set on app start
, dirs :: Dirs
} }
deriving Show deriving Show
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
}
deriving Show
data KeepDirs = Always data KeepDirs = Always
| Errors | Errors

View File

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

View File

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

View File

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

View File

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

View File

@ -7,7 +7,7 @@
Module : GHCup.Utils.File Module : GHCup.Utils.File
Description : File and unix APIs Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020 Copyright : (c) Julian Ospald, 2020
License : GPL-3 License : LGPL-3.0
Maintainer : hasufell@hasufell.de Maintainer : hasufell@hasufell.de
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
@ -17,7 +17,6 @@ Some of these functions use sophisticated logging.
-} -}
module GHCup.Utils.File where module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types import GHCup.Types
@ -123,9 +122,8 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
-> Maybe [(ByteString, ByteString)] -- ^ optional environment -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
Settings {..} <- ask Settings {dirs = Dirs {..}, ..} <- ask
ldir <- liftIO ghcupLogsDir logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd closeFd
(action verbose) (action verbose)
@ -427,3 +425,12 @@ findFiles' path parser = do
Right p' -> isJust $ MP.parseMaybe parser p') Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream $ dirContentsStream dirStream
pure $ join $ fmap parseRel f 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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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