ghcup-hs/lib/GHCup/Utils.hs

1362 lines
50 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
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 #-}
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
2021-10-17 18:39:49 +00:00
#if defined(IS_WINDOWS)
2022-05-21 20:54:18 +00:00
, module GHCup.Prelude.Windows
2021-10-17 18:39:49 +00:00
#else
2022-05-21 20:54:18 +00:00
, module GHCup.Prelude.Posix
2021-10-17 18:39:49 +00:00
#endif
2020-01-11 20:15:05 +00:00
)
where
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.Windows
2021-10-17 18:39:49 +00:00
#else
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.Posix
2021-05-14 21:09:45 +00:00
#endif
2021-10-17 18:39:49 +00:00
import GHCup.Download
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
2022-05-21 20:54:18 +00:00
import GHCup.Version
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal
import GHCup.Prelude.MegaParsec
import GHCup.Prelude.Process
import GHCup.Prelude.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 ) )
import Data.Char ( isHexDigit )
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 )
2021-11-12 18:52:00 +00:00
import Data.Versions hiding ( patch )
2020-01-11 20:15:05 +00:00
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Safe
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
2020-04-25 10:06:41 +00:00
import Text.Regex.Posix
2022-05-21 20:54:18 +00:00
import Text.PrettyPrint.HughesPJClass (prettyShow)
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
2022-05-14 15:58:11 +00:00
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)
import System.Environment (getEnvironment, setEnv)
2023-05-14 13:34:50 +00:00
import Data.Time (Day(..), diffDays, addDays)
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XQuasiQuotes
-- >>> import System.Directory
-- >>> import URI.ByteString
-- >>> import qualified Data.Text as T
2022-05-21 20:54:18 +00:00
-- >>> import GHCup.Prelude
-- >>> import GHCup.Download
-- >>> import GHCup.Version
-- >>> import GHCup.Errors
-- >>> import GHCup.Types
-- >>> import GHCup.Types.Optics
-- >>> import Optics
2022-05-21 20:54:18 +00:00
-- >>> import GHCup.Prelude.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
2021-11-02 00:22:06 +00:00
-- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ]
-- >>> let settings = Settings True 0 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 ]--
------------------------
2022-02-05 18:11:56 +00:00
-- | Create a relative symlink destination for the binary directory,
-- given a target toolpath.
2022-02-09 17:57:59 +00:00
binarySymLinkDestination :: ( MonadThrow m
2022-02-05 18:11:56 +00:00
, MonadIO m
)
2022-02-09 17:57:59 +00:00
=> FilePath -- ^ binary dir
-> FilePath -- ^ the full toolpath
2022-02-05 18:11:56 +00:00
-> m FilePath
2022-02-09 17:57:59 +00:00
binarySymLinkDestination binDir toolPath = do
2022-02-05 18:11:56 +00:00
toolPath' <- liftIO $ canonicalizePath toolPath
binDir' <- liftIO $ canonicalizePath binDir
2022-02-05 18:11:56 +00:00
pure (relativeSymlink binDir' toolPath')
2022-02-05 00:53:04 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
2022-02-05 00:53:04 +00:00
rmMinorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks 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.
2022-02-05 00:53:04 +00:00
rmPlainGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
rmPlainGHC 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.
2022-02-05 00:53:04 +00:00
rmMajorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks 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
2022-02-05 00:53:04 +00:00
-- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'
-- and 'haskell-language-server-wrapper-1.6.1.0'.
rmMinorHLSSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks ver = do
Dirs {..} <- lift getDirs
hlsBins <- hlsAllBinaries ver
forM_ hlsBins $ \f -> do
2022-02-06 21:25:23 +00:00
let fullF = binDir </> f
2022-02-05 00:53:04 +00:00
lift $ logDebug ("rm -f " <> T.pack fullF)
-- on unix, this may be either a file (legacy) or a symlink
-- on windows, this is always a file... hence 'rmFile'
-- works consistently across platforms
lift $ rmFile fullF
-- | Removes the set HLS version, if any.
rmPlainHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Excepts '[NotInstalled] m ()
rmPlainHLS = do
Dirs {..} <- lift getDirs
-- delete 'haskell-language-server-8.10.7'
2022-02-05 18:39:00 +00:00
hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f)))
2022-02-05 00:53:04 +00:00
$ liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
forM_ hlsBins $ \f -> do
let fullF = binDir </> f
lift $ logDebug ("rm -f " <> T.pack fullF)
if isWindows
then lift $ rmLink fullF
else lift $ rmFile fullF
-- 'haskell-language-server-wrapper'
let hlswrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
lift $ logDebug ("rm -f " <> T.pack hlswrapper)
if isWindows
then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper
else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper
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 (fromGHCupPath ghcdir)
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
)
<* MP.some pathSep
2021-05-14 21:09:45 +00:00
<* MP.takeRest
<* MP.eof
ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some 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
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectoryDirs (fromGHCupPath 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/"
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some 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
2022-02-05 00:53:04 +00:00
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
-- as well as @~\/.ghcup\/hls\/<\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)
)
2022-02-05 00:53:04 +00:00
legacy <- 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
2022-02-05 00:53:04 +00:00
hlsdir <- ghcupHLSBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectoryDirs (fromGHCupPath hlsdir)
2022-02-05 00:53:04 +00:00
new <- forM fs $ \f -> case parseGHCupHLSDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
pure (nub (new <> legacy))
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 *> MP.some pathSep
2021-05-14 21:09:45 +00:00
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
2021-05-14 21:09:45 +00:00
-- 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
2022-02-05 18:11:56 +00:00
isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
isLegacyHLS ver = do
bdir <- ghcupHLSDir ver
not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir)
-- 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 *> MP.some pathSep
2021-05-14 21:09:45 +00:00
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet)
2021-05-14 21:09:45 +00:00
-- 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
2022-02-05 00:53:04 +00:00
-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, 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
)
)
2022-02-05 18:11:56 +00:00
-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
-- Returns the full path.
hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
2022-02-05 00:53:04 +00:00
=> Version
2022-02-05 18:11:56 +00:00
-> Maybe Version -- ^ optional GHC version
2022-02-05 00:53:04 +00:00
-> m [FilePath]
2022-02-05 18:11:56 +00:00
hlsInternalServerScripts ver mghcVer = do
2022-02-05 00:53:04 +00:00
dir <- ghcupHLSDir ver
let bdir = fromGHCupPath dir </> "bin"
2022-02-05 18:39:00 +00:00
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
<$> liftIO (listDirectoryFiles bdir)
2022-02-05 18:11:56 +00:00
-- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.
-- Returns the full path.
hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
=> Version
-> Maybe Version -- ^ optional GHC version
-> m [FilePath]
hlsInternalServerBinaries ver mghcVer = do
dir <- fromGHCupPath <$> ghcupHLSDir ver
2022-02-05 18:11:56 +00:00
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
2022-02-05 18:39:00 +00:00
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
<$> liftIO (listDirectoryFiles bdir)
2022-02-05 18:11:56 +00:00
-- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/
-- directory, if any.
-- Returns the full path.
hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
=> Version
-> Version -- ^ GHC version
-> m [FilePath]
hlsInternalServerLibs ver ghcVer = do
dir <- fromGHCupPath <$> ghcupHLSDir ver
2022-02-05 18:11:56 +00:00
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
fmap (bdir </>) <$> liftIO (listDirectoryFiles bdir)
2022-02-05 00:53:04 +00:00
-- | 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)
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 _ (Chunks (Numeric x :| Numeric y : _)) _ _) = pure (fromIntegral x, fromIntegral y)
getMajorMinorV _ = throwM $ ParseError "Could not parse X.Y from version"
2020-04-25 10:06:41 +00:00
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
2021-11-02 00:22:06 +00:00
(pvp_, rest) <- versionToPVP _tvVersion
pure (pvp_, rest, _tvTarget)
getGHCForPVP' pvpIn ghcs' mt
-- | Like 'getGHCForPVP', except with explicit input parameter.
--
2021-11-02 00:22:06 +00:00
-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
-- >>> 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
2021-11-02 00:22:06 +00:00
-> [(PVP, Text, Maybe Text)] -- ^ installed GHCs
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForPVP' pvpIn ghcs' mt = do
let mResult = lastMay
2021-11-02 00:22:06 +00:00
. sortBy (\(x, _, _) (y, _, _) -> compare x y)
. filter
2021-11-02 00:22:06 +00:00
(\(pvp_, _, target) ->
target == mt && matchPVPrefix pvp_ pvpIn
)
$ ghcs'
2021-11-02 00:22:06 +00:00
forM mResult $ \(pvp_, rest, target) -> do
ver' <- pvpToVersion pvp_ rest
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
2023-07-07 08:41:58 +00:00
-> Maybe Text
-> PVP
-> GHCupDownloads
2023-07-07 08:41:58 +00:00
-> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor tool target pvpIn dls = do
let ls :: [(GHCTargetVersion, VersionInfo)]
ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
let ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps = catMaybes $ fmap (\(v, vi) -> (,vi, _tvTarget v) <$> versionToPVP (_tvVersion v)) ls
pure . fmap (\((pv', _), vi, mt) -> (pv', vi, mt)) . headMay . filter (\((v, _), _, t) -> matchPVPrefix pvpIn v && t == target) $ 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
let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) 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.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents
2021-04-02 14:54:27 +00:00
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)
=> GHCupPath -- ^ unpacked tar dir
2020-08-06 11:28:20 +00:00
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m GHCupPath
2020-08-06 11:28:20 +00:00
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
2022-05-14 15:58:11 +00:00
whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr))
2020-08-06 11:28:20 +00:00
(throwE $ TarDirDoesNotExist tardir)
pure (bdir `appendGHCupPath` pr)
2020-08-06 11:28:20 +00:00
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 ->
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
2020-08-06 11:28:20 +00:00
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y `appendGHCupPath` 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
2023-07-07 08:41:58 +00:00
-> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id
2020-01-11 20:15:05 +00:00
2023-07-07 08:41:58 +00:00
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
2023-05-14 13:34:50 +00:00
getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m ->
maybe m (\d -> let diff = diffDays d day
in Map.insert (abs diff) (diff, (k, vi)) m) _viReleaseDay)
Map.empty mvv
in case headMay (Map.toAscList mdv) of
Nothing -> Left Nothing
Just (absDiff, (diff, (k, vi)))
| absDiff == 0 -> Right (k, vi)
| otherwise -> Left (Just (addDays diff day))
2023-07-07 08:41:58 +00:00
getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id
2023-07-07 08:41:58 +00:00
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, 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
2023-07-07 08:41:58 +00:00
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av
2023-07-07 08:41:58 +00:00
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av
2023-07-07 08:41:58 +00:00
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, 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.
2023-07-07 08:41:58 +00:00
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, 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 ]--
-------------
2022-02-05 18:11:56 +00:00
-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> m FilePath
ghcInternalBinDir ver = do
ghcdir <- fromGHCupPath <$> ghcupGHCDir ver
2022-02-05 18:11:56 +00:00
pure (ghcdir </> "bin")
2020-01-11 20:15:05 +00:00
2022-02-05 18:11:56 +00:00
-- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@
2020-07-21 23:08:58 +00:00
-- 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
2022-02-05 18:11:56 +00:00
bindir <- ghcInternalBinDir ver
2020-01-11 20:15:05 +00:00
-- fail if ghc is not installed
2022-02-05 18:11:56 +00:00
whenM (fmap not $ ghcInstalled ver)
(throwE (NotInstalled GHC ver))
2020-01-11 20:15:05 +00:00
files <- liftIO (listDirectoryFiles 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
-- | Calls gmake if it exists in PATH, otherwise make.
make :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
2021-11-11 23:58:21 +00:00
, HasLog 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 = make' args workdir "ghc-make" Nothing
-- | Calls gmake if it exists in PATH, otherwise make.
make' :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
)
=> [String]
-> Maybe FilePath
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
make' args workdir logfile menv = 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"
execLogged mymake args workdir logfile menv
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. The order is determined by
-- a quilt series file (in the patch directory) if one exists,
-- else the patches are applied in lexicographical 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 ()
2022-01-12 12:31:10 +00:00
applyPatches pdir ddir = do
let lexicographical = (fmap . fmap) (pdir </>) $ sort <$> findFiles
pdir
(makeRegexOpts compExtended
execBlank
([s|.+\.(patch|diff)$|] :: ByteString)
)
2022-01-12 12:31:10 +00:00
let quilt = map (pdir </>) . lines <$> readFile (pdir </> "series")
patches <- liftIO $ quilt `catchIO` (\e ->
if isDoesNotExistError e || isPermissionError e then
lexicographical
else throwIO e)
forM_ patches $ \patch' -> applyPatch patch' ddir
2021-11-12 18:52:00 +00:00
applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath -- ^ Patch
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatch patch ddir = do
lift $ logInfo $ "Applying patch " <> T.pack patch
fmap (either (const Nothing) Just)
(exec
"patch"
["-p1", "-s", "-f", "-i", patch]
(Just ddir)
Nothing)
!? PatchFailed
2020-04-10 17:27:17 +00:00
2022-05-21 20:54:18 +00:00
applyAnyPatch :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadCatch m
, MonadResource m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
2022-05-21 20:54:18 +00:00
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing Nothing tmpUnpack Nothing False
2022-05-21 20:54:18 +00:00
liftE $ applyPatch patch workdir
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 ()
2022-05-13 09:58:01 +00:00
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
2023-07-07 08:41:58 +00:00
getChangeLog dls tool (GHCVersion v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls
2023-07-07 08:41:58 +00:00
getChangeLog dls tool (ToolVersion (mkTVer -> v')) =
preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolTag tag) =
preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls
getChangeLog dls tool (ToolDay day) =
preview (ix tool % pre (getByReleaseDayFold day) % 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
2021-10-10 18:02:15 +00:00
runBuildAction :: ( MonadReader env m
2021-07-22 13:45:08 +00:00
, 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
)
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a
2021-10-10 18:02:15 +00:00
-> Excepts e m a
runBuildAction bdir action = do
Settings {..} <- lift getSettings
2020-07-31 18:10:40 +00:00
let exAction = do
2020-04-22 16:12:40 +00:00
when (keepDirs == Never)
2021-10-10 18:02:15 +00:00
$ rmBDir bdir
2020-07-31 18:10:40 +00:00
v <-
2021-10-10 18:02:15 +00:00
flip onException (lift exAction)
$ onE_ exAction action
2021-07-22 13:45:08 +00:00
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
2021-10-10 18:02:15 +00:00
-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanUpOnError :: forall e m a env .
( MonadReader env m
2021-10-10 18:02:15 +00:00
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
2021-10-10 18:02:15 +00:00
-> Excepts e m a
-> Excepts e m a
cleanUpOnError bdir action = do
Settings {..} <- lift getSettings
let exAction = when (keepDirs == Never) $ rmBDir bdir
flip onException (lift exAction) $ onE_ exAction action
-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanFinally :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a
-> Excepts e m a
cleanFinally bdir action = do
Settings {..} <- lift getSettings
let exAction = when (keepDirs == Never) $ rmBDir bdir
flip finally (lift exAction) $ onE_ exAction action
2021-10-10 18:02:15 +00:00
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.
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> 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 $
"Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e))
2021-07-22 13:45:08 +00:00
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
2023-07-07 08:41:58 +00:00
getVersionInfo :: GHCTargetVersion
-> 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
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
)
=> Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
2021-10-17 18:39:49 +00:00
ensureGlobalTools
| isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools
2021-10-17 18:39:49 +00:00
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 (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
2021-10-17 18:39:49 +00:00
| otherwise = pure ()
2021-06-13 11:41:06 +00:00
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
2022-05-20 21:19:33 +00:00
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do
createDirRecursive' (fromGHCupPath baseDir)
createDirRecursive' (fromGHCupPath baseDir </> "ghc")
2022-05-20 21:19:33 +00:00
createDirRecursive' (fromGHCupPath baseDir </> "hls")
2021-06-13 11:41:06 +00:00
createDirRecursive' binDir
createDirRecursive' (fromGHCupPath cacheDir)
createDirRecursive' (fromGHCupPath logsDir)
createDirRecursive' (fromGHCupPath confDir)
createDirRecursive' (fromGHCupPath trashDir)
createDirRecursive' (fromGHCupPath dbDir)
2022-05-20 21:19:33 +00:00
createDirRecursive' (fromGHCupPath tmpDir)
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
2021-07-15 20:38:42 +00:00
--
-- For ghc with arch triple:
--
-- - <triple>-ghc (e.g. arm-linux-gnueabihf-ghc)
2021-07-15 20:38:42 +00:00
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)
2022-02-05 00:53:04 +00:00
-- | Does basic checks for isolated installs
-- Isolated Directory:
-- 1. if it doesn't exist -> proceed
-- 2. if it exists and is empty -> proceed
-- 3. if it exists and is non-empty -> panic and leave the house
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
2022-05-14 15:58:11 +00:00
, MonadMask m
2022-02-05 00:53:04 +00:00
) =>
InstallDirResolved ->
2022-02-05 00:53:04 +00:00
Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved isoDir) = do
2022-02-05 00:53:04 +00:00
hideErrorDef [doesNotExistErrorType] () $ do
2022-05-14 15:58:11 +00:00
empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir
when (not empty') (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()
-- | Returns 'Nothing' for legacy installs.
getInstalledFiles :: ( MonadIO m
, MonadCatch m
, MonadReader env m
, HasDirs env
, MonadFail m
)
=> Tool
-> GHCTargetVersion
-> m (Maybe [FilePath])
getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
f <- recordedInstallationFile t v'
(force -> !c) <- liftIO
(readFile f >>= evaluate)
pure (Just $ lines c)
2022-05-21 20:54:18 +00:00
-- | Warn if the installed and set HLS is not compatible with the installed and
-- set GHC version.
warnAboutHlsCompatibility :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadCatch m
, MonadIO m
)
=> m ()
warnAboutHlsCompatibility = do
supportedGHC <- hlsGHCVersions
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
currentHLS <- hlsSet
case (currentGHC, currentHLS) of
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
logWarn $
"GHC-" <> T.pack (prettyShow gv) <> " appears to have no corresponding HLS-" <> T.pack (prettyShow hv) <> " binary." <> "\n" <>
"Haskell IDE support may not work." <> "\n" <>
"You can try to either: " <> "\n" <>
" 1. Install a different HLS version (e.g. downgrade for older GHCs)" <> "\n" <>
" 2. Install and set one of the following GHCs: " <> T.pack (prettyShow supportedGHC) <> "\n" <>
" 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " <> T.pack (prettyShow hv) <> " --ghc " <> T.pack (prettyShow gv) <> " --cabal-update\n" <>
" (see https://www.haskell.org/ghcup/guide/#hls for more information)"
2022-05-21 20:54:18 +00:00
_ -> return ()
addToPath :: FilePath
-> Bool -- ^ if False will prepend
-> IO [(String, String)]
addToPath path append = do
cEnv <- Map.fromList <$> getEnvironment
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
{- HLINT ignore "Redundant bracket" -}
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
liftIO $ setEnv pathVar newPath
return envWithNewPath
-----------
--[ Git ]--
-----------
isCommitHash :: String -> Bool
isCommitHash str' = let hex = all isHexDigit str'
len = length str'
in hex && len == 40
gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut args dir = do
CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)
case _exitCode of
ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
ExitFailure c -> do
let pe = NonZeroExit c "git" args
lift $ logDebug $ T.pack (prettyHFError pe)
throwE pe
processBranches :: T.Text -> [String]
processBranches str' = let lines' = lines (T.unpack str')
words' = fmap words lines'
refs = catMaybes $ fmap (`atMay` 1) words'
branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
in branches