ghcup-hs/lib/GHCup/Utils.hs

1174 lines
40 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
2021-09-23 10:53:01 +00:00
import GHCup.Utils.Logger
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
import Codec.Archive hiding ( Directory )
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.Reader
2021-05-14 21:09:45 +00:00
import Control.Monad.Trans.Resource
hiding ( throwM )
2021-07-22 13:45:08 +00:00
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
2021-05-14 21:09:45 +00:00
#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
2020-10-24 20:55:35 +00:00
import Data.List.NonEmpty ( NonEmpty( (:|) ))
2020-01-11 20:15:05 +00:00
import Data.Maybe
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
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
2020-04-25 10:06:41 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import URI.ByteString
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
import qualified Data.List.NonEmpty as NE
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XQuasiQuotes
-- >>> import System.Directory
-- >>> import URI.ByteString
-- >>> import qualified Data.Text as T
-- >>> import GHCup.Utils.Prelude
-- >>> import GHCup.Download
-- >>> import GHCup.Version
-- >>> import GHCup.Errors
-- >>> import GHCup.Types
-- >>> import GHCup.Types.Optics
-- >>> import Optics
-- >>> import GHCup.Utils.Version.QQ
-- >>> import qualified Data.Text.Encoding as E
-- >>> import Control.Monad.Reader
-- >>> import Haskus.Utils.Variant.Excepts
-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
-- >>> dirs' <- getAllDirs
-- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ]
-- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False
-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
-- >>> cwd <- getCurrentDirectory
-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref
2020-01-11 20:15:05 +00:00
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ( MonadReader env m
, HasDirs env
, 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
Dirs {..} <- getDirs
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 env m
, HasDirs env
, MonadIO m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
2021-03-11 16:03:51 +00:00
rmMinorSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs
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-08-30 20:41:58 +00:00
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ 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 env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask 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
Dirs {..} <- lift getDirs
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
2021-08-30 20:41:58 +00:00
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ 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
2021-08-30 20:41:58 +00:00
lift $ logDebug ("rm -f " <> T.pack hdc_file)
lift $ 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 env m
, HasDirs env
, MonadIO m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask 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
Dirs {..} <- lift getDirs
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
2021-09-03 19:00:39 +00:00
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ 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.
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, 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.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, 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.
ghcSet :: (MonadReader env m, HasDirs env, 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
Dirs {..} <- getDirs
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.
getInstalledGHCs :: (MonadReader env m, HasDirs env, 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-*@.
2021-08-30 20:41:58 +00:00
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
)
2021-05-14 21:09:45 +00:00
=> m [Either FilePath Version]
getInstalledCabals = do
Dirs {..} <- getDirs
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 :: (MonadIO m, MonadReader env m, HasDirs env, 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.
2021-08-30 20:41:58 +00:00
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
2020-01-11 20:15:05 +00:00
cabalSet = do
Dirs {..} <- getDirs
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
2021-08-30 20:41:58 +00:00
logWarn $ "Failed to parse cabal symlink target with: "
2021-08-25 16:54:58 +00:00
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack cabalbin
<> " needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
2021-06-12 20:26:50 +00:00
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\>@.
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
2021-05-14 21:09:45 +00:00
=> m [Either FilePath Version]
getInstalledHLSs = do
Dirs {..} <- getDirs
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 env m, HasDirs env, 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
Dirs {..} <- getDirs
2021-05-14 22:31:36 +00:00
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 :>
2021-08-30 20:41:58 +00:00
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
2021-05-14 22:31:36 +00:00
stackSet = do
Dirs {..} <- getDirs
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
2021-08-30 20:41:58 +00:00
logWarn $ "Failed to parse stack symlink target with: "
2021-08-25 16:54:58 +00:00
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack 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 env m, HasDirs env, MonadCatch m) => Version -> m Bool
2021-05-14 22:31:36 +00:00
stackInstalled ver = do
vers <- fmap rights getInstalledStacks
pure $ elem ver vers
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, 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.
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
Dirs {..} <- getDirs
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.
hlsGHCVersions :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
fromMaybe [] <$> forM h hlsGHCVersions'
hlsGHCVersions' :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> Version
-> m [Version]
hlsGHCVersions' v' = do
bins <- hlsServerBinaries v' Nothing
let vers = fmap
(version
. T.pack
. fromJust
. stripPrefix "haskell-language-server-"
. head
. splitOn "~"
)
bins
pure . sortBy (flip compare) . rights $ vers
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version
-> Maybe Version -- ^ optional GHC version
2021-05-14 21:09:45 +00:00
-> m [FilePath]
hlsServerBinaries ver mghcVer = do
Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-|]
<> maybe [s|.*|] escapeVerRex mghcVer
<> [s|~|]
<> escapeVerRex ver
<> E.encodeUtf8 (T.pack exeExt)
<> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Version
2021-05-14 21:09:45 +00:00
-> m (Maybe FilePath)
hlsWrapperBinary ver = do
Dirs {..} <- getDirs
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.
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver Nothing
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks = do
Dirs {..} <- getDirs
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
-- | Match PVP prefix.
--
-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
-- True
-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
-- True
-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
-- False
-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
-- True
matchPVPrefix :: PVP -> PVP -> Bool
matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
toL :: PVP -> [Int]
toL (PVP inner) = fmap fromIntegral $ NE.toList inner
-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
-- PVP version.
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
=> PVP
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForPVP pvpIn mt = do
2020-04-25 10:06:41 +00:00
ghcs <- rights <$> getInstalledGHCs
-- we're permissive here... failed parse just means we have no match anyway
let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
pvp_ <- versionToPVP _tvVersion
pure (pvp_, _tvTarget)
getGHCForPVP' pvpIn ghcs' mt
-- | Like 'getGHCForPVP', except with explicit input parameter.
--
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing
-- "Just 8.10.7"
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
-- "Just 8.8.4"
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
-- "Just 8.10.4"
getGHCForPVP' :: MonadThrow m
=> PVP
-> [(PVP, Maybe Text)] -- ^ installed GHCs
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForPVP' pvpIn ghcs' mt = do
let mResult = lastMay
. sortBy (\(x, _) (y, _) -> compare x y)
. filter
(\(pvp_, target) ->
target == mt && matchPVPrefix pvp_ pvpIn
)
$ ghcs'
forM mResult $ \(pvp_, target) -> do
ver' <- pvpToVersion pvp_
pure (GHCTargetVersion target ver')
-- | Get the latest available ghc for the given PVP version, which
-- may only contain parts.
--
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r
-- Just (PVP {_pComponents = 8 :| [10,7]})
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r
-- Just (PVP {_pComponents = 8 :| [8,4]})
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r
-- Just (PVP {_pComponents = 8 :| [8,4]})
getLatestToolFor :: MonadThrow m
=> Tool
-> PVP
-> GHCupDownloads
-> m (Maybe (PVP, VersionInfo))
getLatestToolFor tool pvpIn dls = do
let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps
2020-04-25 10:06:41 +00:00
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.
2021-08-30 20:41:58 +00:00
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
, ArchiveResult
] m ()
2021-05-14 21:09:45 +00:00
unpackToDir dfp av = do
let fn = takeFileName av
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
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-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)
2021-08-25 18:13:17 +00:00
| ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av)
2020-01-11 20:15:05 +00:00
| otherwise -> throwE $ UnknownArchive fn
2021-08-30 20:41:58 +00:00
getArchiveFiles :: (MonadReader env m, HasLog env, 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
, ArchiveResult
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
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
-- 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)
2021-08-25 18:13:17 +00:00
| ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av)
2021-04-02 14:54:27 +00:00
| otherwise -> throwE $ UnknownArchive fn
2021-08-30 20:41:58 +00:00
intoSubdir :: (MonadReader env m, HasLog env, 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
-> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id
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
-------------
--[ 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"]@
ghcToolFiles :: (MonadReader env m, HasDirs env, 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
files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
2020-06-20 12:37:38 +00:00
where
2021-05-14 21:09:45 +00:00
groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
getUniqueTools :: [[(FilePath, String)]] -> [String]
getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
blackListedTools :: [String]
blackListedTools = ["haddock-ghc"]
isNotAnyInfix :: [String] -> String -> Bool
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
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.
make :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasSettings env
)
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
makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
2021-05-14 21:09:45 +00:00
=> [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-08-30 20:41:58 +00:00
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
2021-05-14 21:09:45 +00:00
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ findFiles
pdir
(makeRegexOpts compExtended
execBlank
([s|.+\.(patch|diff)$|] :: ByteString)
)
forM_ (sort patches) $ \patch' -> do
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "Applying patch " <> T.pack 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
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
2021-05-14 21:09:45 +00:00
=> 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 % pre (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
2021-07-22 13:45:08 +00:00
runBuildAction :: ( Pretty (V e)
, Show (V e)
2021-09-06 20:31:07 +00:00
, PopVariant BuildFailed e
, ToVariantMaybe BuildFailed e
2021-07-22 13:45:08 +00:00
, MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-07-22 13:45:08 +00:00
, MonadUnliftIO m
2021-09-19 19:24:21 +00:00
, MonadFail m
, MonadCatch m
2021-07-22 13:45:08 +00:00
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
2021-05-14 21:09:45 +00:00
-> 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
Settings {..} <- lift getSettings
2020-07-31 18:10:40 +00:00
let exAction = do
2020-04-22 16:12:40 +00:00
forM_ instdir $ \dir ->
2021-07-22 13:45:08 +00:00
lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
2020-04-22 16:12:40 +00:00
when (keepDirs == Never)
2021-07-22 13:45:08 +00:00
$ lift $ rmBDir 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-07-22 13:45:08 +00:00
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
2021-07-22 13:45:08 +00:00
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
2021-08-30 20:41:58 +00:00
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
2021-07-22 13:45:08 +00:00
rmBDir dir = withRunInIO (\run -> run $
2021-08-30 20:41:58 +00:00
liftIO $ handleIO (\e -> run $ logWarn $
2021-08-25 16:54:58 +00:00
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
2021-07-22 13:45:08 +00:00
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
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 :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
rmLink fp = do
2021-07-22 13:45:08 +00:00
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
2021-05-14 21:09:45 +00:00
#else
2021-07-22 13:45:08 +00:00
rmLink = hideError doesNotExistErrorType . recycleFile
2021-05-14 21:09:45 +00:00
#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
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadReader env m
, HasDirs env
2021-05-14 21:09:45 +00:00
, MonadUnliftIO m
, MonadFail m
)
=> FilePath -- ^ path to the target executable
-> FilePath -- ^ path to be created
-> m ()
createLink link exe = do
#if defined(IS_WINDOWS)
dirs <- getDirs
2021-05-14 21:09:45 +00:00
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
2021-08-30 20:41:58 +00:00
logDebug $ "rm -f " <> T.pack exe
rmLink exe
2021-05-14 21:09:45 +00:00
2021-08-30 20:41:58 +00:00
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
2021-05-14 21:09:45 +00:00
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
2021-08-30 20:41:58 +00:00
logDebug $ "rm -f " <> T.pack exe
2021-07-22 13:45:08 +00:00
hideError doesNotExistErrorType $ recycleFile exe
2021-05-14 21:09:45 +00:00
2021-08-30 20:41:58 +00:00
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
2021-05-14 21:09:45 +00:00
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasGHCupInfo env
2021-05-14 21:09:45 +00:00
, MonadUnliftIO m
, MonadFail m
)
2021-09-18 17:45:32 +00:00
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
2021-05-14 21:09:45 +00:00
ensureGlobalTools = do
#if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs
2021-05-14 21:09:45 +00:00
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
2021-07-19 17:08:43 +00:00
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
2021-09-19 19:24:21 +00:00
void $ (\(DigestError _ _ _) -> do
2021-08-30 20:41:58 +00:00
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
2021-09-04 14:06:33 +00:00
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
2021-07-22 13:45:08 +00:00
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
2021-09-18 17:45:32 +00:00
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
2021-05-14 21:09:45 +00:00
pure ()
#else
pure ()
#endif
2021-06-13 11:41:06 +00:00
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
2021-07-22 13:45:08 +00:00
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
2021-06-13 11:41:06 +00:00
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
2021-06-13 11:41:06 +00:00
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
2021-07-22 13:45:08 +00:00
createDirRecursive' trashDir
2021-06-13 11:41:06 +00:00
pure ()
2021-07-15 20:38:42 +00:00
-- | For ghc without arch triple, this is:
--
-- - ghc-<ver> (e.g. ghc-8.10.4)
--
-- For ghc with arch triple:
--
-- - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)