ghcup-hs/lib/GHCup/Utils.hs

1096 lines
36 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
2021-04-02 14:54:27 +00:00
{-# LANGUAGE TypeApplications #-}
2020-04-25 10:06:41 +00:00
{-# LANGUAGE ViewPatterns #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
2020-01-11 20:15:05 +00:00
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
import GHCup.Download
#endif
2020-01-11 20:15:05 +00:00
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
2020-04-25 10:06:41 +00:00
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
#if !defined(TAR)
import Codec.Archive hiding ( Directory )
#endif
2021-05-14 21:09:45 +00:00
import Codec.Archive.Zip
2020-01-11 20:15:05 +00:00
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
import Control.Monad.Reader
2021-05-14 21:09:45 +00:00
import Control.Monad.Trans.Resource
hiding ( throwM )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
2020-01-11 20:15:05 +00:00
import Data.ByteString ( ByteString )
2020-04-25 10:06:41 +00:00
import Data.Either
2020-08-06 11:28:20 +00:00
import Data.Foldable
2020-01-11 20:15:05 +00:00
import Data.List
2021-05-14 21:09:45 +00:00
import Data.List.Extra
2020-10-24 20:55:35 +00:00
import Data.List.NonEmpty ( NonEmpty( (:|) ))
2020-01-11 20:15:05 +00:00
import Data.Maybe
import Data.String.Interpolate
2020-04-25 10:06:41 +00:00
import Data.Text ( Text )
2020-01-11 20:15:05 +00:00
import Data.Versions
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Safe
2021-05-14 21:09:45 +00:00
import System.Directory hiding ( findFiles )
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
import System.Win32.Console
import System.Win32.File hiding ( copyFile )
import System.Win32.Types
#endif
2020-04-25 10:06:41 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#endif
2020-01-11 20:15:05 +00:00
import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString.Lazy as BL
2020-01-11 20:15:05 +00:00
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
2020-01-11 20:15:05 +00:00
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
2020-10-23 23:06:53 +00:00
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
2020-04-25 10:06:41 +00:00
-> GHCTargetVersion
2021-05-14 21:09:45 +00:00
-> m FilePath
2020-07-28 23:43:00 +00:00
ghcLinkDestination tool ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
ghcd <- ghcupGHCDir ver
2021-05-14 21:09:45 +00:00
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
2021-03-11 16:03:51 +00:00
rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
2020-04-25 10:06:41 +00:00
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
2021-05-14 21:09:45 +00:00
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
2021-03-11 16:03:51 +00:00
let fullF = binDir </> f_xyz
2021-05-14 21:09:45 +00:00
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Maybe Text -- ^ target
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
2020-04-25 10:06:41 +00:00
rmPlain target = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target
2020-04-25 10:06:41 +00:00
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
2021-05-14 21:09:45 +00:00
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
2020-04-25 10:06:41 +00:00
-- old ghcup
2021-05-14 21:09:45 +00:00
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
2020-04-25 10:06:41 +00:00
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
2021-03-11 16:03:51 +00:00
rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
2020-04-25 10:06:41 +00:00
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
2020-01-11 20:15:05 +00:00
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
2021-05-14 21:09:45 +00:00
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF
2020-01-11 20:15:05 +00:00
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
2021-04-29 12:47:22 +00:00
-- | Whether the given GHC versin is installed.
2020-10-23 23:06:53 +00:00
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is installed from source.
2020-10-23 23:06:53 +00:00
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is set as the current.
2020-10-23 23:06:53 +00:00
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
2021-05-14 21:09:45 +00:00
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc <> exeExt
2020-01-11 20:15:05 +00:00
-- link destination is of the form ../ghc/<ver>/bin/ghc
2020-04-25 10:06:41 +00:00
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
2021-03-11 16:03:51 +00:00
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
2021-05-14 21:09:45 +00:00
link <- liftIO $ getLinkTarget ghcBin
2020-01-11 20:15:05 +00:00
Just <$> ghcLinkVersion link
2020-04-25 10:06:41 +00:00
where
2021-05-14 21:09:45 +00:00
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where
parser =
(do
_ <- parseUntil1 ghcSubPath
_ <- ghcSubPath
r <- parseUntil1 pathSep
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* pathSep
<* MP.takeRest
<* MP.eof
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
2020-04-25 10:06:41 +00:00
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
2021-05-14 21:09:45 +00:00
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
2020-04-25 10:06:41 +00:00
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
2021-05-14 21:09:45 +00:00
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
2020-04-25 10:06:41 +00:00
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
2021-05-14 21:09:45 +00:00
=> m [Either FilePath Version]
getInstalledCabals = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
2021-05-14 21:09:45 +00:00
vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
2021-06-12 20:26:50 +00:00
pure $ nub vs
2020-07-21 23:08:58 +00:00
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
2020-01-11 20:15:05 +00:00
cabalInstalled ver = do
2021-03-11 16:03:51 +00:00
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
2020-01-11 20:15:05 +00:00
cabalSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
2021-05-14 21:09:45 +00:00
let cabalbin = binDir </> "cabal" <> exeExt
2021-06-12 20:26:50 +00:00
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink cabalbin
if broken
then pure Nothing
else do
link <- liftIO
$ handleIO' InvalidArgument
(\e -> pure $ Left (toException e))
$ fmap Right $ getLinkTarget cabalbin
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing
where
-- We try to be extra permissive with link destination parsing,
-- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
2021-05-14 21:09:45 +00:00
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
cabalParse = MP.chunk "cabal-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
2021-05-14 21:09:45 +00:00
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
2021-05-14 21:09:45 +00:00
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
2020-01-11 20:15:05 +00:00
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
2020-10-23 23:06:53 +00:00
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
2021-05-14 21:09:45 +00:00
=> m [Either FilePath Version]
getInstalledHLSs = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
2021-03-11 16:03:51 +00:00
forM bins $ \f ->
case
2021-05-14 21:09:45 +00:00
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
2021-05-14 22:31:36 +00:00
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
2021-05-14 21:09:45 +00:00
=> m [Either FilePath Version]
2021-05-14 22:31:36 +00:00
getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^stack-.*$|] :: ByteString)
)
forM bins $ \f ->
2021-05-14 21:09:45 +00:00
case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
2021-05-14 22:31:36 +00:00
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
2021-05-14 22:31:36 +00:00
stackSet = do
AppState {dirs = Dirs {..}} <- ask
2021-05-14 21:09:45 +00:00
let stackBin = binDir </> "stack" <> exeExt
2021-05-14 22:31:36 +00:00
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink stackBin
2021-05-14 22:31:36 +00:00
if broken
then pure Nothing
else do
link <- liftIO
$ handleIO' InvalidArgument
(\e -> pure $ Left (toException e))
$ fmap Right $ getLinkTarget stackBin
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse stack symlink target with: "#{err}". The symlink #{stackBin} needs to point to valid stack binary, such as 'stack-2.7.1'.|]
pure Nothing
2021-05-14 22:31:36 +00:00
where
2021-05-14 21:09:45 +00:00
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
2021-05-14 22:31:36 +00:00
where
2021-05-14 21:09:45 +00:00
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "stack-2.7.1" -> "2.7.1"
cabalParse = MP.chunk "stack-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
2021-05-14 22:31:36 +00:00
-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
stackInstalled ver = do
vers <- fmap rights getInstalledStacks
pure $ elem ver vers
-- | Whether the given HLS version is installed.
2020-10-23 23:06:53 +00:00
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
2021-03-11 16:03:51 +00:00
vers <- fmap rights getInstalledHLSs
pure $ elem ver vers
-- Return the currently set hls version, if any.
2020-10-23 23:06:53 +00:00
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
2021-05-14 21:09:45 +00:00
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
2021-03-11 16:03:51 +00:00
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
2021-05-14 21:09:45 +00:00
link <- liftIO $ getLinkTarget hlsBin
Just <$> linkVersion link
where
2021-05-14 21:09:45 +00:00
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where
2021-05-14 21:09:45 +00:00
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
-- | Return the GHC versions the currently selected HLS supports.
2020-10-23 23:06:53 +00:00
hlsGHCVersions :: ( MonadReader AppState m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
2021-03-11 16:03:51 +00:00
(version
2021-05-14 21:09:45 +00:00
. T.pack
2021-03-11 16:03:51 +00:00
. fromJust
2021-05-14 21:09:45 +00:00
. stripPrefix "haskell-language-server-"
2021-03-11 16:03:51 +00:00
. head
2021-05-14 21:09:45 +00:00
. splitOn "~"
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version
2021-05-14 21:09:45 +00:00
-> m [FilePath]
hlsServerBinaries ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
2021-05-14 21:09:45 +00:00
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
=> Version
2021-05-14 21:09:45 +00:00
-> m (Maybe FilePath)
hlsWrapperBinary ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
2021-05-14 21:09:45 +00:00
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
)
)
case wrapper of
2021-03-11 16:03:51 +00:00
[] -> pure Nothing
[x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version"
-- | Get all binaries for an hls version, if any.
2021-05-14 21:09:45 +00:00
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
2021-05-14 21:09:45 +00:00
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
2021-05-14 21:09:45 +00:00
( liftIO
. pathIsLink
. (binDir </>)
)
oldSyms
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
2020-07-21 23:08:58 +00:00
-- | Extract (major, minor) from any version.
2020-04-25 10:06:41 +00:00
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of
2020-10-24 20:55:35 +00:00
((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
2020-04-25 10:06:41 +00:00
_ -> throwM $ ParseError "Could not parse X.Y from version"
matchMajor :: Version -> Int -> Int -> Bool
matchMajor v' major' minor' = case getMajorMinorV v' of
Just (x, y) -> x == major' && y == minor'
Nothing -> False
2020-01-11 20:15:05 +00:00
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
2020-10-23 23:06:53 +00:00
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
2020-04-25 10:06:41 +00:00
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForMajor major' minor' mt = do
ghcs <- rights <$> getInstalledGHCs
pure
2020-01-11 20:15:05 +00:00
. lastMay
2020-04-25 10:06:41 +00:00
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
2020-01-11 20:15:05 +00:00
. filter
2020-04-25 10:06:41 +00:00
(\GHCTargetVersion {..} ->
_tvTarget == mt && matchMajor _tvVersion major' minor'
2020-01-11 20:15:05 +00:00
)
2020-04-25 10:06:41 +00:00
$ ghcs
2020-01-11 20:15:05 +00:00
2020-04-22 14:13:58 +00:00
-- | Get the latest available ghc for X.Y major version.
getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component
-> GHCupDownloads
-> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getLatestGHCFor major' minor' dls =
preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
2020-04-22 14:13:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
2021-05-14 21:09:45 +00:00
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
2021-05-14 21:09:45 +00:00
untar = liftIO . Tar.unpack dfp . Tar.read
2020-07-30 18:04:37 +00:00
2021-05-14 21:09:45 +00:00
rf :: MonadIO m => FilePath -> Excepts '[] m BL.ByteString
rf = liftIO . BL.readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
2021-05-14 21:09:45 +00:00
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
2021-05-14 21:09:45 +00:00
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . BL.readFile
2020-07-30 18:04:37 +00:00
#endif
2020-01-11 20:15:05 +00:00
-- extract, depending on file extension
if
2021-05-14 21:09:45 +00:00
| ".tar.gz" `isSuffixOf` fn -> liftE
(untar . GZip.decompress =<< rf av)
2021-05-14 21:09:45 +00:00
| ".tar.xz" `isSuffixOf` fn -> do
filecontents <- liftE $ rf av
2020-01-11 20:15:05 +00:00
let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed
2021-05-14 21:09:45 +00:00
| ".tar.bz2" `isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
2021-05-14 21:09:45 +00:00
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av (unpackInto dfp)
2020-01-11 20:15:05 +00:00
| otherwise -> throwE $ UnknownArchive fn
2021-04-02 14:54:27 +00:00
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ archive path
2021-04-02 14:54:27 +00:00
-> Excepts '[UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
2021-05-14 21:09:45 +00:00
] m [FilePath]
2021-04-02 14:54:27 +00:00
getArchiveFiles av = do
2021-05-14 21:09:45 +00:00
let fn = takeFileName av
2021-04-02 14:54:27 +00:00
#if defined(TAR)
2021-05-14 21:09:45 +00:00
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [FilePath]
2021-04-02 14:54:27 +00:00
entries =
lE @Tar.FormatError
. Tar.foldEntries
(\e x -> fmap (Tar.entryPath e :) x)
(Right [])
(\e -> Left e)
. Tar.read
2021-05-14 21:09:45 +00:00
rf :: MonadIO m => FilePath -> Excepts '[Tar.FormatError] m BL.ByteString
rf = liftIO . BL.readFile
2021-04-02 14:54:27 +00:00
#else
2021-05-14 21:09:45 +00:00
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries = (fmap . fmap) filepath . lE . readArchiveBSL
2021-04-02 14:54:27 +00:00
2021-05-14 21:09:45 +00:00
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . BL.readFile
2021-04-02 14:54:27 +00:00
#endif
-- extract, depending on file extension
if
2021-05-14 21:09:45 +00:00
| ".tar.gz" `isSuffixOf` fn -> liftE
2021-04-02 14:54:27 +00:00
(entries . GZip.decompress =<< rf av)
2021-05-14 21:09:45 +00:00
| ".tar.xz" `isSuffixOf` fn -> do
2021-04-02 14:54:27 +00:00
filecontents <- liftE $ rf av
let decompressed = Lzma.decompress filecontents
liftE $ entries decompressed
2021-05-14 21:09:45 +00:00
| ".tar.bz2" `isSuffixOf` fn ->
2021-04-02 14:54:27 +00:00
liftE (entries . BZip.decompress =<< rf av)
2021-05-14 21:09:45 +00:00
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av $ do
entries' <- getEntries
pure $ fmap unEntrySelector $ Map.keys entries'
2021-04-02 14:54:27 +00:00
| otherwise -> throwE $ UnknownArchive fn
2020-08-06 11:28:20 +00:00
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ unpacked tar dir
2020-08-06 11:28:20 +00:00
-> TarDir -- ^ how to descend
2021-05-14 21:09:45 +00:00
-> Excepts '[TarDirDoesNotExist] m FilePath
2020-08-06 11:28:20 +00:00
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
RegexDir r -> do
2021-05-14 21:09:45 +00:00
let rs = split (`elem` pathSeparators) r
2020-08-06 11:28:20 +00:00
foldlM
(\y x ->
2021-03-11 16:03:51 +00:00
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
2020-08-06 11:28:20 +00:00
[] -> throwE $ TarDirDoesNotExist tardir
2021-03-11 16:03:51 +00:00
(p : _) -> pure (y </> p)) . sort
2020-08-06 11:28:20 +00:00
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
2020-01-11 20:15:05 +00:00
------------
--[ Tags ]--
------------
-- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version.
2020-04-25 10:06:41 +00:00
getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag =
2021-03-11 16:03:51 +00:00
to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% to Map.toDescList
% _head
2020-01-11 20:15:05 +00:00
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getLatest av tool = headOf (ix tool % getTagged Latest) av
2020-01-11 20:15:05 +00:00
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getRecommended av tool = headOf (ix tool % getTagged Recommended) av
2020-01-11 20:15:05 +00:00
2020-04-22 00:33:35 +00:00
-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
2020-04-25 10:06:41 +00:00
getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer)) av
2020-04-22 00:33:35 +00:00
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
--[ AppState Getter ]--
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache . settings
2020-01-11 20:15:05 +00:00
2020-10-23 23:06:53 +00:00
getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader . settings
2020-04-29 17:12:58 +00:00
2020-01-11 20:15:05 +00:00
-------------
--[ Other ]--
-------------
2020-07-21 23:08:58 +00:00
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
2020-01-11 20:15:05 +00:00
--
2021-05-14 21:09:45 +00:00
-- Returns unversioned relative files without extension, e.g.:
2020-07-21 23:08:58 +00:00
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
2020-10-23 23:06:53 +00:00
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2021-05-14 21:09:45 +00:00
-> Excepts '[NotInstalled] m [FilePath]
2020-01-11 20:15:05 +00:00
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
2021-05-14 21:09:45 +00:00
let bindir = ghcdir </> "bin"
2020-01-11 20:15:05 +00:00
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC ver))
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
files <- liftIO $ listDirectory bindir
2020-01-11 20:15:05 +00:00
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
2020-04-25 10:06:41 +00:00
2021-05-14 21:09:45 +00:00
ghcIsHadrian <- liftIO $ isHadrian bindir
onlyUnversioned <- case ghcIsHadrian of
Right () -> pure id
Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
| (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
, not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
_ -> fail "Fatal: Could not find internal GHC version"
2020-04-25 10:06:41 +00:00
2021-05-14 21:09:45 +00:00
pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
2020-06-20 12:37:38 +00:00
where
2021-05-14 21:09:45 +00:00
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
2020-06-20 12:37:38 +00:00
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
2021-05-14 21:09:45 +00:00
isHadrian :: FilePath -- ^ ghcbin path
-> IO (Either [String] ()) -- ^ Right for Hadrian
isHadrian dir = do
-- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-- which also requires us to discover the internal version
-- to filter the correct tool files.
-- We can't use the symlink on windows, so we fall back to some
-- more complicated logic.
fs <- fmap
-- regex over-matches
(filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
$ liftIO $ findFiles
dir
(makeRegexOpts compExtended
execBlank
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
)
if | length fs == 1 -> pure $ Right () -- hadrian
| length fs == 2 -> pure $ Left
(sortOn length fs) -- legacy make, result should
-- be ["ghc", "ghc-8.10.4"]
| otherwise -> fail "isHadrian failed!"
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
2020-01-11 20:15:05 +00:00
-- this GHC was built from source. It contains the build config.
2021-05-14 21:09:45 +00:00
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make.
2020-10-23 23:06:53 +00:00
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
2021-05-14 21:09:45 +00:00
=> [String]
-> Maybe FilePath
2020-07-13 09:52:34 +00:00
-> m (Either ProcessError ())
make args workdir = do
2021-05-14 21:09:45 +00:00
spaths <- liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
2020-03-21 21:19:37 +00:00
let mymake = if has_gmake then "gmake" else "make"
2021-05-14 21:09:45 +00:00
execLogged mymake args workdir "ghc-make" Nothing
2021-05-14 21:09:45 +00:00
makeOut :: (MonadReader AppState m, MonadIO m)
=> [String]
-> Maybe FilePath
-> m CapturedProcess
2021-04-28 16:45:48 +00:00
makeOut args workdir = do
2021-05-14 21:09:45 +00:00
spaths <- liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
let mymake = if has_gmake then "gmake" else "make"
executeOut mymake args workdir
2021-04-28 16:45:48 +00:00
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
2021-05-14 21:09:45 +00:00
applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
2021-05-14 21:09:45 +00:00
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
2021-03-11 16:03:51 +00:00
fmap (either (const Nothing) Just)
2021-05-14 21:09:45 +00:00
(exec
2021-03-11 16:03:51 +00:00
"patch"
2021-05-14 21:09:45 +00:00
["-p1", "-i", patch']
2021-03-11 16:03:51 +00:00
(Just ddir)
Nothing)
!? PatchFailed
2020-04-10 17:27:17 +00:00
2020-07-21 23:08:58 +00:00
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
2021-05-14 21:09:45 +00:00
darwinNotarization :: (MonadReader AppState m, MonadIO m)
=> Platform
-> FilePath
-> m (Either ProcessError ())
2020-04-10 17:27:17 +00:00
darwinNotarization Darwin path = exec
"xattr"
2021-05-14 21:09:45 +00:00
["-r", "-d", "com.apple.quarantine", path]
2020-04-10 17:27:17 +00:00
Nothing
Nothing
darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog dls tool (Left v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls
2020-04-25 10:06:41 +00:00
getChangeLog dls tool (Right tag) =
preview (ix tool % getTagged tag % to snd % viChangeLog % _Just) dls
2020-04-22 16:12:40 +00:00
-- | Execute a build action while potentially cleaning up:
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
2020-10-23 23:06:53 +00:00
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
2020-04-22 16:12:40 +00:00
runBuildAction bdir instdir action = do
2020-10-23 23:06:53 +00:00
AppState { settings = Settings {..} } <- lift ask
2020-07-31 18:10:40 +00:00
let exAction = do
2020-04-22 16:12:40 +00:00
forM_ instdir $ \dir ->
2021-05-14 21:09:45 +00:00
liftIO $ hideError doesNotExistErrorType $ rmPath dir
2020-04-22 16:12:40 +00:00
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
2021-05-14 21:09:45 +00:00
$ rmPath bdir
2020-07-31 18:10:40 +00:00
v <-
flip onException exAction
2020-04-22 16:12:40 +00:00
$ catchAllE
(\es -> do
2020-07-31 18:10:40 +00:00
exAction
2020-04-22 16:12:40 +00:00
throwE (BuildFailed bdir es)
2021-03-11 16:03:51 +00:00
) action
2020-04-22 16:12:40 +00:00
2021-05-14 21:09:45 +00:00
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
pure v
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo
2021-03-11 16:03:51 +00:00
getVersionInfo v' tool =
headOf
( ix tool
% to (Map.filterWithKey (\k _ -> k == v'))
% to Map.elems
% _head
)
2021-05-14 21:09:45 +00:00
-- | The file extension for executables.
exeExt :: String
#if defined(IS_WINDOWS)
exeExt = ".exe"
#else
exeExt = ""
#endif
2021-05-14 21:09:45 +00:00
-- | The file extension for executables.
exeExt' :: ByteString
#if defined(IS_WINDOWS)
exeExt' = ".exe"
#else
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
-- symbolic link target.
--
-- 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
-- | 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
rmLink :: FilePath -> IO ()
#if defined(IS_WINDOWS)
rmLink fp = do
hideError doesNotExistErrorType . liftIO . rmFile $ fp
hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
#else
rmLink = hideError doesNotExistErrorType . liftIO . rmFile
#endif
-- | Creates a symbolic link on unix and a fake symlink on windows for
-- executables, which:
-- 1. is a shim exe
-- 2. has a corresponding .shim file in the same directory that
-- contains the target
--
-- This overwrites previously existing files.
--
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe = do
#if defined(IS_WINDOWS)
AppState { dirs } <- ask
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
$(logDebug) [i|rm -f #{exe}|]
liftIO $ rmLink exe
$(logDebug) [i|ln -s #{fullLink} #{exe}|]
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
liftIO $ hideError doesNotExistErrorType $ rmFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
#else
pure ()
#endif
2021-06-13 11:41:06 +00:00
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories dirs = do
let Dirs
{ baseDir
, binDir
, cacheDir
, logsDir
, confDir
} = dirs
createDirRecursive' baseDir
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
pure ()