Add xdg support wrt #39

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

app/ghcup/Main.hs

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

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"
+	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
 	# 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:"
+if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
-echo "  $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
+	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;;

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
 

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

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
+                   -> m ByteString
-ghcLinkDestination tool ver =
+ghcLinkDestination tool ver = do
-  "../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
+  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
+  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>.
@@ -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
+        broken <- isBrokenSymlink cabalbin
-        Just <$> linkVersion link
+        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

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
+  xdg <- useXDG
-    Just r  -> parseAbs r
+  if xdg
-    Nothing -> liftIO getHomeDirectory
+    then do
-  pure (bdir </> [rel|.ghcup|])
+      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))
+
+
+
+
+

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

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