ghcup-hs/lib/GHCup.hs

1064 lines
33 KiB
Haskell
Raw Normal View History

2020-01-14 21:55:34 +00:00
{-# LANGUAGE DataKinds #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE DeriveGeneric #-}
2020-01-14 21:55:34 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
2020-01-14 21:55:34 +00:00
{-# LANGUAGE TemplateHaskell #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE TypeFamilies #-}
2020-02-24 13:56:13 +00:00
{-# LANGUAGE TypeApplications #-}
2020-01-14 21:55:34 +00:00
-- TODO: handle SIGTERM, SIGUSR
module GHCup where
2020-01-16 22:27:38 +00:00
2020-03-01 00:05:02 +00:00
import GHCup.Bash
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
2020-01-14 21:55:34 +00:00
import Control.Applicative
2020-03-01 00:05:02 +00:00
import Control.Exception.Safe
2020-01-16 22:27:38 +00:00
import Control.Monad
2020-02-24 13:56:13 +00:00
import Control.Monad.Fail ( MonadFail )
2020-02-22 18:21:10 +00:00
import Control.Monad.Logger
2020-03-01 00:05:02 +00:00
import Control.Monad.Reader
2020-02-22 18:21:10 +00:00
import Control.Monad.Trans.Class ( lift )
2020-03-01 01:21:40 +00:00
import Control.Monad.Trans.Resource
hiding ( throwM )
2020-02-28 23:33:32 +00:00
import Data.Aeson
import Data.Attoparsec.ByteString
2020-02-18 08:40:01 +00:00
import Data.ByteString ( ByteString )
2020-02-28 23:33:32 +00:00
import Data.ByteString.Builder
2020-02-29 23:07:39 +00:00
import Data.Foldable
2020-03-01 00:05:02 +00:00
import Data.IORef
import Data.List
import Data.Maybe
import Data.String.Interpolate
2020-02-19 19:54:23 +00:00
import Data.String.QQ
2020-01-16 22:27:38 +00:00
import Data.Text ( Text )
import Data.Versions
2020-03-01 00:05:02 +00:00
import Data.Word8
import GHC.IO.Exception
2020-01-14 21:55:34 +00:00
import HPath
import HPath.IO
2020-03-01 00:05:02 +00:00
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
2020-01-14 21:55:34 +00:00
import Optics
import Prelude hiding ( abs
2020-01-16 22:27:38 +00:00
, readFile
2020-01-14 21:55:34 +00:00
)
2020-03-01 00:05:02 +00:00
import Safe
2020-01-17 22:29:16 +00:00
import System.IO.Error
2020-03-01 00:05:02 +00:00
import System.Info
2020-03-01 01:21:40 +00:00
import System.Posix.Env.ByteString ( getEnv )
2020-02-29 23:07:39 +00:00
import System.Posix.FilePath ( takeFileName )
2020-02-24 13:56:13 +00:00
import System.Posix.Files.ByteString ( readSymbolicLink )
2020-01-17 22:29:16 +00:00
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
2020-03-01 00:05:02 +00:00
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import System.Posix.Types
import URI.ByteString
import URI.ByteString.QQ
2020-01-17 22:29:16 +00:00
2020-03-01 00:05:02 +00:00
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.BZip as BZip
2020-02-18 08:40:01 +00:00
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
2020-03-01 00:05:02 +00:00
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU
import qualified System.IO.Streams as Streams
import qualified System.Posix.FilePath as FP
import qualified System.Posix.RawFilePath.Directory
as RD
2020-02-18 08:40:01 +00:00
2020-02-24 13:56:13 +00:00
data Settings = Settings
2020-02-28 23:33:32 +00:00
{ cache :: Bool
, urlSource :: URLSource
2020-02-24 13:56:13 +00:00
}
deriving Show
2020-02-22 18:21:10 +00:00
2020-02-28 23:33:32 +00:00
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
2020-02-22 18:21:10 +00:00
2020-02-18 08:40:01 +00:00
---------------------------
--[ Excepts Error types ]--
---------------------------
2020-02-29 23:07:39 +00:00
data PlatformResultError = NoCompatiblePlatform String
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data NoDownload = NoDownload
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data NoCompatibleArch = NoCompatibleArch String
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data DistroNotFound = DistroNotFound
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data ArchiveError = UnknownArchive ByteString
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
2020-02-19 19:54:23 +00:00
data URLException = UnsupportedURL
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-19 19:54:23 +00:00
2020-02-24 13:56:13 +00:00
data FileError = CopyError String
deriving Show
2020-02-22 18:21:10 +00:00
data TagNotFound = TagNotFound Tag Tool
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-22 18:21:10 +00:00
2020-02-24 13:56:13 +00:00
data AlreadyInstalled = AlreadyInstalled ToolRequest
deriving Show
data NotInstalled = NotInstalled ToolRequest
deriving Show
2020-02-18 08:40:01 +00:00
2020-02-28 23:33:32 +00:00
data NotSet = NotSet Tool
deriving Show
data JSONError = JSONDecodeError String
deriving Show
data ParseError = ParseError String
deriving Show
2020-02-29 23:07:39 +00:00
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
2020-02-28 23:33:32 +00:00
instance Exception ParseError
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
--------------------------------
--[ AvailableDownloads stuff ]--
--------------------------------
2020-02-18 08:40:01 +00:00
2020-01-14 21:55:34 +00:00
2020-02-28 23:33:32 +00:00
ghcupURL :: URI
ghcupURL =
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
2020-02-22 18:21:10 +00:00
-- | Get the tool versions that have this tag.
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: AvailableDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: AvailableDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
2020-02-28 23:33:32 +00:00
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
2020-02-29 23:07:39 +00:00
, MonadCatch m
2020-02-28 23:33:32 +00:00
, MonadReader Settings m
)
2020-02-29 23:07:39 +00:00
=> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
AvailableDownloads
2020-02-28 23:33:32 +00:00
getDownloads = lift getUrlSource >>= \case
GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
2020-02-29 23:07:39 +00:00
(OwnSource url) -> do
bs <- liftE $ downloadBS url
2020-02-28 23:33:32 +00:00
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
2020-02-22 18:21:10 +00:00
----------------------
--[ Download stuff ]--
----------------------
2020-02-28 23:33:32 +00:00
getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
2020-02-22 18:21:10 +00:00
=> ToolRequest
-> Maybe PlatformRequest
-> Excepts
2020-02-29 23:07:39 +00:00
'[ DistroNotFound
, FileDoesNotExistError
, JSONError
2020-02-24 13:56:13 +00:00
, NoCompatibleArch
2020-02-29 23:07:39 +00:00
, NoDownload
, PlatformResultError
2020-02-28 23:33:32 +00:00
, URLException
2020-02-24 13:56:13 +00:00
]
2020-02-22 18:21:10 +00:00
m
DownloadInfo
2020-02-28 23:33:32 +00:00
getDownloadInfo (ToolRequest t v) mpfReq = do
urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
2020-02-22 18:21:10 +00:00
-- lift $ monadLoggerLog undefined undefined undefined ""
2020-02-29 23:07:39 +00:00
(PlatformRequest arch' plat ver) <- case mpfReq of
2020-01-16 22:27:38 +00:00
Just x -> pure x
Nothing -> do
2020-02-18 08:40:01 +00:00
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
2020-01-16 22:27:38 +00:00
pure $ PlatformRequest ar rp rv
2020-02-28 23:33:32 +00:00
dls <- liftE $ getDownloads
2020-01-16 22:27:38 +00:00
2020-02-29 23:07:39 +00:00
lE $ getDownloadInfo' t v arch' plat ver dls
2020-02-22 18:21:10 +00:00
getDownloadInfo' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
2020-02-18 08:40:01 +00:00
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
2020-01-14 21:55:34 +00:00
where
2020-01-16 22:27:38 +00:00
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
2020-02-18 08:40:01 +00:00
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
distro_preview f g =
2020-02-22 18:21:10 +00:00
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
2020-02-28 23:33:32 +00:00
-- | Same as `download'`, except uses URL type. As such, this might
2020-01-17 22:29:16 +00:00
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
2020-02-28 23:33:32 +00:00
download :: (MonadLogger m, MonadIO m)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[URLException] m (Path Abs)
download dli dest mfn
2020-02-22 18:21:10 +00:00
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
2020-02-19 19:54:23 +00:00
| otherwise = throwE UnsupportedURL
2020-01-17 22:29:16 +00:00
2020-02-19 19:54:23 +00:00
where
dl https = do
2020-02-29 23:07:39 +00:00
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
2020-02-19 19:54:23 +00:00
host <-
2020-02-22 18:21:10 +00:00
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
2020-02-19 19:54:23 +00:00
?? UnsupportedURL
2020-02-22 18:21:10 +00:00
let path = view (dlUri % pathL') dli
2020-02-19 19:54:23 +00:00
let port = preview
2020-02-22 18:21:10 +00:00
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
2020-02-28 23:33:32 +00:00
liftIO $ download' https host path port dest mfn
2020-02-29 23:07:39 +00:00
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[FileDoesNotExistError , URLException]
m
L.ByteString
downloadBS uri'
| scheme == [s|https|]
= dl True
| scheme == [s|http|]
= dl False
| scheme == [s|file|]
= liftException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
| otherwise
= throwE UnsupportedURL
2020-02-28 23:33:32 +00:00
where
2020-02-29 23:07:39 +00:00
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
2020-02-28 23:33:32 +00:00
dl https = do
host <-
2020-02-29 23:07:39 +00:00
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
2020-02-28 23:33:32 +00:00
?? UnsupportedURL
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
2020-02-29 23:07:39 +00:00
uri'
2020-02-28 23:33:32 +00:00
liftIO $ downloadBS' https host path port
2020-01-17 22:29:16 +00:00
2020-02-28 23:33:32 +00:00
-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
-- 1. try to guess the filename from the url path
-- 2. otherwise create a random file
--
-- The file must not exist.
download' :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename
-> IO (Path Abs)
download' https host path port dest mfn = do
(fd, fp) <- getFile
let stepper = fdWrite fd
flip finally (closeFd fd) $ downloadInternal https host path port stepper
pure fp
where
-- Manage to find a file we can write the body into.
getFile :: IO (Fd, Path Abs)
getFile = do
-- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of
-- if a filename was provided, try that
Just x ->
let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...otherwise try to infer the filename from the URL path
fn' <- urlBaseName path
let fp = dest </> fn'
fmap (, fp) $ createRegularFileFd newFilePerms fp
-- | Load the result of this download into memory at once.
downloadBS' :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> IO (L.ByteString)
downloadBS' https host path port = do
bref <- newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
downloadInternal https host path port stepper
readIORef bref <&> toLazyByteString
2020-01-17 22:29:16 +00:00
downloadInternal :: Bool
2020-02-19 19:54:23 +00:00
-> ByteString
-> ByteString
-> Maybe Int
2020-02-28 23:33:32 +00:00
-> (ByteString -> IO a) -- ^ the consuming step function
-> IO ()
downloadInternal https host path port consumer = do
2020-01-17 22:29:16 +00:00
c <- case https of
True -> do
ctx <- baselineContextSSL
2020-02-19 19:54:23 +00:00
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
2020-01-17 22:29:16 +00:00
2020-02-28 23:33:32 +00:00
let q = buildRequest1 $ http GET path
2020-01-17 22:29:16 +00:00
sendRequest c q emptyBody
2020-02-28 23:33:32 +00:00
receiveResponse
2020-01-17 22:29:16 +00:00
c
2020-02-29 23:07:39 +00:00
(\_ i' -> do
2020-01-17 22:29:16 +00:00
outStream <- Streams.makeOutputStream
(\case
2020-02-28 23:33:32 +00:00
Just bs -> void $ consumer bs
2020-01-17 22:29:16 +00:00
Nothing -> pure ()
)
2020-02-29 23:07:39 +00:00
Streams.connect i' outStream
2020-01-17 22:29:16 +00:00
)
closeConnection c
2020-01-14 21:55:34 +00:00
2020-02-18 08:40:01 +00:00
--------------------------
--[ Platform detection ]--
--------------------------
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
2020-01-14 21:55:34 +00:00
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
2020-02-18 08:40:01 +00:00
=> Excepts
2020-02-24 13:56:13 +00:00
'[PlatformResultError , DistroNotFound]
2020-02-18 08:40:01 +00:00
m
PlatformResult
2020-02-22 18:21:10 +00:00
getPlatform = do
pfr <- case os of
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
2020-02-29 23:07:39 +00:00
what -> throwE $ NoCompatiblePlatform what
2020-02-28 23:33:32 +00:00
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
2020-02-22 18:21:10 +00:00
pure pfr
2020-02-18 08:40:01 +00:00
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
2020-02-24 13:56:13 +00:00
-- TODO: don't do alternative on IO, because it hides bugs
2020-02-18 08:40:01 +00:00
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
| hasWord name ["debian"] -> Debian
| hasWord name ["ubuntu"] -> Ubuntu
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
| hasWord name ["fedora"] -> Fedora
| hasWord name ["centos"] -> CentOS
| hasWord name ["Red Hat"] -> RedHat
| hasWord name ["alpine"] -> Alpine
| hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
hasWord t matches = foldr
(\x y ->
( isJust
2020-02-22 18:21:10 +00:00
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
2020-02-18 08:40:01 +00:00
$ t
)
|| y
)
False
(T.pack <$> matches)
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
2020-02-24 13:56:13 +00:00
(Just _) <- findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
2020-02-18 08:40:01 +00:00
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap lBS2sT $ readFile redhat_release
let nameRe n =
join
. fmap (ICU.group 0)
. ICU.find
2020-02-22 18:21:10 +00:00
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
2020-02-18 08:40:01 +00:00
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
2020-02-22 18:21:10 +00:00
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
2020-02-18 08:40:01 +00:00
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (name, verRe)
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
ver <- readFile debian_version
pure (T.pack "debian", Just $ lBS2sT ver)
2020-02-22 18:21:10 +00:00
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined
-------------------------
--[ Tool installation ]--
-------------------------
2020-02-24 13:56:13 +00:00
-- TODO: custom logger intepreter and pretty printing
2020-02-22 18:21:10 +00:00
2020-02-28 23:33:32 +00:00
-- | Install a tool, such as GHC or cabal. This also sets
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
2020-02-24 13:56:13 +00:00
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
2020-02-22 18:21:10 +00:00
installTool :: ( MonadThrow m
, MonadReader Settings m
, MonadLogger m
, MonadCatch m
, MonadIO m
2020-02-24 14:09:38 +00:00
, MonadFail m
2020-03-01 01:21:40 +00:00
, MonadResource m
) -- tmp file
2020-02-22 18:21:10 +00:00
=> ToolRequest
2020-02-24 13:56:13 +00:00
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
2020-02-22 18:21:10 +00:00
-> Excepts
2020-02-24 13:56:13 +00:00
'[ AlreadyInstalled
, ArchiveError
, DistroNotFound
2020-02-29 23:07:39 +00:00
, FileDoesNotExistError
, FileError
, JSONError
, NoCompatibleArch
, NoDownload
2020-02-24 14:09:38 +00:00
, NotInstalled
2020-02-29 23:07:39 +00:00
, PlatformResultError
, ProcessError
2020-02-28 23:33:32 +00:00
, URLException
2020-02-24 13:56:13 +00:00
]
2020-02-22 18:21:10 +00:00
m
()
2020-02-28 23:33:32 +00:00
installTool treq mpfReq = do
lift $ $(logDebug) [i|Requested to install: #{treq}|]
2020-02-24 13:56:13 +00:00
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
Settings {..} <- lift ask
-- download (or use cached version)
2020-02-28 23:33:32 +00:00
dlinfo <- liftE $ getDownloadInfo treq mpfReq
2020-02-24 13:56:13 +00:00
dl <- case cache of
2020-02-22 18:21:10 +00:00
True -> do
cachedir <- liftIO $ ghcupCacheDir
fn <- urlBaseName $ view (dlUri % pathL') dlinfo
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> pure $ cachfile
2020-02-28 23:33:32 +00:00
| otherwise -> liftE $ download dlinfo cachedir Nothing
2020-02-22 18:21:10 +00:00
False -> do
2020-03-01 01:21:40 +00:00
tmp <- lift withGHCupTmpDir
2020-02-28 23:33:32 +00:00
liftE $ download dlinfo tmp Nothing
2020-02-24 13:56:13 +00:00
-- unpack
2020-02-22 18:21:10 +00:00
unpacked <- liftE $ unpackToTmpDir dl
2020-02-24 13:56:13 +00:00
-- prepare paths
2020-02-29 23:07:39 +00:00
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
2020-02-24 13:56:13 +00:00
bindir <- liftIO ghcupBinDir
2020-02-22 18:21:10 +00:00
-- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
case treq of
2020-02-28 23:33:32 +00:00
(ToolRequest GHC ver) -> do
2020-02-24 14:09:38 +00:00
liftE $ installGHC archiveSubdir ghcdir
2020-02-28 23:33:32 +00:00
liftE $ setGHC ver SetGHCMinor
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
(mj, mi) <- liftIO $ getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
2020-02-29 23:07:39 +00:00
(ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
2020-02-22 18:21:10 +00:00
pure ()
2020-02-24 13:56:13 +00:00
toolAlreadyInstalled :: ToolRequest -> IO Bool
2020-02-29 23:07:39 +00:00
toolAlreadyInstalled ToolRequest {..} = case _trTool of
GHC -> ghcInstalled _trVersion
Cabal -> cabalInstalled _trVersion
2020-02-24 13:56:13 +00:00
2020-02-24 14:09:38 +00:00
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
2020-02-22 18:21:10 +00:00
installGHC :: (MonadLogger m, MonadIO m)
2020-02-24 13:56:13 +00:00
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
2020-02-22 18:21:10 +00:00
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC path inst = do
2020-02-28 23:33:32 +00:00
lift $ $(logInfo) [s|Installing GHC|]
2020-02-22 18:21:10 +00:00
lEM $ liftIO $ exec [s|./configure|]
[[s|--prefix=|] <> toFilePath inst]
False
(Just path)
lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path)
pure ()
-- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
2020-02-24 13:56:13 +00:00
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
2020-02-22 18:21:10 +00:00
-> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m ()
installCabal path inst = do
2020-02-28 23:33:32 +00:00
lift $ $(logInfo) [s|Installing cabal|]
2020-02-22 18:21:10 +00:00
let cabalFile = [rel|cabal|] :: Path Rel
2020-02-24 14:09:38 +00:00
liftIO $ createDirIfMissing newDirPerms inst
2020-02-24 13:56:13 +00:00
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> cabalFile)
Overwrite
2020-02-22 18:21:10 +00:00
2020-02-18 08:40:01 +00:00
2020-02-28 23:33:32 +00:00
---------------
--[ Set GHC ]--
---------------
2020-02-24 13:56:13 +00:00
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
2020-02-28 23:33:32 +00:00
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
2020-02-24 13:56:13 +00:00
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> SetGHC
-> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
2020-02-28 23:33:32 +00:00
let verBS = verToBS ver
ghcdir <- liftIO $ ghcupGHCDir ver
2020-02-24 13:56:13 +00:00
-- symlink destination
2020-02-28 23:33:32 +00:00
destdir <- liftIO $ ghcupBinDir
2020-03-01 00:05:02 +00:00
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir
2020-02-24 13:56:13 +00:00
-- for ghc tools (ghc, ghci, haddock, ...)
2020-02-28 23:33:32 +00:00
verfiles <- ghcToolFiles ver
2020-02-29 23:07:39 +00:00
forM_ verfiles $ \file -> do
2020-02-24 13:56:13 +00:00
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHCMajor -> do
2020-02-29 23:07:39 +00:00
major' <-
2020-02-28 23:33:32 +00:00
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
<$> getGHCMajor ver
2020-02-29 23:07:39 +00:00
parseRel (toFilePath file <> B.singleton _hyphen <> major')
2020-02-24 13:56:13 +00:00
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
2020-02-28 23:33:32 +00:00
liftIO $ hideError doesNotExistErrorType $ deleteFile
2020-02-24 13:56:13 +00:00
(destdir </> targetFile)
2020-02-28 23:33:32 +00:00
liftIO $ createSymlink (destdir </> targetFile)
(ghcLinkDestination (toFilePath file) ver)
2020-02-24 13:56:13 +00:00
-- create symlink for share dir
2020-02-28 23:33:32 +00:00
liftIO $ symlinkShareDir ghcdir verBS
2020-02-24 13:56:13 +00:00
pure ()
where
2020-02-28 23:33:32 +00:00
symlinkShareDir :: Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir verBS = do
destdir <- ghcupBaseDir
case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> sharedir)
createSymlink
(destdir </> sharedir)
2020-03-01 00:37:09 +00:00
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
2020-02-28 23:33:32 +00:00
_ -> pure ()
------------------
--[ List tools ]--
------------------
data ListCriteria = ListInstalled
| ListSet
deriving Show
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
, lTag :: [Tag]
, lInstalled :: Bool
, lSet :: Bool
}
deriving Show
availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
av
2020-02-29 23:07:39 +00:00
listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m)
2020-02-28 23:33:32 +00:00
=> Maybe Tool
-> Maybe ListCriteria
2020-02-29 23:07:39 +00:00
-> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
[ListResult]
2020-02-28 23:33:32 +00:00
listVersions lt criteria = do
dls <- liftE $ getDownloads
liftIO $ listVersions' dls lt criteria
listVersions' :: AvailableDownloads
-> Maybe Tool
-> Maybe ListCriteria
-> IO [ListResult]
listVersions' av lt criteria = case lt of
Just t -> do
filter' <$> forM (availableToolVersions av t) (toListResult t)
Nothing -> do
ghcvers <- listVersions' av (Just GHC) criteria
cabalvers <- listVersions' av (Just Cabal) criteria
pure (ghcvers <> cabalvers)
where
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult t (v, tags) = case t of
GHC -> do
lSet <- fmap (maybe False (== v)) $ ghcSet
lInstalled <- ghcInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
Cabal -> do
lSet <- fmap (== v) $ cabalSet
lInstalled <- cabalInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
2020-02-29 23:07:39 +00:00
--------------
--[ GHC rm ]--
--------------
2020-02-28 23:33:32 +00:00
-- | This function may throw and crash in various ways.
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir
2020-02-29 23:07:39 +00:00
exists <- liftIO $ doesDirectoryExist dir
2020-02-28 23:33:32 +00:00
toolsFiles <- liftE $ ghcToolFiles ver
if exists
then do
2020-02-29 23:07:39 +00:00
-- this isn't atomic, order matters
2020-02-28 23:33:32 +00:00
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
liftIO $ rmMinorSymlinks
2020-03-01 01:21:40 +00:00
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
2020-02-28 23:33:32 +00:00
liftE fixMajorSymlinks
when isSetGHC $ liftE $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
2020-02-29 23:07:39 +00:00
rmPlain toolsFiles
2020-02-28 23:33:32 +00:00
liftIO
$ ghcupBaseDir
>>= hideError doesNotExistErrorType
. deleteFile
. (</> ([rel|share|] :: Path Rel))
else throwE (NotInstalled $ ToolRequest GHC ver)
where
-- e.g. ghc-8.6.5
rmMinorSymlinks :: IO ()
rmMinorSymlinks = do
bindir <- ghcupBinDir
files <- getDirsFiles' bindir
let myfiles = filter
(\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
files
forM_ myfiles $ \f -> deleteFile (bindir </> f)
-- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`.
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
2020-02-29 23:07:39 +00:00
=> [Path Rel] -- ^ tools files
2020-02-28 23:33:32 +00:00
-> Excepts '[NotInstalled] m ()
2020-02-29 23:07:39 +00:00
rmPlain files = do
2020-02-28 23:33:32 +00:00
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
-- e.g. ghc-8.6
fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
=> Excepts '[NotInstalled] m ()
fixMajorSymlinks = do
(mj, mi) <- getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
bindir <- liftIO $ ghcupBinDir
-- first delete them
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)
-- then fix them (e.g. with an earlier version)
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
2020-02-24 13:56:13 +00:00
2020-02-29 23:07:39 +00:00
------------------
--[ Debug info ]--
------------------
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
=> Excepts
'[PlatformResultError , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
diBaseDir <- liftIO $ ghcupBaseDir
diBinDir <- liftIO $ ghcupBinDir
diGHCDir <- liftIO $ ghcupGHCBaseDir
diCacheDir <- liftIO $ ghcupCacheDir
diURLSource <- lift $ getUrlSource
diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
pure $ DebugInfo { .. }
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
2020-03-01 00:05:02 +00:00
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
2020-02-22 18:21:10 +00:00
2020-02-24 13:56:13 +00:00
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
2020-02-28 23:33:32 +00:00
verdir <- parseRel (verToBS ver)
2020-02-24 13:56:13 +00:00
pure (ghcbasedir </> verdir)
2020-02-28 23:33:32 +00:00
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> Version
-> ByteString
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
-- | Extract the version part of the result of `ghcLinkDestination`.
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
where
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
verParser = many1' (notWord8 _slash) >>= \t ->
case version $ E.decodeUtf8 $ B.pack t of
Left e -> fail $ show e
Right r -> pure r
2020-02-24 13:56:13 +00:00
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
2020-02-22 18:21:10 +00:00
2020-02-28 23:33:32 +00:00
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
ghcSet = do
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
-- link destination is of the form ../ghc/<ver>/bin/ghc
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
2020-02-22 18:21:10 +00:00
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
2020-02-24 13:56:13 +00:00
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
2020-02-28 23:33:32 +00:00
pure (reportedVer == (verToBS ver))
2020-02-24 13:56:13 +00:00
2020-02-28 23:33:32 +00:00
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
case version (E.decodeUtf8 reportedVer) of
Left e -> throwM e
Right r -> pure r
2020-02-24 13:56:13 +00:00
-- | We assume GHC is in semver format. I hope it is.
2020-02-28 23:33:32 +00:00
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
2020-02-24 13:56:13 +00:00
getGHCMajor ver = do
2020-02-28 23:33:32 +00:00
SemVer {..} <- throwEither (semver $ prettyVer ver)
pure (fromIntegral _svMajor, fromIntegral _svMinor)
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadIO m, MonadThrow m)
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> m (Maybe Version)
2020-02-29 23:07:39 +00:00
getGHCForMajor major' minor' = do
2020-02-28 23:33:32 +00:00
p <- liftIO $ ghcupGHCBaseDir
ghcs <- liftIO $ getDirsFiles' p
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
mapM (throwEither . version)
. fmap prettySemVer
. lastMay
. sort
. filter
(\SemVer {..} ->
2020-02-29 23:07:39 +00:00
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
2020-02-28 23:33:32 +00:00
)
$ semvers
2020-02-24 13:56:13 +00:00
2020-02-22 18:21:10 +00:00
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
2020-02-18 08:40:01 +00:00
-- | Unpack an archive to a temporary directory and return that path.
2020-03-01 01:21:40 +00:00
unpackToTmpDir :: (MonadResource m -- temp file
, MonadLogger m, MonadIO m, MonadThrow m)
2020-02-22 18:21:10 +00:00
=> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs)
2020-02-18 08:40:01 +00:00
unpackToTmpDir av = do
2020-02-28 23:33:32 +00:00
let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|]
2020-03-01 01:21:40 +00:00
fn <- toFilePath <$> basename av
tmp <- toFilePath <$> lift withGHCupTmpDir
2020-02-18 08:40:01 +00:00
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
2020-02-22 18:21:10 +00:00
parseAbs tmp
2020-02-18 08:40:01 +00:00
-- extract, depending on file extension
if
2020-02-24 13:56:13 +00:00
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
2020-02-22 18:21:10 +00:00
(untar . GZip.decompress =<< readFile av)
2020-02-24 13:56:13 +00:00
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
2020-02-22 18:21:10 +00:00
filecontents <- liftIO $ readFile av
2020-02-18 08:40:01 +00:00
let decompressed = Lzma.decompress filecontents
2020-02-22 18:21:10 +00:00
liftIO $ untar decompressed
2020-02-24 13:56:13 +00:00
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
2020-02-22 18:21:10 +00:00
(untar . BZip.decompress =<< readFile av)
2020-02-24 13:56:13 +00:00
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn
2020-02-28 23:33:32 +00:00
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
(Just symver) <-
(B.stripPrefix [s|ghc-|] . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files