ghcup-hs/lib/GHCup/Utils.hs

941 lines
31 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
Portability : POSIX
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
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
2020-04-25 10:06:41 +00:00
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
#if !defined(TAR)
import Codec.Archive hiding ( Directory )
#endif
2020-01-11 20:15:05 +00:00
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
import Control.Monad.Reader
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-08-06 11:28:20 +00:00
import Data.List.Split
2020-01-11 20:15:05 +00:00
import Data.Maybe
import Data.String.Interpolate
2020-04-25 10:06:41 +00:00
import Data.Text ( Text )
2020-01-11 20:15:05 +00:00
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.IO.Error
2020-03-21 21:19:37 +00:00
import System.Posix.FilePath ( getSearchPath
, takeFileName
)
2020-06-20 12:37:38 +00:00
import System.Posix.Files.ByteString ( readSymbolicLink )
2020-04-25 10:06:41 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#endif
2020-01-11 20:15:05 +00:00
import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
2020-01-11 20:15:05 +00:00
import qualified Data.Map.Strict as Map
#if !defined(TAR)
import qualified Data.Text as T
#endif
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
2020-01-11 20:15:05 +00:00
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
2020-10-23 23:06:53 +00:00
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2020-07-28 23:43:00 +00:00
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
2020-04-25 10:06:41 +00:00
-> GHCTargetVersion
2020-07-28 23:43:00 +00:00
-> m ByteString
ghcLinkDestination tool ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
2020-07-28 23:43:00 +00:00
t <- parseRel tool
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
2021-03-11 16:03:51 +00:00
rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
2020-04-25 10:06:41 +00:00
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
2021-03-11 16:03:51 +00:00
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
2020-01-11 20:15:05 +00:00
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
2020-04-25 10:06:41 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Maybe Text -- ^ target
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
2020-04-25 10:06:41 +00:00
rmPlain target = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target
2020-04-25 10:06:41 +00:00
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
2021-03-11 16:03:51 +00:00
let fullF = binDir </> f
2020-04-25 10:06:41 +00:00
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
2021-03-11 16:03:51 +00:00
let hdc_file = binDir </> [rel|haddock-ghc|]
2020-04-25 10:06:41 +00:00
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
2021-03-11 16:03:51 +00:00
rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
2020-04-25 10:06:41 +00:00
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
2020-01-11 20:15:05 +00:00
files <- liftE $ ghcToolFiles tv
2020-04-25 10:06:41 +00:00
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
2021-03-11 16:03:51 +00:00
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
2020-01-11 20:15:05 +00:00
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
2021-04-29 12:47:22 +00:00
-- | Whether the given GHC versin is installed.
2020-10-23 23:06:53 +00:00
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is installed from source.
2020-10-23 23:06:53 +00:00
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is set as the current.
2020-10-23 23:06:53 +00:00
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
2020-04-25 10:06:41 +00:00
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc
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
2020-01-11 20:15:05 +00:00
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
2020-07-28 23:43:00 +00:00
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "ghcLinkVersion" t
2020-04-25 10:06:41 +00:00
where
2020-07-28 23:43:00 +00:00
parser =
(do
_ <- parseUntil1 (MP.chunk "/ghc/")
_ <- MP.chunk "/ghc/"
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
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.
2020-10-23 23:06:53 +00:00
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
2020-04-25 10:06:41 +00:00
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
2020-04-25 10:06:41 +00:00
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals = do
cs <- cabalSet -- for legacy cabal
getInstalledCabals' cs
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Maybe Version
-> m [Either (Path Rel) Version]
getInstalledCabals' cs = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
2021-03-11 16:03:51 +00:00
vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
2020-07-28 19:40:26 +00:00
pure $ maybe vs (\x -> nub $ Right x:vs) cs
2020-07-21 23:08:58 +00:00
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
2020-01-11 20:15:05 +00:00
cabalInstalled ver = do
2021-03-11 16:03:51 +00:00
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
2020-01-11 20:15:05 +00:00
cabalSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
2020-07-28 23:43:00 +00:00
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink cabalbin
2020-07-28 23:43:00 +00:00
if broken
then do
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
pure Nothing
2020-07-28 23:43:00 +00:00
else do
link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
case linkVersion link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where
-- We try to be extra permissive with link destination parsing,
-- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
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 "/" *> MP.chunk "/"
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
2020-01-11 20:15:05 +00:00
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
2020-10-23 23:06:53 +00:00
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledHLSs = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
2021-03-11 16:03:51 +00:00
forM bins $ \f ->
case
2021-03-11 16:03:51 +00:00
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
2021-05-14 22:31:36 +00:00
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^stack-.*$|] :: ByteString)
)
forM bins $ \f ->
case
fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
stackSet = do
AppState {dirs = Dirs {..}} <- ask
let stackBin = binDir </> [rel|stack|]
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink stackBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath stackBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "stack-" *> version'
-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
stackInstalled ver = do
vers <- fmap rights getInstalledStacks
pure $ elem ver vers
-- | Whether the given HLS version is installed.
2020-10-23 23:06:53 +00:00
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
2021-03-11 16:03:51 +00:00
vers <- fmap rights getInstalledHLSs
pure $ elem ver vers
-- Return the currently set hls version, if any.
2020-10-23 23:06:53 +00:00
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
2021-03-11 16:03:51 +00:00
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
2020-10-23 23:06:53 +00:00
hlsGHCVersions :: ( MonadReader AppState m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
2021-03-11 16:03:51 +00:00
(version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version
-> m [Path Rel]
hlsServerBinaries ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
hlsWrapperBinary ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [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.
2020-10-23 23:06:53 +00:00
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
2020-10-23 23:06:53 +00:00
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
. (binDir </>)
)
oldSyms
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
2020-07-21 23:08:58 +00:00
-- | Extract (major, minor) from any version.
2020-04-25 10:06:41 +00:00
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of
2020-10-24 20:55:35 +00:00
((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
2020-04-25 10:06:41 +00:00
_ -> throwM $ ParseError "Could not parse X.Y from version"
matchMajor :: Version -> Int -> Int -> Bool
matchMajor v' major' minor' = case getMajorMinorV v' of
Just (x, y) -> x == major' && y == minor'
Nothing -> False
2020-01-11 20:15:05 +00:00
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
2020-10-23 23:06:53 +00:00
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
2020-04-25 10:06:41 +00:00
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForMajor major' minor' mt = do
ghcs <- rights <$> getInstalledGHCs
pure
2020-01-11 20:15:05 +00:00
. lastMay
2020-04-25 10:06:41 +00:00
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
2020-01-11 20:15:05 +00:00
. filter
2020-04-25 10:06:41 +00:00
(\GHCTargetVersion {..} ->
_tvTarget == mt && matchMajor _tvVersion major' minor'
2020-01-11 20:15:05 +00:00
)
2020-04-25 10:06:41 +00:00
$ ghcs
2020-01-11 20:15:05 +00:00
2020-04-22 14:13:58 +00:00
-- | Get the latest available ghc for X.Y major version.
getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component
-> GHCupDownloads
-> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getLatestGHCFor major' minor' dls =
preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
2020-04-22 14:13:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
2020-01-11 20:15:05 +00:00
unpackToDir dest av = do
2021-03-11 16:03:51 +00:00
fp <- decUTF8Safe . toFilePath <$> basename av
2020-04-17 07:30:45 +00:00
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
2020-01-11 20:15:05 +00:00
fn <- toFilePath <$> basename av
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
2020-07-30 18:04:37 +00:00
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
rf = liftIO . readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
2020-07-30 18:04:37 +00:00
#endif
2020-01-11 20:15:05 +00:00
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
(untar . GZip.decompress =<< rf av)
2020-03-21 21:19:37 +00:00
| ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftE $ rf av
2020-01-11 20:15:05 +00:00
let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
2020-01-11 20:15:05 +00:00
| otherwise -> throwE $ UnknownArchive fn
2021-04-02 14:54:27 +00:00
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
] m [ByteString]
getArchiveFiles av = do
fn <- toFilePath <$> basename av
#if defined(TAR)
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
entries =
lE @Tar.FormatError
. Tar.foldEntries
(\e x -> fmap (Tar.entryPath e :) x)
(Right [])
(\e -> Left e)
. Tar.read
rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
rf = liftIO . readFile
#else
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
#endif
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
(entries . GZip.decompress =<< rf av)
| ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftE $ rf av
let decompressed = Lzma.decompress filecontents
liftE $ entries decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
liftE (entries . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av)
| otherwise -> throwE $ UnknownArchive fn
2020-08-06 11:28:20 +00:00
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
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
let rs = splitOn "/" r
foldlM
(\y x ->
2021-03-11 16:03:51 +00:00
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
2020-08-06 11:28:20 +00:00
[] -> throwE $ TarDirDoesNotExist tardir
2021-03-11 16:03:51 +00:00
(p : _) -> pure (y </> p)) . sort
2020-08-06 11:28:20 +00:00
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
2020-01-11 20:15:05 +00:00
------------
--[ Tags ]--
------------
-- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version.
2020-04-25 10:06:41 +00:00
getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag =
2021-03-11 16:03:51 +00:00
to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% to Map.toDescList
% _head
2020-01-11 20:15:05 +00:00
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getLatest av tool = headOf (ix tool % getTagged Latest) av
2020-01-11 20:15:05 +00:00
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
2021-03-11 16:03:51 +00:00
getRecommended av tool = headOf (ix tool % getTagged Recommended) av
2020-01-11 20:15:05 +00:00
2020-04-22 00:33:35 +00:00
-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
2020-04-25 10:06:41 +00:00
getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer)) av
2020-04-22 00:33:35 +00:00
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
--[ AppState Getter ]--
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache . settings
2020-01-11 20:15:05 +00:00
2020-10-23 23:06:53 +00:00
getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader . settings
2020-04-29 17:12:58 +00:00
2020-01-11 20:15:05 +00:00
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
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
--
-- Returns unversioned relative files, e.g.:
2020-07-21 23:08:58 +00:00
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
2020-10-23 23:06:53 +00:00
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
2020-01-11 20:15:05 +00:00
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC ver))
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
files <- liftIO $ getDirsFiles' bindir
2020-01-11 20:15:05 +00:00
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
2020-04-25 10:06:41 +00:00
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
[ghcbin] <- liftIO $ findFiles
bindir
(makeRegexOpts compExtended
execBlank
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
)
2020-06-20 12:37:38 +00:00
let ghcbinPath = bindir </> ghcbin
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
onlyUnversioned <- if ghcIsHadrian
then pure id
else do
(Just symver) <-
2021-03-11 16:03:51 +00:00
B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
<$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver)
2021-03-11 16:03:51 +00:00
(throwIO $ userError "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
pure $ onlyUnversioned files
2020-06-20 12:37:38 +00:00
where
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
2020-06-20 12:37:38 +00:00
isHadrian :: Path Abs -- ^ ghcbin path
-> IO Bool
isHadrian = fmap (/= SymbolicLink) . getFileType
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.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make.
2020-10-23 23:06:53 +00:00
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
2020-07-13 09:52:34 +00:00
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do
2021-03-11 16:03:51 +00:00
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
2020-03-21 21:19:37 +00:00
let mymake = if has_gmake then "gmake" else "make"
2020-03-24 15:49:18 +00:00
execLogged mymake True args [rel|ghc-make|] workdir Nothing
2021-04-28 16:45:48 +00:00
makeOut :: [ByteString]
-> Maybe (Path Abs)
-> IO CapturedProcess
makeOut args workdir = do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
liftIO $ executeOut mymake args workdir
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ dir containing patches
-> Path Abs -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- liftIO $ getDirsFiles pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
2021-03-11 16:03:51 +00:00
fmap (either (const Nothing) Just)
(liftIO $ exec
"patch"
True
["-p1", "-i", toFilePath patch']
(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
2020-04-10 17:27:17 +00:00
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
True
["-r", "-d", "com.apple.quarantine", toFilePath path]
Nothing
Nothing
darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog dls tool (Left v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls
2020-04-25 10:06:41 +00:00
getChangeLog dls tool (Right tag) =
preview (ix tool % getTagged tag % to snd % viChangeLog % _Just) dls
2020-04-22 16:12:40 +00:00
-- | Execute a build action while potentially cleaning up:
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
2020-10-23 23:06:53 +00:00
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
2020-04-22 16:12:40 +00:00
runBuildAction bdir instdir action = do
2020-10-23 23:06:53 +00:00
AppState { settings = Settings {..} } <- lift ask
2020-07-31 18:10:40 +00:00
let exAction = do
2020-04-22 16:12:40 +00:00
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive 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
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirRecursive newDirPerms
$ p
where
isSymlinkDir e = do
ft <- getFileType p
case ft of
SymbolicLink -> do
rp <- canonicalizePath p
rft <- getFileType rp
case rft of
Directory -> pure ()
_ -> throwIO e
_ -> throwIO e
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
)
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
2021-03-11 16:03:51 +00:00
forFold = \t -> (`traverseFold` t)