hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'reduce-win-cpp'

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
app/ghcup/GHCup/OptParse/List.hs
View File

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

48
ghcup.cabal
View File

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

141
lib/GHCup.hs
View File

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

169
lib/GHCup/Utils.hs
View File

@ -22,13 +22,21 @@ installation and introspection of files/versions etc.
module GHCup.Utils module GHCup.Utils
( module GHCup.Utils.Dirs ( module GHCup.Utils.Dirs
, module GHCup.Utils , module GHCup.Utils
#if defined(IS_WINDOWS)
, module GHCup.Utils.Windows
#else
, module GHCup.Utils.Posix
#endif
) )
where where
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
import GHCup.Download import GHCup.Utils.Windows
#else
import GHCup.Utils.Posix
#endif #endif
import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
@ -51,9 +59,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
@ -69,11 +74,6 @@ import Safe
import System.Directory hiding ( findFiles ) import System.Directory hiding ( findFiles )
import System.FilePath import System.FilePath
import System.IO.Error 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 Text.Regex.Posix
import URI.ByteString import URI.ByteString
@ -1000,50 +1000,17 @@ getVersionInfo v' tool =
-- | The file extension for executables. -- | The file extension for executables.
exeExt :: String exeExt :: String
#if defined(IS_WINDOWS) exeExt
exeExt = ".exe" | isWindows = ".exe"
#else | otherwise = ""
exeExt = ""
#endif
-- | The file extension for executables. -- | The file extension for executables.
exeExt' :: ByteString exeExt' :: ByteString
#if defined(IS_WINDOWS) exeExt'
exeExt' = ".exe" | isWindows = ".exe"
#else | otherwise = ""
exeExt' = ""
#endif
-- | 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 -- | 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, -- On windows, we have to emulate symlinks via shims,
-- see 'createLink'. -- see 'createLink'.
getLinkTarget :: FilePath -> IO FilePath getLinkTarget :: FilePath -> IO FilePath
getLinkTarget fp = do getLinkTarget fp
#if defined(IS_WINDOWS) | isWindows = do
content <- readFile (dropExtension fp <.> "shim") content <- readFile (dropExtension fp <.> "shim")
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
pure $ stripNewline $ dropPrefix "path = " p pure $ stripNewline $ dropPrefix "path = " p
#else | otherwise = getSymbolicLinkTarget fp
getSymbolicLinkTarget fp
#endif
-- | Checks whether the path is a link. -- | Checks whether the path is a link.
pathIsLink :: FilePath -> IO Bool pathIsLink :: FilePath -> IO Bool
#if defined(IS_WINDOWS) pathIsLink fp
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim") | isWindows = doesPathExist (dropExtension fp <.> "shim")
#else | otherwise = pathIsSymbolicLink fp
pathIsLink = pathIsSymbolicLink
#endif
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS) rmLink fp
rmLink fp = do | isWindows = do
hideError doesNotExistErrorType . recycleFile $ fp hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else | otherwise = hideError doesNotExistErrorType . recycleFile $ fp
rmLink = hideError doesNotExistErrorType . recycleFile
#endif
-- | Creates a symbolic link on unix and a fake symlink on windows for -- | 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 the target executable
-> FilePath -- ^ path to be created -> FilePath -- ^ path to be created
-> m () -> m ()
createLink link exe = do createLink link exe
#if defined(IS_WINDOWS) | isWindows = do
dirs <- getDirs dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe" let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim" let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute. -- For hardlinks, link needs to be absolute.
-- If link is relative, it's relative to the target exe. -- If link is relative, it's relative to the target exe.
-- Note that (</>) drops lhs when rhs is absolute. -- Note that (</>) drops lhs when rhs is absolute.
fullLink = takeDirectory exe </> link fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink shimContents = "path = " <> fullLink
logDebug $ "rm -f " <> T.pack exe logDebug $ "rm -f " <> T.pack exe
rmLink exe rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents liftIO $ writeFile shim shimContents
#else | otherwise = do
logDebug $ "rm -f " <> T.pack exe logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe hideError doesNotExistErrorType $ recycleFile exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m ensureGlobalTools :: ( MonadMask m
@ -1141,23 +1101,20 @@ ensureGlobalTools :: ( MonadMask m
, MonadFail m , MonadFail m
) )
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m () => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do ensureGlobalTools
#if defined(IS_WINDOWS) | isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo (GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _ _) -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe")) lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe") lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl) ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
pure () | otherwise = pure ()
#else
pure ()
#endif
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.

159
lib/GHCup/Utils/Dirs.hs
View File

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

114
lib/GHCup/Utils/Prelude.hs
View File

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

20
lib/GHCup/Utils/Prelude/Posix.hs Normal file
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

17
lib/GHCup/Utils/Prelude/Windows.hs Normal file
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

48
lib/GHCup/Utils/Windows.hs Normal file
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)