Initial commit

lib/GHCup/Utils/Dirs.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE QuasiQuotes           #-}
+
+module GHCup.Utils.Dirs where
+
+
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Maybe
+import           Data.Versions
+import           HPath
+import           HPath.IO
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           System.Posix.Env.ByteString    ( getEnv
+                                                , getEnvDefault
+                                                )
+import           System.Posix.Temp.ByteString   ( mkdtemp )
+
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
+
+
+
+    -------------------------
+    --[ GHCup directories ]--
+    -------------------------
+
+
+ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir = do
+  getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
+    Just r  -> parseAbs r
+    Nothing -> do
+      home <- liftIO getHomeDirectory
+      pure (home </> ([rel|.ghcup|] :: Path Rel))
+
+ghcupGHCBaseDir :: IO (Path Abs)
+ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
+
+ghcupGHCDir :: Version -> IO (Path Abs)
+ghcupGHCDir ver = do
+  ghcbasedir <- ghcupGHCBaseDir
+  verdir     <- parseRel (verToBS ver)
+  pure (ghcbasedir </> verdir)
+
+
+ghcupBinDir :: IO (Path Abs)
+ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
+
+ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
+
+ghcupLogsDir :: IO (Path Abs)
+ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
+
+
+mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
+mkGhcupTmpDir = do
+  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
+  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+  parseAbs tmp
+
+
+withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
+withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv [s|HOME|]
+  case e of
+    Just fp -> parseAbs fp
+    Nothing -> do
+      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
+      parseAbs $ UTF8.fromString h -- this is a guess