{-# 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 qualified Codec.Archive.Tar as Tar import Control.Applicative import Control.Monad import Control.Monad.Fail ( MonadFail ) import Control.Monad.Reader import Control.Monad.Logger import Control.Monad.Trans.Class ( lift ) import Control.Exception.Safe import Data.Aeson import Data.Attoparsec.ByteString import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder import Data.Foldable import Data.String.QQ import Data.Text ( Text ) import Data.Versions import Data.IORef import GHCup.Bash import GHCup.File import GHCup.Prelude import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import HPath import HPath.IO import Optics import Prelude hiding ( abs , readFile ) import Data.List import System.Info import System.IO.Error import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.ICU as ICU import Data.Maybe import qualified Data.Map.Strict as Map import Data.Word8 import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Network.Http.Client hiding ( URL ) import qualified System.IO.Streams as Streams import System.Posix.FilePath ( takeFileName ) import qualified System.Posix.FilePath as FP import System.Posix.Files.ByteString ( readSymbolicLink ) import System.Posix.Env.ByteString ( getEnvDefault ) import System.Posix.Temp.ByteString import qualified System.Posix.RawFilePath.Directory as RD import System.Posix.RawFilePath.Directory.Errors ( hideError ) import "unix" System.Posix.IO.ByteString hiding ( fdWrite ) import qualified Data.ByteString as B import System.Posix.Types import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.BZip as BZip import URI.ByteString import URI.ByteString.QQ import Data.String.Interpolate import Safe 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 $ createDirIfMissing 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 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