{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} -- TODO: handle SIGTERM, SIGUSR module GHCup where import GHCup.Bash import GHCup.File import GHCup.Prelude import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import Control.Applicative import Control.Exception.Safe import Control.Monad import Control.Monad.Fail ( MonadFail ) import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Class ( lift ) import Data.Aeson import Data.Attoparsec.ByteString import Data.ByteString ( ByteString ) import Data.ByteString.Builder import Data.Foldable import Data.IORef import Data.List import Data.Maybe import Data.String.Interpolate import Data.String.QQ import Data.Text ( Text ) import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath import HPath.IO import Haskus.Utils.Variant.Excepts import Network.Http.Client hiding ( URL ) import Optics import Prelude hiding ( abs , readFile ) import Safe import System.IO.Error import System.Info import System.Posix.Env.ByteString ( getEnvDefault , getEnv ) import System.Posix.FilePath ( takeFileName ) import System.Posix.Files.ByteString ( readSymbolicLink ) import "unix" System.Posix.IO.ByteString hiding ( fdWrite ) import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) import System.Posix.RawFilePath.Directory.Errors ( hideError ) import System.Posix.Temp.ByteString import System.Posix.Types import URI.ByteString import URI.ByteString.QQ import qualified Codec.Archive.Tar as Tar 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 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 data Settings = Settings { cache :: Bool , urlSource :: URLSource } deriving Show getUrlSource :: MonadReader Settings m => m URLSource getUrlSource = ask <&> urlSource getCache :: MonadReader Settings m => m Bool getCache = ask <&> cache --------------------------- --[ Excepts Error types ]-- --------------------------- data PlatformResultError = NoCompatiblePlatform String deriving Show data NoDownload = NoDownload deriving Show data NoCompatibleArch = NoCompatibleArch String deriving Show data DistroNotFound = DistroNotFound deriving Show data ArchiveError = UnknownArchive ByteString deriving Show data URLException = UnsupportedURL deriving Show data FileError = CopyError String deriving Show data TagNotFound = TagNotFound Tag Tool deriving Show data AlreadyInstalled = AlreadyInstalled ToolRequest deriving Show data NotInstalled = NotInstalled ToolRequest deriving Show data NotSet = NotSet Tool deriving Show data JSONError = JSONDecodeError String deriving Show data ParseError = ParseError String deriving Show data FileDoesNotExistError = FileDoesNotExistError ByteString deriving Show instance Exception ParseError -------------------------------- --[ AvailableDownloads stuff ]-- -------------------------------- ghcupURL :: URI ghcupURL = [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|] -- | 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 getDownloads :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo , MonadIO m , MonadCatch m , MonadReader Settings m ) => Excepts '[FileDoesNotExistError , URLException , JSONError] m AvailableDownloads getDownloads = lift getUrlSource >>= \case GHCupURL -> do bs <- liftE $ downloadBS ghcupURL lE' JSONDecodeError $ eitherDecode' bs (OwnSource url) -> do bs <- liftE $ downloadBS url lE' JSONDecodeError $ eitherDecode' bs (OwnSpec av) -> pure $ av ---------------------- --[ Download stuff ]-- ---------------------- getDownloadInfo :: ( MonadLogger m , MonadCatch m , MonadIO m , MonadReader Settings m ) => ToolRequest -> Maybe PlatformRequest -> Excepts '[ DistroNotFound , FileDoesNotExistError , JSONError , NoCompatibleArch , NoDownload , PlatformResultError , URLException ] m DownloadInfo getDownloadInfo (ToolRequest t v) mpfReq = do urlSource <- lift getUrlSource lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] -- lift $ monadLoggerLog undefined undefined undefined "" (PlatformRequest arch' plat ver) <- case mpfReq of Just x -> pure x Nothing -> do (PlatformResult rp rv) <- liftE getPlatform ar <- lE getArchitecture pure $ PlatformRequest ar rp rv dls <- liftE $ getDownloads lE $ getDownloadInfo' t v arch' plat ver dls 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 (Left NoDownload) Right (with_distro <|> without_distro_ver <|> without_distro) where with_distro = distro_preview id id without_distro_ver = distro_preview id (const Nothing) without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) distro_preview f g = preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls -- | Same as `download'`, except uses URL type. As such, this might -- throw an exception if the url type or host protocol is not supported. -- -- Only Absolute HTTP/HTTPS is supported. download :: (MonadLogger m, MonadIO m) => DownloadInfo -> Path Abs -- ^ destination dir -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[URLException] m (Path Abs) download dli dest mfn | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False | otherwise = throwE UnsupportedURL where dl https = do let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) lift $ $(logInfo) [i|downloading: #{uri'}|] host <- preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli ?? UnsupportedURL let path = view (dlUri % pathL') dli let port = preview (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL') dli liftIO $ download' https host path port dest mfn -- | 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 where scheme = view (uriSchemeL' % schemeBSL') uri' path = view pathL' uri' dl https = do host <- preview (authorityL' % _Just % authorityHostL' % hostBSL') uri' ?? UnsupportedURL let port = preview (authorityL' % _Just % authorityPortL' % _Just % portNumberL') uri' liftIO $ downloadBS' https host path port -- | 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 downloadInternal :: Bool -> ByteString -> ByteString -> Maybe Int -> (ByteString -> IO a) -- ^ the consuming step function -> IO () downloadInternal https host path port consumer = do c <- case https of True -> do ctx <- baselineContextSSL openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port) False -> openConnection host (fromIntegral $ fromMaybe 80 port) let q = buildRequest1 $ http GET path sendRequest c q emptyBody receiveResponse c (\_ i' -> do outStream <- Streams.makeOutputStream (\case Just bs -> void $ consumer bs Nothing -> pure () ) Streams.connect i' outStream ) closeConnection c -------------------------- --[ Platform detection ]-- -------------------------- getArchitecture :: Either NoCompatibleArch Architecture getArchitecture = case arch of "x86_64" -> Right A_64 "i386" -> Right A_32 what -> Left (NoCompatibleArch what) getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[PlatformResultError , DistroNotFound] m PlatformResult 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 } what -> throwE $ NoCompatiblePlatform what lift $ $(logDebug) [i|Identified Platform as: #{pfr}|] pure pfr where getFreeBSDVersion = pure Nothing getLinuxDistro :: (MonadCatch m, MonadIO m) => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning) getLinuxDistro = do -- TODO: don't do alternative on IO, because it hides bugs (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 . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|])) $ 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 (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) 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 (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|])) $ t verRe = join . fmap (ICU.group 0) . ICU.find (ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|]) $ 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) -- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads -- parseAvailableDownloads = undefined ------------------------- --[ Tool installation ]-- ------------------------- -- TODO: custom logger intepreter and pretty printing -- | Install a tool, such as GHC or cabal. This also sets -- the ghc-x.y.z symlinks and potentially the ghc-x.y. -- -- This can fail in many ways. You may want to explicitly catch -- `AlreadyInstalled` to not make it fatal. installTool :: ( MonadThrow m , MonadReader Settings m , MonadLogger m , MonadCatch m , MonadIO m , MonadFail m ) => ToolRequest -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Excepts '[ AlreadyInstalled , ArchiveError , DistroNotFound , FileDoesNotExistError , FileError , JSONError , NoCompatibleArch , NoDownload , NotInstalled , PlatformResultError , ProcessError , URLException ] m () installTool treq mpfReq = do lift $ $(logDebug) [i|Requested to install: #{treq}|] alreadyInstalled <- liftIO $ toolAlreadyInstalled treq when alreadyInstalled $ (throwE $ AlreadyInstalled treq) Settings {..} <- lift ask -- download (or use cached version) dlinfo <- liftE $ getDownloadInfo treq mpfReq dl <- case cache of True -> do cachedir <- liftIO $ ghcupCacheDir fn <- urlBaseName $ view (dlUri % pathL') dlinfo let cachfile = cachedir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> pure $ cachfile | otherwise -> liftE $ download dlinfo cachedir Nothing False -> do tmp <- liftIO mkGhcupTmpDir liftE $ download dlinfo tmp Nothing -- unpack unpacked <- liftE $ unpackToTmpDir dl -- prepare paths ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq) bindir <- liftIO ghcupBinDir -- the subdir of the archive where we do the work let archiveSubdir = maybe unpacked (unpacked ) (view dlSubdir dlinfo) case treq of (ToolRequest GHC ver) -> do liftE $ installGHC archiveSubdir ghcdir 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) (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir pure () toolAlreadyInstalled :: ToolRequest -> IO Bool toolAlreadyInstalled ToolRequest {..} = case _trTool of GHC -> ghcInstalled _trVersion Cabal -> cabalInstalled _trVersion -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else. installGHC :: (MonadLogger m, MonadIO m) => Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> Path Abs -- ^ Path to install to -> Excepts '[ProcessError] m () installGHC path inst = do lift $ $(logInfo) [s|Installing GHC|] 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) => Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides) -> Path Abs -- ^ Path to install to -> Excepts '[FileError] m () installCabal path inst = do lift $ $(logInfo) [s|Installing cabal|] let cabalFile = [rel|cabal|] :: Path Rel liftIO $ createDirIfMissing newDirPerms inst handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile) (inst cabalFile) Overwrite --------------- --[ Set GHC ]-- --------------- -- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends -- on `SetGHC`: -- -- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc//bin/ghc -- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc//bin/ghc -- * SetGHCMinor: ~/.ghcup/bin/ghc- -> ~/.ghcup/ghc//bin/ghc -- -- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc//share symlink -- for `SetGHCOnly` constructor. setGHC :: (MonadThrow m, MonadFail m, MonadIO m) => Version -> SetGHC -> Excepts '[NotInstalled] m () setGHC ver sghc = do let verBS = verToBS ver ghcdir <- liftIO $ ghcupGHCDir ver -- symlink destination destdir <- liftIO $ ghcupBinDir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir -- for ghc tools (ghc, ghci, haddock, ...) verfiles <- ghcToolFiles ver forM_ verfiles $ \file -> do liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir file) targetFile <- case sghc of SetGHCOnly -> pure file SetGHCMajor -> do major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi) <$> getGHCMajor ver parseRel (toFilePath file <> B.singleton _hyphen <> major') SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir targetFile) liftIO $ createSymlink (destdir targetFile) (ghcLinkDestination (toFilePath file) ver) -- create symlink for share dir liftIO $ symlinkShareDir ghcdir verBS pure () where 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) ([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir) _ -> 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 listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Maybe Tool -> Maybe ListCriteria -> Excepts '[FileDoesNotExistError , URLException , JSONError] m [ListResult] 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 -------------- --[ GHC rm ]-- -------------- -- | 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 exists <- liftIO $ doesDirectoryExist dir toolsFiles <- liftE $ ghcToolFiles ver if exists then do -- this isn't atomic, order matters lift $ $(logInfo) [i|Removing directory recursively: #{d'}|] liftIO $ deleteDirRecursive dir lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] liftIO $ rmMinorSymlinks lift $ $(logInfo) [i|Removing ghc-x.y symlinks|] liftE fixMajorSymlinks when isSetGHC $ liftE $ do lift $ $(logInfo) [i|Removing ghc symlinks|] rmPlain toolsFiles 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) => [Path Rel] -- ^ tools files -> Excepts '[NotInstalled] m () rmPlain files = do 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) ------------------ --[ 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 { .. } ----------------- --[ Utilities ]-- ----------------- ghcupBaseDir :: IO (Path Abs) ghcupBaseDir = do getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case Just r -> parseAbs r Nothing -> do home <- liftIO getHomeDirectory pure (home ([rel|.ghcup|] :: Path Rel)) ghcupGHCBaseDir :: IO (Path Abs) ghcupGHCBaseDir = ghcupBaseDir <&> ( ([rel|ghc|] :: Path Rel)) ghcupGHCDir :: Version -> IO (Path Abs) ghcupGHCDir ver = do ghcbasedir <- ghcupGHCBaseDir verdir <- parseRel (verToBS ver) pure (ghcbasedir verdir) -- | 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 ghcInstalled :: Version -> IO Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver doesDirectoryExist ghcdir ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) ghcSet = do ghcBin <- ( ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir -- link destination is of the form ../ghc//bin/ghc liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do link <- readSymbolicLink $ toFilePath ghcBin Just <$> ghcLinkVersion link ghcupBinDir :: IO (Path Abs) ghcupBinDir = ghcupBaseDir <&> ( ([rel|bin|] :: Path Rel)) ghcupCacheDir :: IO (Path Abs) ghcupCacheDir = ghcupBaseDir <&> ( ([rel|cache|] :: Path Rel)) 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 pure (reportedVer == (verToBS ver)) 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 -- | We assume GHC is in semver format. I hope it is. getGHCMajor :: MonadThrow m => Version -> m (Int, Int) getGHCMajor ver = do 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) getGHCForMajor major' minor' = do p <- liftIO $ ghcupGHCBaseDir ghcs <- liftIO $ getDirsFiles' p semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath mapM (throwEither . version) . fmap prettySemVer . lastMay . sort . filter (\SemVer {..} -> fromIntegral _svMajor == major' && fromIntegral _svMinor == minor' ) $ semvers urlBaseName :: MonadThrow m => ByteString -- ^ the url path (without scheme and host) -> m (Path Rel) urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False -- | Unpack an archive to a temporary directory and return that path. unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m) => Path Abs -- ^ archive path -> Excepts '[ArchiveError] m (Path Abs) unpackToTmpDir av = do let fp = E.decodeUtf8 (toFilePath av) lift $ $(logInfo) [i|Unpacking: #{fp}|] fn <- toFilePath <$> basename av tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) let untar bs = do Tar.unpack tmp . Tar.read $ bs parseAbs tmp -- extract, depending on file extension if | [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO (untar . GZip.decompress =<< readFile av) | [s|.tar.xz|] `B.isSuffixOf` fn -> do filecontents <- liftIO $ readFile av let decompressed = Lzma.decompress filecontents liftIO $ untar decompressed | [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO (untar . BZip.decompress =<< readFile av) | [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av) | otherwise -> throwE $ UnknownArchive fn -- get tool files from ~/.ghcup/bin/ghc//bin/* -- while ignoring *- 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 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