Merge branch 'reduce-win-cpp'

This commit is contained in:
Julian Ospald 2021-10-17 21:16:59 +02:00
commit 920b027a32
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 380 additions and 363 deletions

View File

@ -11,6 +11,7 @@ module GHCup.OptParse.List where
import GHCup
import GHCup.Utils.Prelude
import GHCup.Types
import GHCup.OptParse.Common
@ -115,15 +116,9 @@ printListResult no_color raw lr = do
. fmap
(\ListResult {..} ->
let marks = if
#if defined(IS_WINDOWS)
| lSet -> (color Green "IS")
| lInstalled -> (color Green "I ")
| otherwise -> (color Red "X ")
#else
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
#endif
| lSet -> (color Green (if isWindows then "IS" else "✔✔"))
| lInstalled -> (color Green (if isWindows then "I " else ""))
| otherwise -> (color Red (if isWindows then "X " else ""))
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool

View File

@ -16,11 +16,11 @@ description:
category: System
build-type: Simple
extra-doc-files:
CHANGELOG.md
data/config.yaml
data/metadata/ghcup-0.0.4.yaml
data/metadata/ghcup-0.0.5.yaml
data/metadata/ghcup-0.0.6.yaml
CHANGELOG.md
README.md
extra-source-files:
@ -120,6 +120,7 @@ library
, pretty-terminal ^>=0.1.0.0
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, retry ^>=0.8.1.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, split ^>=0.2.3.4
@ -148,16 +149,21 @@ library
if os(windows)
cpp-options: -DIS_WINDOWS
other-modules: GHCup.Utils.File.Windows
other-modules:
GHCup.Utils.File.Windows
GHCup.Utils.Prelude.Windows
GHCup.Utils.Windows
build-depends:
, bzlib
, process ^>=1.6.11.0
, retry ^>=0.8.1.2
, Win32 ^>=2.10
else
other-modules:
GHCup.Utils.File.Posix
GHCup.Utils.Posix
GHCup.Utils.Prelude.Posix
System.Console.Terminal.Common
System.Console.Terminal.Posix
@ -172,23 +178,25 @@ library
executable ghcup
main-is: Main.hs
other-modules: GHCup.OptParse.Install
GHCup.OptParse.Common
GHCup.OptParse.Set
GHCup.OptParse.UnSet
GHCup.OptParse.Rm
GHCup.OptParse.Compile
GHCup.OptParse.Config
GHCup.OptParse.Whereis
GHCup.OptParse.List
GHCup.OptParse.DInfo
GHCup.OptParse.Upgrade
GHCup.OptParse.ToolRequirements
GHCup.OptParse.ChangeLog
GHCup.OptParse.Nuke
GHCup.OptParse.Prefetch
GHCup.OptParse.GC
GHCup.OptParse
other-modules:
GHCup.OptParse
GHCup.OptParse.ChangeLog
GHCup.OptParse.Common
GHCup.OptParse.Compile
GHCup.OptParse.Config
GHCup.OptParse.DInfo
GHCup.OptParse.GC
GHCup.OptParse.Install
GHCup.OptParse.List
GHCup.OptParse.Nuke
GHCup.OptParse.Prefetch
GHCup.OptParse.Rm
GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet
GHCup.OptParse.Upgrade
GHCup.OptParse.Whereis
hs-source-dirs: app/ghcup
default-language: Haskell2010
default-extensions:

View File

@ -52,9 +52,7 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
#if defined(IS_WINDOWS)
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#endif
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
@ -96,9 +94,6 @@ import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
#if defined(IS_WINDOWS)
import qualified System.Win32.File as Win32
#endif
import qualified Text.Megaparsec as MP
import GHCup.Utils.MegaParsec
import Control.Concurrent (threadDelay)
@ -339,36 +334,35 @@ installUnpackedGHC :: ( MonadReader env m
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do
#if defined(IS_WINDOWS)
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
Win32.moveFile source dest
setModificationTime dest mtime
#else
PlatformRequest {..} <- lift getPlatformReq
installUnpackedGHC path inst ver
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
moveFilePortable source dest
setModificationTime dest mtime
| otherwise = do
PlatformRequest {..} <- lift getPlatformReq
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
: alpineArgs
)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
#endif
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
: alpineArgs
)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -1147,15 +1141,17 @@ setGHC ver sghc = do
logDebug $ "rm -f " <> T.pack fullF
hideError doesNotExistErrorType $ rmDirectoryLink fullF
logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
liftIO
#if defined(IS_WINDOWS)
-- On windows we need to be more permissive
-- in case symlinks can't be created, be just
-- give up here. This symlink isn't strictly necessary.
$ hideError permissionErrorType
$ hideError illegalOperationErrorType
#endif
$ createDirectoryLink targetF fullF
if isWindows
then liftIO
-- On windows we need to be more permissive
-- in case symlinks can't be created, be just
-- give up here. This symlink isn't strictly necessary.
$ hideError permissionErrorType
$ hideError illegalOperationErrorType
$ createDirectoryLink targetF fullF
else liftIO
$ createDirectoryLink targetF fullF
_ -> pure ()
unsetGHC :: ( MonadReader env m
@ -1876,17 +1872,17 @@ rmGhcup = do
unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exe on windows
-- we move it to temp dir, to be deleted at next reboot
tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
#else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
#endif
if isWindows
then do
-- since it doesn't seem possible to delete a running exe on windows
-- we move it to temp dir, to be deleted at next reboot
tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
moveFile ghcupFilepath (tempFilepath </> "ghcup")
else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
where
handlePathNotPresent fp _err = do
@ -1946,10 +1942,9 @@ rmGhcupDirs = do
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS)
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif
when isWindows $ do
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
handleRm $ removeEmptyDirsRecursive baseDir
@ -1983,15 +1978,13 @@ rmGhcupDirs = do
forM_ contents (deleteFile . (dir </>))
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmBinDir binDir = do
#if !defined(IS_WINDOWS)
isXDGStyle <- liftIO useXDG
if not isXDGStyle
then removeDirIfEmptyOrIsSymlink binDir
else pure ()
#else
removeDirIfEmptyOrIsSymlink binDir
#endif
rmBinDir binDir
| isWindows = removeDirIfEmptyOrIsSymlink binDir
| otherwise = do
isXDGStyle <- liftIO useXDG
if not isXDGStyle
then removeDirIfEmptyOrIsSymlink binDir
else pure ()
reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
reportRemainingFiles dir = do
@ -2311,11 +2304,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
m
FilePath
findHadrianFile workdir = do
#if defined(IS_WINDOWS)
let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
#else
let possible_files = ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
#endif
let possible_files = if isWindows
then ((workdir </> "hadrian") </>) <$> ["build.bat"]
else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
case filter fst exsists of
[] -> throwE HadrianNotFound
@ -2489,9 +2480,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
#if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"]
#endif
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)
@ -2505,9 +2494,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ ["--prefix=" <> ghcdir]
#if defined(IS_WINDOWS)
++ ["--enable-tarballs-autodownload"]
#endif
++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
++ fmap T.unpack aargs
)
(Just workdir)

View File

@ -22,13 +22,21 @@ installation and introspection of files/versions etc.
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
#if defined(IS_WINDOWS)
, module GHCup.Utils.Windows
#else
, module GHCup.Utils.Posix
#endif
)
where
#if defined(IS_WINDOWS)
import GHCup.Download
import GHCup.Utils.Windows
#else
import GHCup.Utils.Posix
#endif
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
@ -51,9 +59,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
@ -69,11 +74,6 @@ import Safe
import System.Directory hiding ( findFiles )
import System.FilePath
import System.IO.Error
#if defined(IS_WINDOWS)
import System.Win32.Console
import System.Win32.File hiding ( copyFile )
import System.Win32.Types
#endif
import Text.Regex.Posix
import URI.ByteString
@ -1000,50 +1000,17 @@ getVersionInfo v' tool =
-- | The file extension for executables.
exeExt :: String
#if defined(IS_WINDOWS)
exeExt = ".exe"
#else
exeExt = ""
#endif
exeExt
| isWindows = ".exe"
| otherwise = ""
-- | The file extension for executables.
exeExt' :: ByteString
#if defined(IS_WINDOWS)
exeExt' = ".exe"
#else
exeExt' = ""
#endif
exeExt'
| isWindows = ".exe"
| otherwise = ""
-- | Enables ANSI support on windows, does nothing on unix.
--
-- Returns 'Left str' on errors and 'Right bool' on success, where
-- 'bool' markes whether ansi support was already enabled.
--
-- This function never crashes.
--
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
enableAnsiSupport :: IO (Either String Bool)
#if defined(IS_WINDOWS)
enableAnsiSupport = handleIO (pure . Left . displayException) $ do
-- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
-- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
-- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
m <- getConsoleMode h
-- VT processing not already enabled?
if ((m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING) == 0)
-- https://docs.microsoft.com/en-us/windows/console/setconsolemode
then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
>> pure (Right False)
else pure (Right True)
#else
enableAnsiSupport = pure (Right True)
#endif
-- | On unix, we can use symlinks, so we just get the
@ -1052,33 +1019,27 @@ enableAnsiSupport = pure (Right True)
-- On windows, we have to emulate symlinks via shims,
-- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath
getLinkTarget fp = do
#if defined(IS_WINDOWS)
content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p
#else
getSymbolicLinkTarget fp
#endif
getLinkTarget fp
| isWindows = do
content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p
| otherwise = getSymbolicLinkTarget fp
-- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool
#if defined(IS_WINDOWS)
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
#else
pathIsLink = pathIsSymbolicLink
#endif
pathIsLink fp
| isWindows = doesPathExist (dropExtension fp <.> "shim")
| otherwise = pathIsSymbolicLink fp
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS)
rmLink fp = do
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else
rmLink = hideError doesNotExistErrorType . recycleFile
#endif
rmLink fp
| isWindows = do
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
| otherwise = hideError doesNotExistErrorType . recycleFile $ fp
-- | Creates a symbolic link on unix and a fake symlink on windows for
@ -1102,31 +1063,30 @@ createLink :: ( MonadMask m
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe = do
#if defined(IS_WINDOWS)
dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe"
createLink link exe
| isWindows = do
dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
logDebug $ "rm -f " <> T.pack exe
rmLink exe
logDebug $ "rm -f " <> T.pack exe
rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
| otherwise = do
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
#endif
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
ensureGlobalTools :: ( MonadMask m
@ -1141,23 +1101,20 @@ ensureGlobalTools :: ( MonadMask m
, MonadFail m
)
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _ _) -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
pure ()
#else
pure ()
#endif
ensureGlobalTools
| isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
| otherwise = pure ()
-- | Ensure ghcup directory structure exists.

View File

@ -25,9 +25,7 @@ module GHCup.Utils.Dirs
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
#if !defined(IS_WINDOWS)
, useXDG
#endif
, cleanupTrash
)
where
@ -75,26 +73,25 @@ import Control.Concurrent (threadDelay)
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
ghcupBaseDir = do
#if defined(IS_WINDOWS)
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
ghcupBaseDir
| isWindows = do
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
-- | ~/.ghcup by default
@ -102,45 +99,41 @@ ghcupBaseDir = do
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
#endif
ghcupConfigDir
| isWindows = ghcupBaseDir
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
-- | 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 FilePath
ghcupBinDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "bin")
#else
xdg <- useXDG
if xdg
then do
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
ghcupBinDir
| isWindows = ghcupBaseDir <&> (</> "bin")
| otherwise = do
xdg <- useXDG
if xdg
then do
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'.
@ -148,21 +141,19 @@ ghcupBinDir = do
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO FilePath
ghcupCacheDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "cache")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
ghcupCacheDir
| isWindows = ghcupBaseDir <&> (</> "cache")
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
-- | Defaults to '~/.ghcup/logs'.
@ -170,21 +161,19 @@ ghcupCacheDir = do
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO FilePath
ghcupLogsDir = do
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "logs")
#else
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
ghcupLogsDir
| isWindows = ghcupBaseDir <&> (</> "logs")
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
-- | '~/.ghcup/trash'.
@ -320,10 +309,8 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
--------------
#if !defined(IS_WINDOWS)
useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
#endif
relativeSymlink :: FilePath -- ^ the path in which to create the symlink

14
lib/GHCup/Utils/Posix.hs Normal file
View File

@ -0,0 +1,14 @@
module GHCup.Utils.Posix where
-- | Enables ANSI support on windows, does nothing on unix.
--
-- Returns 'Left str' on errors and 'Right bool' on success, where
-- 'bool' markes whether ansi support was already enabled.
--
-- This function never crashes.
--
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
enableAnsiSupport :: IO (Either String Bool)
enableAnsiSupport = pure (Right True)

View File

@ -17,14 +17,25 @@ Portability : portable
GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Utils.Prelude where
module GHCup.Utils.Prelude
(module GHCup.Utils.Prelude,
#if defined(IS_WINDOWS)
import GHCup.Types
module GHCup.Utils.Prelude.Windows
#else
module GHCup.Utils.Prelude.Posix
#endif
)
where
import GHCup.Types
import GHCup.Errors
import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger
#if defined(IS_WINDOWS)
import GHCup.Utils.Prelude.Windows
#else
import GHCup.Utils.Prelude.Posix
#endif
import Control.Applicative
import Control.Exception.Safe
@ -45,17 +56,13 @@ import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp
#endif
import System.IO.Unsafe
import System.Directory
import System.FilePath
#if defined(IS_WINDOWS)
import Control.Retry
import GHC.IO.Exception
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
@ -69,9 +76,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
#if defined(IS_WINDOWS)
import qualified System.Win32.File as Win32
#endif
-- $setup
@ -438,19 +442,17 @@ recyclePathForcibly :: ( MonadIO m
)
=> FilePath
-> m ()
recyclePathForcibly fp = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removePathForcibly fp
#endif
recyclePathForcibly fp
| isWindows = do
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (moveFile fp dest)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removePathForcibly fp
rmPathForcibly :: ( MonadIO m
@ -458,23 +460,17 @@ rmPathForcibly :: ( MonadIO m
)
=> FilePath
-> m ()
rmPathForcibly fp =
#if defined(IS_WINDOWS)
recover (liftIO $ removePathForcibly fp)
#else
liftIO $ removePathForcibly fp
#endif
rmPathForcibly fp
| isWindows = recover (liftIO $ removePathForcibly fp)
| otherwise = liftIO $ removePathForcibly fp
rmDirectory :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmDirectory fp =
#if defined(IS_WINDOWS)
recover (liftIO $ removeDirectory fp)
#else
liftIO $ removeDirectory fp
#endif
rmDirectory fp
| isWindows = recover (liftIO $ removeDirectory fp)
| otherwise = liftIO $ removeDirectory fp
-- https://www.sqlite.org/src/info/89f1848d7f
@ -486,20 +482,18 @@ recycleFile :: ( MonadIO m
)
=> FilePath
-> m ()
recycleFile fp = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removeFile fp
#endif
recycleFile fp
| isWindows = do
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
liftIO (moveFile fp dest)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removeFile fp
rmFile :: ( MonadIO m
@ -507,26 +501,19 @@ rmFile :: ( MonadIO m
)
=> FilePath
-> m ()
rmFile fp =
#if defined(IS_WINDOWS)
recover (liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
rmFile fp
| isWindows = recover (liftIO $ removeFile fp)
| otherwise = liftIO $ removeFile fp
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
=> FilePath
-> m ()
rmDirectoryLink fp =
#if defined(IS_WINDOWS)
recover (liftIO $ removeDirectoryLink fp)
#else
liftIO $ removeDirectoryLink fp
#endif
rmDirectoryLink fp
| isWindows = recover (liftIO $ removeDirectoryLink fp)
| otherwise = liftIO $ removeDirectoryLink fp
#if defined(IS_WINDOWS)
recover :: (MonadIO m, MonadMask m) => m a -> m a
recover action =
recovering (fullJitterBackoff 25000 <> limitRetries 10)
@ -535,7 +522,6 @@ recover action =
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> action)
#endif
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
@ -752,5 +738,3 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
breakOn _ [] = ([], [])
breakOn needle (x:xs) = first (x:) $ breakOn needle xs

View File

@ -0,0 +1,20 @@
module GHCup.Utils.Prelude.Posix where
import System.Directory
import System.Posix.Files
isWindows, isNotWindows :: Bool
isWindows = False
isNotWindows = not isWindows
moveFile :: FilePath -> FilePath -> IO ()
moveFile = rename
moveFilePortable :: FilePath -> FilePath -> IO ()
moveFilePortable from to = do
copyFile from to
removeFile from

View File

@ -0,0 +1,17 @@
module GHCup.Utils.Prelude.Windows where
import qualified System.Win32.File as Win32
isWindows, isNotWindows :: Bool
isWindows = True
isNotWindows = not isWindows
moveFile :: FilePath -> FilePath -> IO ()
moveFile from to = Win32.moveFileEx from (Just to) 0
moveFilePortable :: FilePath -> FilePath -> IO ()
moveFilePortable = Win32.moveFile

View File

@ -0,0 +1,48 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Utils.Windows where
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Data.Bits
import System.Win32.Console
import System.Win32.File hiding ( copyFile )
import System.Win32.Types
-- | Enables ANSI support on windows, does nothing on unix.
--
-- Returns 'Left str' on errors and 'Right bool' on success, where
-- 'bool' markes whether ansi support was already enabled.
--
-- This function never crashes.
--
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
enableAnsiSupport :: IO (Either String Bool)
enableAnsiSupport = handleIO (pure . Left . displayException) $ do
-- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
-- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
-- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
m <- getConsoleMode h
-- VT processing not already enabled?
if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
-- https://docs.microsoft.com/en-us/windows/console/setconsolemode
then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
>> pure (Right False)
else pure (Right True)