diff --git a/README.md b/README.md index 1f6cfc2..a726d17 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p * [Manpages](#manpages) * [Shell-completion](#shell-completion) * [Cross support](#cross-support) + * [XDG support](#xdg-support) * [Design goals](#design-goals) * [How](#how) * [Known users](#known-users) @@ -96,6 +97,16 @@ For distributions with non-standard locations of cross toolchain and libraries, this may need some tweaking of `build.mk` or configure args. See `ghcup compile ghc --help` for further information. +### Cross support + +To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything. + +Then you can control the locations via XDG environment variables as such: + +* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir +* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir +* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`) + ## Design goals 1. simplicity diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index cf42698..5fd5172 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -903,9 +903,11 @@ Report bugs at |] >>= \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 |] 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 |] 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 |] 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 |] 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 diff --git a/bootstrap-haskell b/bootstrap-haskell index e968d29..7b0c8cc 100755 --- a/bootstrap-haskell +++ b/bootstrap-haskell @@ -4,6 +4,17 @@ ( : "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}" + +export GHCUP_USE_XDG_DIRS + +if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then + GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local}/ghcup + GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin} +else + GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup + GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin +fi + : "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}" : "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}" @@ -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/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;; diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8c55626..d712e50 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index bf9f4f1..e06e6ed 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 9b9534d..fb94e6c 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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/. @@ -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 diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index f3c0b12..dc9d4cf 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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)) + + + + + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index eec8362..706ccda 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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 diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 45f49dc..0b7088f 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -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