diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index 64c1c40..1db45e2 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -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 diff --git a/ghcup.cabal b/ghcup.cabal index d47941f..5eb5128 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 72353eb..3e20f30 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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/\@ 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) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 94434a8..a07229b 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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. diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index a22bd73..f2778ab 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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 diff --git a/lib/GHCup/Utils/Posix.hs b/lib/GHCup/Utils/Posix.hs new file mode 100644 index 0000000..4b2dcee --- /dev/null +++ b/lib/GHCup/Utils/Posix.hs @@ -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) + diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 0d085af..080bfa0 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -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 - - diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs new file mode 100644 index 0000000..22ae3cb --- /dev/null +++ b/lib/GHCup/Utils/Prelude/Posix.hs @@ -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 + diff --git a/lib/GHCup/Utils/Prelude/Windows.hs b/lib/GHCup/Utils/Prelude/Windows.hs new file mode 100644 index 0000000..914b374 --- /dev/null +++ b/lib/GHCup/Utils/Prelude/Windows.hs @@ -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 + diff --git a/lib/GHCup/Utils/Windows.hs b/lib/GHCup/Utils/Windows.hs new file mode 100644 index 0000000..14ffbd8 --- /dev/null +++ b/lib/GHCup/Utils/Windows.hs @@ -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) +