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

Add xdg support wrt #39

Browse Source
This commit is contained in:
Julian Ospald 2020-07-29 01:43:00 +02:00
parent 7d334c18f5
commit aac8f760ad
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
9 changed files with 179 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

16
app/ghcup/Main.hs
View File

@ -903,9 +903,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \opt@Options {..} -> do
let settings@Settings{..} = toSettings opt
logsDir <- toFilePath <$> ghcupLogsDir
-- create ~/.ghcup dir
ghcdir <- ghcupBaseDir
createDirIfMissing newDirPerms ghcdir
createDirRecursive newDirPerms ghcdir
-- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|]
@ -1079,7 +1081,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 +1094,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 +1123,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 +1239,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 +1263,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

39
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}"
@ -83,15 +94,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
@ -106,8 +117,12 @@ echo " * ghcup - The Haskell toolchain installer (for managing GHC/cabal versio
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, which can be removed anytime:"
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
else
echo "ghcup installs into XDG directories as long as 'GHCUP_USE_XDG_DIRS' is set"
fi
echo
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
@ -119,7 +134,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 +171,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
@ -199,14 +214,14 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
"") 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}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
break ;;
*)
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\"" >> "${GHCUP_PROFILE_FILE}"
break ;;
esac
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
printf "\\033[0;35m%s\\033[0m\\n" "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;;
[Nn]*)
exit 0;;

6
lib/GHCup.hs
View File

@ -270,7 +270,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)
@ -360,7 +360,7 @@ setGHC ver sghc = do
-- create symlink
let fullF = bindir </> targetFile
let destL = ghcLinkDestination (toFilePath file) ver
destL <- ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
@ -631,7 +631,7 @@ rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled GHC (prettyVer ver))
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver))
cSet <- liftIO cabalSet

2
lib/GHCup/Download.hs
View File

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

61
lib/GHCup/Utils.hs
View File

@ -97,11 +97,15 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
ghcLinkDestination :: (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
t <- parseRel tool
bin <- liftIO ghcupBinDir
ghcd <- liftIO $ ghcupGHCDir ver
pure (relativeSymlink bin (ghcd </> [rel|bin|] </> t))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
@ -201,25 +205,26 @@ ghcSet mtarget = do
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>.
@ -256,15 +261,19 @@ cabalInstalled ver = do
-- Return the currently set cabal version, if any.
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet :: (MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
b <- fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath cabalbin
Just <$> linkVersion link
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

90
lib/GHCup/Utils/Dirs.hs
View File

@ -24,6 +24,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 +36,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
@ -51,12 +53,25 @@ import qualified Text.Megaparsec as MP
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_DATA_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/share|])
pure (bdir </> [rel|ghcup|])
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
-- | ~/.ghcup/ghc by default.
@ -82,14 +97,54 @@ parseGHCupGHCDir (toFilePath -> f) = do
throwEither $ MP.parse ghcTargetVerP "" fp
-- | 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 = ghcupBaseDir <&> (</> [rel|bin|])
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 = ghcupBaseDir <&> (</> [rel|cache|])
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 = ghcupBaseDir <&> (</> [rel|logs|])
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|])
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
@ -116,3 +171,24 @@ 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))

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

@ -427,3 +427,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

2
lib/GHCup/Utils/Logger.hs
View File

@ -65,7 +65,7 @@ initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
createDirRecursive newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile