{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-| Module : GHCup Description : GHCup installation functions Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : POSIX This module contains the main functions that correspond to the command line interface, like installation, listing versions and so on. These are the entry points. -} module GHCup where import GHCup.Download import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import GHCup.Utils.Version.QQ import GHCup.Version #if !defined(TAR) import Codec.Archive ( ArchiveResult ) #endif import Control.Applicative import Control.Exception.Safe import Control.Monad #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) import Data.ByteString ( ByteString ) import Data.Either import Data.List import Data.Maybe import Data.String.Interpolate import Data.Text ( Text ) import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath import HPath.IO hiding ( hideError ) import Haskus.Utils.Variant.Excepts import Optics import Prelude hiding ( abs , readFile , writeFile ) import Safe hiding ( at ) import System.IO.Error import System.Posix.Env.ByteString ( getEnvironment ) import System.Posix.FilePath ( getSearchPath ) import System.Posix.Files.ByteString import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as E ------------------------- --[ Tool installation ]-- ------------------------- -- | Like 'installGHCBin', except takes the 'DownloadInfo' as -- argument instead of looking it up from 'GHCupDownloads'. installGHCBindist :: ( MonadFail m , MonadMask m , MonadCatch m , MonadReader Settings m , MonadLogger m , MonadResource m , MonadIO m ) => DownloadInfo -- ^ where/how to download -> Version -- ^ the version to install -> PlatformRequest -- ^ the platform to install on -> Excepts '[ AlreadyInstalled , BuildFailed , DigestError , DownloadFailed , NoDownload , NotInstalled , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () installGHCBindist dlinfo ver (PlatformRequest {..}) = do let tver = (mkTVer ver) lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] whenM (lift $ ghcInstalled tver) $ (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing -- unpack tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack -- prepare paths ghcdir <- lift $ ghcupGHCDir tver -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir) liftE $ postGHCInstall tver where -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else. installGHC' :: (MonadReader Settings m, MonadThrow m, 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) "Installing GHC (this may take a while)" lEM $ execLogged "./configure" False (["--prefix=" <> toFilePath inst] ++ alpineArgs) [rel|ghc-configure|] (Just path) Nothing lEM $ make ["install"] (Just path) pure () alpineArgs | ver >= [vver|8.2.2|] , Linux Alpine <- _rPlatform = ["--disable-ld-override"] | otherwise = [] -- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the -- following symlinks in @~\/.ghcup\/bin@: -- -- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ -- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) installGHCBin :: ( MonadFail m , MonadMask m , MonadCatch m , MonadReader Settings m , MonadLogger m , MonadResource m , MonadIO m ) => GHCupDownloads -- ^ the download info to look up the tarball from -> Version -- ^ the version to install -> PlatformRequest -- ^ the platform to install on -> Excepts '[ AlreadyInstalled , BuildFailed , DigestError , DownloadFailed , NoDownload , NotInstalled , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () installGHCBin bDls ver pfreq = do dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls installGHCBindist dlinfo ver pfreq -- | Like 'installCabalBin', except takes the 'DownloadInfo' as -- argument instead of looking it up from 'GHCupDownloads'. installCabalBindist :: ( MonadMask m , MonadCatch m , MonadReader Settings m , MonadLogger m , MonadResource m , MonadIO m , MonadFail m ) => DownloadInfo -> Version -> PlatformRequest -> Excepts '[ AlreadyInstalled , CopyError , DigestError , DownloadFailed , NoDownload , NotInstalled , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () installCabalBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] Settings {dirs = Dirs {..}} <- lift ask whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && isSymbolicLink x) -- ignore when the installation is a legacy cabal (binary, not symlink) $ getSymbolicLinkStatus (toFilePath (binDir [rel|cabal|])) ) $ (throwE $ AlreadyInstalled Cabal ver) -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing -- unpack tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) liftE $ installCabal' workdir binDir -- create symlink if this is the latest version cVers <- lift $ fmap rights $ getInstalledCabals let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver pure () where -- | 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 '[CopyError] m () installCabal' path inst = do lift $ $(logInfo) "Installing cabal" let cabalFile = [rel|cabal|] liftIO $ createDirRecursive' inst destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver) let destPath = inst destFileName handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile) (destPath) Overwrite lift $ chmod_777 destPath -- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and -- creates a default @cabal -> cabal-x.y.z.q@ symlink for -- the latest installed version. installCabalBin :: ( MonadMask m , MonadCatch m , MonadReader Settings m , MonadLogger m , MonadResource m , MonadIO m , MonadFail m ) => GHCupDownloads -> Version -> PlatformRequest -> Excepts '[ AlreadyInstalled , CopyError , DigestError , DownloadFailed , NoDownload , NotInstalled , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () installCabalBin bDls ver pfreq = do dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls installCabalBindist dlinfo ver pfreq --------------------- --[ Set GHC/cabal ]-- --------------------- -- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends -- on `SetGHC`: -- -- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ -- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ -- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. setGHC :: ( MonadReader Settings m , MonadLogger m , MonadThrow m , MonadFail m , MonadIO m , MonadCatch m ) => GHCTargetVersion -> SetGHC -> Excepts '[NotInstalled] m GHCTargetVersion setGHC ver sghc = do let verBS = verToBS (_tvVersion ver) ghcdir <- lift $ ghcupGHCDir ver whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) -- symlink destination Settings { dirs = Dirs {..} } <- lift ask liftIO $ createDirRecursive' binDir -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) case sghc of SetGHCOnly -> liftE $ rmPlain (_tvTarget ver) SetGHC_XY -> lift $ rmMajorSymlinks ver SetGHC_XYZ -> lift $ rmMinorSymlinks ver -- for ghc tools (ghc, ghci, haddock, ...) verfiles <- ghcToolFiles ver forM_ verfiles $ \file -> do mTargetFile <- case sghc of SetGHCOnly -> pure $ Just file SetGHC_XY -> do v' <- handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing) $ fmap Just $ getMajorMinorV (_tvVersion ver) forM v' $ \(mj, mi) -> let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi in parseRel (toFilePath file <> B.singleton _hyphen <> major') SetGHC_XYZ -> fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS) -- create symlink forM mTargetFile $ \targetFile -> do let fullF = binDir targetFile destL <- lift $ ghcLinkDestination (toFilePath file) ver lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|] liftIO $ createSymlink fullF destL -- create symlink for share dir when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS pure ver where symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) => Path Abs -> ByteString -> m () symlinkShareDir ghcdir verBS = do Settings { dirs = Dirs {..} } <- ask let destdir = baseDir case sghc of SetGHCOnly -> do let sharedir = [rel|share|] let fullsharedir = ghcdir sharedir whenM (liftIO $ doesDirectoryExist fullsharedir) $ do let fullF = destdir sharedir let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir $(logDebug) [i|rm -f #{fullF}|] liftIO $ hideError doesNotExistErrorType $ deleteFile fullF $(logDebug) [i|ln -s #{targetF} #{fullF}|] liftIO $ createSymlink fullF targetF _ -> pure () -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Version -> Excepts '[NotInstalled] m () setCabal ver = do let verBS = verToBS ver targetFile <- parseRel ("cabal-" <> verBS) -- symlink destination Settings {dirs = Dirs {..}} <- lift ask liftIO $ createDirRecursive' binDir whenM (liftIO $ fmap not $ doesFileExist (binDir targetFile)) $ throwE $ NotInstalled Cabal (prettyVer ver) let cabalbin = binDir [rel|cabal|] -- delete old file (may be binary or symlink) lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|] liftIO $ hideError doesNotExistErrorType $ deleteFile cabalbin -- create symlink let destL = toFilePath targetFile lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|] liftIO $ createSymlink cabalbin destL pure () ------------------ --[ List tools ]-- ------------------ -- | Filter data type for 'listVersions'. data ListCriteria = ListInstalled | ListSet deriving Show -- | A list result describes a single tool version -- and various of its properties. data ListResult = ListResult { lTool :: Tool , lVer :: Version , lCross :: Maybe Text -- ^ currently only for GHC , lTag :: [Tag] , lInstalled :: Bool , lSet :: Bool -- ^ currently active version , fromSrc :: Bool -- ^ compiled from source , lStray :: Bool -- ^ not in download info , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch } deriving (Eq, Ord, Show) -- | Extract all available tool versions and their tags. availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag] availableToolVersions av tool = view (at tool % non Map.empty % to (fmap (_viTags))) av -- | List all versions from the download info, as well as stray -- versions. listVersions :: ( MonadCatch m , MonadLogger m , MonadThrow m , MonadLogger m , MonadIO m , MonadReader Settings m ) => GHCupDownloads -> Maybe Tool -> Maybe ListCriteria -> PlatformRequest -> m [ListResult] listVersions av lt criteria pfreq = do case lt of Just t -> do -- get versions from GHCupDownloads let avTools = availableToolVersions av t lr <- filter' <$> forM (Map.toList avTools) (toListResult t) case t of -- append stray GHCs GHC -> do slr <- strayGHCs avTools pure $ (sort (slr ++ lr)) Cabal -> do slr <- strayCabals avTools pure $ (sort (slr ++ lr)) _ -> pure lr Nothing -> do ghcvers <- listVersions av (Just GHC) criteria pfreq cabalvers <- listVersions av (Just Cabal) criteria pfreq ghcupvers <- listVersions av (Just GHCup) criteria pfreq pure (ghcvers <> cabalvers <> ghcupvers) where strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do ghcs <- getInstalledGHCs fmap catMaybes $ forM ghcs $ \case Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do case Map.lookup _tvVersion avTools of Just _ -> pure Nothing Nothing -> do lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing fromSrc <- ghcSrcInstalled tver pure $ Just $ ListResult { lTool = GHC , lVer = _tvVersion , lCross = Nothing , lTag = [] , lInstalled = True , lStray = maybe True (const False) (Map.lookup _tvVersion avTools) , lNoBindist = False , .. } Right tver@GHCTargetVersion{ .. } -> do lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget fromSrc <- ghcSrcInstalled tver pure $ Just $ ListResult { lTool = GHC , lVer = _tvVersion , lCross = _tvTarget , lTag = [] , lInstalled = True , lStray = True -- NOTE: cross currently cannot be installed via bindist , lNoBindist = False , .. } Left e -> do $(logWarn) [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayCabals avTools = do cabals <- getInstalledCabals fmap catMaybes $ forM cabals $ \case Right ver -> case Map.lookup ver avTools of Just _ -> pure Nothing Nothing -> do lSet <- fmap (maybe False (== ver)) $ cabalSet pure $ Just $ ListResult { lTool = Cabal , lVer = ver , lCross = Nothing , lTag = [] , lInstalled = True , lStray = maybe True (const False) (Map.lookup ver avTools) , lNoBindist = False , fromSrc = False -- actually, we don't know :> , .. } Left e -> do $(logWarn) [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing -- NOTE: this are not cross ones, because no bindists toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult toListResult t (v, tags) = case t of GHC -> do let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let tver = mkTVer v lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lInstalled <- ghcInstalled tver fromSrc <- ghcSrcInstalled tver pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } Cabal -> do let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av lSet <- fmap (maybe False (== v)) $ cabalSet lInstalled <- cabalInstalled v pure ListResult { lVer = v , lCross = Nothing , lTag = tags , lTool = t , fromSrc = False , lStray = False , .. } GHCup -> do let lSet = prettyPVP ghcUpVer == prettyVer v let lInstalled = lSet pure ListResult { lVer = v , lTag = tags , lCross = Nothing , lTool = t , fromSrc = False , lStray = False , lNoBindist = False , .. } filter' :: [ListResult] -> [ListResult] filter' lr = case criteria of Nothing -> lr Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr Just ListSet -> filter (\ListResult {..} -> lSet) lr -------------------- --[ GHC/cabal rm ]-- -------------------- -- | Delete a ghc version and all its symlinks. -- -- This may leave GHCup without a "set" version. -- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- older version). rmGHCVer :: ( MonadReader Settings m , MonadThrow m , MonadLogger m , MonadIO m , MonadFail m , MonadCatch m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmGHCVer ver = do isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) dir <- lift $ ghcupGHCDir ver -- this isn't atomic, order matters when isSetGHC $ do lift $ $(logInfo) [i|Removing ghc symlinks|] liftE $ rmPlain (_tvTarget ver) lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|] liftIO $ deleteDirRecursive dir lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] lift $ rmMinorSymlinks ver lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|] -- first remove handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver -- then fix them (e.g. with an earlier version) v' <- handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing) $ fmap Just $ getMajorMinorV (_tvVersion ver) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) Settings { dirs = Dirs {..} } <- lift ask liftIO $ hideError doesNotExistErrorType $ deleteFile $ (baseDir [rel|share|]) -- | Delete a cabal version. Will try to fix the @cabal@ symlink -- after removal (e.g. setting it to an older version). rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmCabalVer ver = do whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver)) cSet <- lift $ cabalSet Settings {dirs = Dirs {..}} <- lift ask cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir cabalFile) when (maybe False (== ver) cSet) $ do cVers <- lift $ fmap rights $ getInstalledCabals case headMay . reverse . sort $ cVers of Just latestver -> setCabal latestver Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir [rel|cabal|]) ------------------ --[ Debug info ]-- ------------------ getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do Settings {dirs = Dirs {..}} <- lift ask let diBaseDir = baseDir let diBinDir = binDir diGHCDir <- lift ghcupGHCBaseDir let diCacheDir = cacheDir diArch <- lE getArchitecture diPlatform <- liftE $ getPlatform pure $ DebugInfo { .. } --------------- --[ Compile ]-- --------------- -- | Compile a GHC from source. This behaves wrt symlinks and installation -- the same as 'installGHCBin'. compileGHC :: ( MonadMask m , MonadReader Settings m , MonadThrow m , MonadResource m , MonadLogger m , MonadIO m , MonadFail m ) => GHCupDownloads -> GHCTargetVersion -- ^ version to install -> Either Version (Path Abs) -- ^ version to bootstrap with -> Maybe Int -- ^ jobs -> Maybe (Path Abs) -- ^ build config -> Maybe (Path Abs) -- ^ patch directory -> [Text] -- ^ additional args to ./configure -> PlatformRequest -> Excepts '[ AlreadyInstalled , BuildFailed , DigestError , DownloadFailed , GHCupSetError , NoDownload , NotFoundInPATH , PatchFailed , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) -- download source tarball dlInfo <- preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing -- unpack tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack bghc <- case bstrap of Right g -> pure $ Right g Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo) ghcdir <- lift $ ghcupGHCDir tver liftE $ runBuildAction tmpUnpack (Just ghcdir) (compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir) reThrowAll GHCupSetError $ postGHCInstall tver pure () where defaultConf = case _tvTarget tver of Nothing -> [s| V=0 BUILD_MAN = NO BUILD_SPHINX_HTML = NO BUILD_SPHINX_PDF = NO HADDOCK_DOCS = YES|] Just _ -> [s| V=0 BUILD_MAN = NO BUILD_SPHINX_HTML = NO BUILD_SPHINX_PDF = NO HADDOCK_DOCS = NO Stage1Only = YES|] compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m) => Either (Path Rel) (Path Abs) -> Path Abs -> Path Abs -> Excepts '[ FileDoesNotExistError , InvalidBuildConfig , PatchFailed , ProcessError , NotFoundInPATH ] m () compile bghc ghcdir workdir = do lift $ $(logInfo) [i|configuring build|] liftE $ checkBuildConfig forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir cEnv <- liftIO $ getEnvironment if | (_tvVersion tver) >= [vver|8.8.0|] -> do bghcPath <- case bghc of Right ghc' -> pure ghc' Left bver -> do spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath (liftIO $ searchPath spaths bver) !? NotFoundInPATH bver lEM $ execLogged "./configure" False ( ["--prefix=" <> toFilePath ghcdir] ++ (maybe mempty (\x -> ["--target=" <> E.encodeUtf8 x]) (_tvTarget tver) ) ++ fmap E.encodeUtf8 aargs ) [rel|ghc-conf|] (Just workdir) (Just (("GHC", toFilePath bghcPath) : cEnv)) | otherwise -> do lEM $ execLogged "./configure" False ( [ "--prefix=" <> toFilePath ghcdir , "--with-ghc=" <> either toFilePath toFilePath bghc ] ++ (maybe mempty (\x -> ["--target=" <> E.encodeUtf8 x]) (_tvTarget tver) ) ++ fmap E.encodeUtf8 aargs ) [rel|ghc-conf|] (Just workdir) (Just cEnv) case mbuildConfig of Just bc -> liftIOException doesNotExistErrorType (FileDoesNotExistError $ toFilePath bc) (liftIO $ copyFile bc (build_mk workdir) Overwrite) Nothing -> liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf lift $ $(logInfo) [i|Building (this may take a while)...|] lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) lift $ $(logInfo) [i|Installing...|] lEM $ make ["install"] (Just workdir) markSrcBuilt ghcdir workdir = do let dest = (ghcdir ghcUpSrcBuiltFile) liftIO $ copyFile (build_mk workdir) dest Overwrite build_mk workdir = workdir [rel|mk/build.mk|] checkBuildConfig :: (MonadCatch m, MonadIO m) => Excepts '[FileDoesNotExistError , InvalidBuildConfig] m () checkBuildConfig = do c <- case mbuildConfig of Just bc -> do BL.toStrict <$> liftIOException doesNotExistErrorType (FileDoesNotExistError $ toFilePath bc) (liftIO $ readFile bc) Nothing -> pure defaultConf let lines' = fmap T.strip . T.lines $ decUTF8Safe c -- for cross, we need Stage1Only case _tvTarget tver of Just _ -> when (not $ elem "Stage1Only = YES" lines') $ throwE (InvalidBuildConfig [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] ) Nothing -> pure () -- | Compile a cabal from source. This behaves wrt symlinks and installation -- the same as 'installCabalBin'. compileCabal :: ( MonadReader Settings m , MonadResource m , MonadMask m , MonadLogger m , MonadIO m , MonadFail m ) => GHCupDownloads -> Version -- ^ version to install -> Either Version (Path Abs) -- ^ version to bootstrap with -> Maybe Int -> Maybe (Path Abs) -> PlatformRequest -> Excepts '[ AlreadyInstalled , BuildFailed , CopyError , DigestError , DownloadFailed , NoDownload , NotInstalled , PatchFailed , UnknownArchive , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif ] m () compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] Settings {dirs = Dirs {..}} <- lift ask whenM (lift (cabalInstalled tver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && isSymbolicLink x) -- ignore when the installation is a legacy cabal (binary, not symlink) $ getSymbolicLinkStatus (toFilePath (binDir [rel|cabal|])) ) $ (throwE $ AlreadyInstalled Cabal tver) -- download source tarball dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing -- unpack tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo) cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir) destFileName <- lift $ parseRel ("cabal-" <> verToBS tver) handleIO (throwE . CopyError . show) $ liftIO $ copyFile cbin (binDir destFileName) Overwrite -- create symlink if this is the latest version cVers <- lift $ fmap rights $ getInstalledCabals let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver pure () where compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m) => Path Abs -> Excepts '[ProcessError , PatchFailed] m (Path Abs) compile workdir = do lift $ $(logInfo) [i|Building (this may take a while)...|] forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir ghcEnv <- case bghc of Right path -> do -- recover the version from /foo/ghc-6.5.4 bn <- basename path let dn = toFilePath $ dirname path let ver = snd . B.break (== _hyphen) . toFilePath $ bn pure [ ("GHC" , toFilePath path) , ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver) , ("HADDOCK", dn <> "/" <> "haddock" <> ver) ] Left bver -> do let v' = verToBS bver pure [ ("GHC" , "ghc-" <> v') , ("GHC_PKG", "ghc-pkg-" <> v') , ("HADDOCK", "haddock-" <> v') ] tmp <- lift withGHCupTmpDir liftIO $ createDirRecursive' (tmp [rel|bin|]) newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv) lift $ $(logDebug) [i|Environment: #{newEnv}|] lEM $ execLogged "./bootstrap.sh" False (maybe [] (\j -> ["-j", fS (show j)]) jobs) [rel|cabal-bootstrap|] (Just workdir) (Just newEnv) pure $ (tmp [rel|bin/cabal|]) --------------------- --[ Upgrade GHCup ]-- --------------------- -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- if no path is provided. upgradeGHCup :: ( MonadMask m , MonadReader Settings m , MonadCatch m , MonadLogger m , MonadThrow m , MonadResource m , MonadIO m ) => GHCupDownloads -> Maybe (Path Abs) -- ^ full file destination to write ghcup into -> Bool -- ^ whether to force update regardless -- of currently installed version -> PlatformRequest -> Excepts '[ CopyError , DigestError , DownloadFailed , NoDownload , NoUpdate ] m Version upgradeGHCup dls mtarget force pfreq = do Settings {dirs = Dirs {..}} <- lift ask lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls tmp <- lift withGHCupTmpDir let fn = [rel|ghcup|] p <- liftE $ download dli tmp (Just fn) let fullDest = fromMaybe (binDir fn) mtarget liftIO $ hideError NoSuchThing $ deleteFile fullDest handleIO (throwE . CopyError . show) $ liftIO $ copyFile p fullDest Overwrite lift $ chmod_777 fullDest pure latestVer ------------- --[ Other ]-- ------------- -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. postGHCInstall :: ( MonadReader Settings m , MonadLogger m , MonadThrow m , MonadFail m , MonadIO m , MonadCatch m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () postGHCInstall ver@GHCTargetVersion {..} = do void $ liftE $ setGHC ver SetGHC_XYZ -- Create ghc-x.y symlinks. This may not be the current -- version, create it regardless. v' <- handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing) $ fmap Just $ getMajorMinorV _tvVersion forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)