Add xdg support wrt #39

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))
+
+
+
+
+

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