ghcup-hs/lib/GHCup.hs

960 lines
32 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE TypeFamilies #-}
2020-04-21 21:37:48 +00:00
{-# LANGUAGE ViewPatterns #-}
2020-01-11 20:15:05 +00:00
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
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.Either
2020-01-11 20:15:05 +00:00
import Data.List
import Data.Maybe
import Data.String.Interpolate
2020-04-25 10:06:41 +00:00
import Data.Text ( Text )
2020-01-11 20:15:05 +00:00
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe hiding ( at )
2020-01-11 20:15:05 +00:00
import System.IO.Error
2020-04-25 10:06:41 +00:00
import System.Posix.Env.ByteString ( getEnvironment )
2020-01-11 20:15:05 +00:00
import System.Posix.FilePath ( getSearchPath )
2020-04-12 18:22:16 +00:00
import System.Posix.Files.ByteString
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
2020-04-25 10:06:41 +00:00
import qualified Data.ByteString.Lazy as BL
2020-01-11 20:15:05 +00:00
import qualified Data.Map.Strict as Map
2020-04-25 10:06:41 +00:00
import qualified Data.Text as T
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
-------------------------
--[ Tool installation ]--
-------------------------
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installGHCBin bDls ver mpfReq = do
2020-04-25 10:06:41 +00:00
let tver = (mkTVer ver)
2020-01-11 20:15:05 +00:00
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
2020-04-25 10:06:41 +00:00
whenM (liftIO $ ghcInstalled tver)
2020-01-11 20:15:05 +00:00
$ (throwE $ AlreadyInstalled GHC ver)
2020-04-22 16:12:40 +00:00
Settings {..} <- lift ask
2020-04-10 17:27:17 +00:00
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
2020-01-11 20:15:05 +00:00
-- download (or use cached version)
2020-04-22 16:12:40 +00:00
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing
2020-01-11 20:15:05 +00:00
-- unpack
2020-04-22 16:12:40 +00:00
tmpUnpack <- lift mkGhcupTmpDir
2020-01-11 20:15:05 +00:00
liftE $ unpackToDir tmpUnpack dl
2020-04-10 17:27:17 +00:00
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
-- prepare paths
2020-04-25 10:06:41 +00:00
ghcdir <- liftIO $ ghcupGHCDir tver
2020-01-11 20:15:05 +00:00
-- the subdir of the archive where we do the work
2020-03-17 17:40:25 +00:00
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
2020-04-22 16:12:40 +00:00
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
liftE $ postGHCInstall tver
2020-01-11 20:15:05 +00:00
where
2020-04-26 09:55:20 +00:00
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
2020-01-11 20:15:05 +00:00
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
2020-03-21 21:19:37 +00:00
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ liftIO $ execLogged "./configure"
2020-01-11 20:15:05 +00:00
False
2020-03-21 21:19:37 +00:00
["--prefix=" <> toFilePath inst]
2020-03-24 15:49:18 +00:00
[rel|ghc-configure|]
2020-01-11 20:15:05 +00:00
(Just path)
Nothing
2020-03-21 21:19:37 +00:00
lEM $ liftIO $ make ["install"] (Just path)
2020-01-11 20:15:05 +00:00
pure ()
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
2020-01-11 20:15:05 +00:00
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, CopyError
2020-01-11 20:15:05 +00:00
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
2020-01-11 20:15:05 +00:00
, UnknownArchive
]
m
()
installCabalBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled ver >>= \a ->
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)
2020-04-25 10:06:41 +00:00
Settings {..} <- lift ask
2020-04-10 17:27:17 +00:00
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
2020-01-11 20:15:05 +00:00
-- download (or use cached version)
2020-04-25 10:06:41 +00:00
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing
2020-01-11 20:15:05 +00:00
-- unpack
2020-04-25 10:06:41 +00:00
tmpUnpack <- lift withGHCupTmpDir
2020-01-11 20:15:05 +00:00
liftE $ unpackToDir tmpUnpack dl
2020-04-10 17:27:17 +00:00
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
-- the subdir of the archive where we do the work
2020-03-17 17:40:25 +00:00
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
2020-01-11 20:15:05 +00:00
2020-03-17 17:40:25 +00:00
liftE $ installCabal' workdir bindir
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
2020-01-11 20:15:05 +00:00
pure ()
where
2020-04-26 09:55:20 +00:00
-- | Install an unpacked cabal distribution.
2020-01-11 20:15:05 +00:00
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
2020-03-21 21:19:37 +00:00
lift $ $(logInfo) "Installing cabal"
2020-03-16 09:47:09 +00:00
let cabalFile = [rel|cabal|]
2020-01-11 20:15:05 +00:00
liftIO $ createDirIfMissing newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
2020-01-11 20:15:05 +00:00
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> destFileName)
2020-01-11 20:15:05 +00:00
Overwrite
---------------------
--[ Set GHC/cabal ]--
---------------------
2020-01-11 20:15:05 +00:00
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> SetGHC
2020-04-25 10:06:41 +00:00
-> Excepts '[NotInstalled] m GHCTargetVersion
2020-01-11 20:15:05 +00:00
setGHC ver sghc = do
2020-04-25 10:06:41 +00:00
let verBS = verToBS (_tvVersion ver)
2020-01-11 20:15:05 +00:00
ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
2020-04-25 10:06:41 +00:00
SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
2020-01-11 20:15:05 +00:00
SetGHC_XY -> lift $ rmMajorSymlinks ver
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHC_XY -> do
2020-04-25 10:06:41 +00:00
major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi)
<$> getMajorMinorV (_tvVersion ver)
2020-01-11 20:15:05 +00:00
parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-- create symlink
let fullF = bindir </> targetFile
let destL = ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir
2020-04-25 10:06:41 +00:00
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
2020-01-11 20:15:05 +00:00
pure ver
2020-01-11 20:15:05 +00:00
where
symlinkShareDir :: (MonadIO m, MonadLogger m)
=> Path Abs
-> ByteString
-> m ()
symlinkShareDir ghcdir verBS = do
destdir <- liftIO $ ghcupBaseDir
case sghc of
SetGHCOnly -> do
2020-03-16 09:47:09 +00:00
let sharedir = [rel|share|]
2020-01-11 20:15:05 +00:00
let fullsharedir = ghcdir </> sharedir
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
2020-03-21 21:19:37 +00:00
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
2020-01-11 20:15:05 +00:00
$(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 :: (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
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms 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 ()
2020-01-11 20:15:05 +00:00
------------------
--[ List tools ]--
------------------
data ListCriteria = ListInstalled
| ListSet
deriving Show
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
2020-04-25 10:06:41 +00:00
, lCross :: Maybe Text -- ^ currently only for GHC
2020-01-11 20:15:05 +00:00
, lTag :: [Tag]
, lInstalled :: Bool
2020-04-21 21:37:48 +00:00
, 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
2020-01-11 20:15:05 +00:00
}
2020-04-21 21:37:48 +00:00
deriving (Eq, Ord, Show)
2020-01-11 20:15:05 +00:00
2020-04-21 21:37:48 +00:00
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
availableToolVersions av tool = view
(at tool % non Map.empty % to (fmap (_viTags)))
2020-01-11 20:15:05 +00:00
av
2020-04-21 21:37:48 +00:00
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
2020-04-21 21:37:48 +00:00
=> GHCupDownloads
2020-01-11 20:15:05 +00:00
-> Maybe Tool
-> Maybe ListCriteria
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
[ListResult]
listVersions av lt criteria = do
pfreq <- platformRequest
case lt of
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t)
case t of
-- append stray GHCs
GHC -> do
slr <- lift $ strayGHCs avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria
ghcupvers <- listVersions av (Just GHCup) criteria
pure (ghcvers <> cabalvers <> ghcupvers)
2020-01-11 20:15:05 +00:00
where
2020-04-25 10:06:41 +00:00
strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m)
2020-04-21 21:37:48 +00:00
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
2020-04-25 10:06:41 +00:00
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 <- liftIO $ 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
2020-04-25 10:06:41 +00:00
, ..
}
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- liftIO $ 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
2020-04-25 10:06:41 +00:00
, ..
}
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 :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult
toListResult pfreq t (v, tags) = case t of
2020-01-11 20:15:05 +00:00
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
2020-04-25 10:06:41 +00:00
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, .. }
2020-01-11 20:15:05 +00:00
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
lSet <- fmap (maybe False (== v)) $ cabalSet
lInstalled <- cabalInstalled v
2020-04-21 21:37:48 +00:00
pure ListResult { lVer = v
2020-04-25 10:06:41 +00:00
, lCross = Nothing
2020-04-21 21:37:48 +00:00
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, ..
}
2020-01-11 20:15:05 +00:00
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
2020-03-16 09:49:34 +00:00
let lInstalled = lSet
2020-04-21 21:37:48 +00:00
pure ListResult { lVer = v
, lTag = tags
2020-04-25 10:06:41 +00:00
, lCross = Nothing
2020-04-21 21:37:48 +00:00
, lTool = t
, fromSrc = False
, lStray = False
, lNoBindist = False
2020-04-21 21:37:48 +00:00
, ..
}
2020-01-11 20:15:05 +00:00
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 ]--
--------------------
2020-01-11 20:15:05 +00:00
-- | This function may throw and crash in various ways.
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
2020-04-25 10:06:41 +00:00
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
2020-01-11 20:15:05 +00:00
dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir
if exists
then do
-- this isn't atomic, order matters
2020-04-15 10:51:37 +00:00
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
2020-04-25 10:06:41 +00:00
liftE $ rmPlain (_tvTarget ver)
2020-04-15 10:51:37 +00:00
2020-01-11 20:15:05 +00:00
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
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
lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
2020-04-25 10:06:41 +00:00
(mj, mi) <- getMajorMinorV (_tvVersion ver)
getGHCForMajor mj mi (_tvTarget ver) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
2020-01-11 20:15:05 +00:00
liftIO
$ ghcupBaseDir
>>= hideError doesNotExistErrorType
. deleteFile
2020-03-16 09:47:09 +00:00
. (</> [rel|share|])
2020-04-25 10:06:41 +00:00
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
2020-01-11 20:15:05 +00:00
-- | This function may throw and crash in various ways.
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled GHC (prettyVer ver))
cSet <- liftIO cabalSet
bindir <- liftIO ghcupBinDir
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile)
when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> [rel|cabal|])
2020-01-11 20:15:05 +00:00
------------------
--[ Debug info ]--
------------------
2020-03-17 17:39:01 +00:00
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
2020-01-11 20:15:05 +00:00
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
2020-03-17 17:39:01 +00:00
diBaseDir <- liftIO $ ghcupBaseDir
diBinDir <- liftIO $ ghcupBinDir
diGHCDir <- liftIO $ ghcupGHCBaseDir
diCacheDir <- liftIO $ ghcupCacheDir
diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
2020-01-11 20:15:05 +00:00
pure $ DebugInfo { .. }
---------------
--[ Compile ]--
---------------
compileGHC :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadResource m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
2020-04-25 10:06:41 +00:00
-> GHCTargetVersion -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
2020-04-25 10:06:41 +00:00
-> Maybe (Path Abs) -- ^ patch directory
-> [Text] -- ^ additional args to ./configure
2020-01-11 20:15:05 +00:00
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
2020-04-10 17:27:17 +00:00
, DistroNotFound
2020-01-11 20:15:05 +00:00
, DownloadFailed
, GHCupSetError
2020-04-10 17:27:17 +00:00
, NoCompatibleArch
, NoCompatiblePlatform
2020-01-11 20:15:05 +00:00
, NoDownload
2020-04-10 20:44:43 +00:00
, NotFoundInPATH
, PatchFailed
2020-01-11 20:15:05 +00:00
, UnknownArchive
]
m
()
2020-04-25 10:06:41 +00:00
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
2020-04-25 10:06:41 +00:00
whenM (liftIO $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
2020-01-11 20:15:05 +00:00
-- download source tarball
2020-04-25 10:06:41 +00:00
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
2020-01-11 20:15:05 +00:00
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
2020-04-10 17:27:17 +00:00
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
2020-01-11 20:15:05 +00:00
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
2020-04-22 16:12:40 +00:00
liftE $ runBuildAction
tmpUnpack
(Just ghcdir)
(compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir)
2020-01-11 20:15:05 +00:00
reThrowAll GHCupSetError $ postGHCInstall tver
pure ()
where
2020-04-25 10:06:41 +00:00
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|
2020-01-11 20:15:05 +00:00
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
2020-04-25 10:06:41 +00:00
HADDOCK_DOCS = NO
Stage1Only = YES|]
2020-01-11 20:15:05 +00:00
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
2020-01-11 20:15:05 +00:00
-> Path Abs
-> Path Abs
-> Excepts
2020-04-10 20:44:43 +00:00
'[ FileDoesNotExistError
2020-04-25 10:06:41 +00:00
, InvalidBuildConfig
, PatchFailed
, ProcessError
2020-04-10 20:44:43 +00:00
, NotFoundInPATH
]
2020-01-11 20:15:05 +00:00
m
()
compile bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|]
2020-04-25 10:06:41 +00:00
liftE $ checkBuildConfig
2020-03-18 16:31:17 +00:00
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
2020-04-25 10:06:41 +00:00
cEnv <- liftIO $ getEnvironment
2020-03-18 16:31:17 +00:00
2020-01-11 20:15:05 +00:00
if
2020-04-25 10:06:41 +00:00
| (_tvVersion tver) >= [vver|8.8.0|] -> do
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
2020-04-10 20:44:43 +00:00
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
2020-03-18 16:31:17 +00:00
lEM $ liftIO $ execLogged
2020-03-21 21:19:37 +00:00
"./configure"
2020-03-18 16:31:17 +00:00
False
2020-04-25 10:06:41 +00:00
( ["--prefix=" <> toFilePath ghcdir]
++ (maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver)
)
++ fmap E.encodeUtf8 aargs
)
2020-03-24 15:49:18 +00:00
[rel|ghc-conf|]
2020-03-18 16:31:17 +00:00
(Just workdir)
2020-04-25 10:06:41 +00:00
(Just (("GHC", toFilePath bghcPath) : cEnv))
2020-01-11 20:15:05 +00:00
| otherwise -> do
lEM $ liftIO $ execLogged
2020-03-21 21:19:37 +00:00
"./configure"
2020-01-11 20:15:05 +00:00
False
2020-04-25 10:06:41 +00:00
( [ "--prefix=" <> toFilePath ghcdir
, "--with-ghc=" <> either toFilePath toFilePath bghc
]
++ (maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver)
)
++ fmap E.encodeUtf8 aargs
)
2020-03-24 15:49:18 +00:00
[rel|ghc-conf|]
2020-01-11 20:15:05 +00:00
(Just workdir)
2020-04-25 10:06:41 +00:00
(Just cEnv)
2020-01-11 20:15:05 +00:00
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)...|]
2020-03-21 21:19:37 +00:00
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
2020-01-11 20:15:05 +00:00
lift $ $(logInfo) [i|Installing...|]
2020-03-21 21:19:37 +00:00
lEM $ liftIO $ make ["install"] (Just workdir)
2020-01-11 20:15:05 +00:00
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ copyFile (build_mk workdir) dest Overwrite
2020-03-16 09:47:09 +00:00
build_mk workdir = workdir </> [rel|mk/build.mk|]
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
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 ()
2020-01-11 20:15:05 +00:00
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
, MonadLogger m
, MonadIO m
, MonadFail m
2020-01-11 20:15:05 +00:00
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
2020-01-11 20:15:05 +00:00
-> Maybe Int
-> Maybe (Path Abs)
2020-01-11 20:15:05 +00:00
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, CopyError
2020-01-11 20:15:05 +00:00
, DigestError
2020-04-10 17:27:17 +00:00
, DistroNotFound
2020-01-11 20:15:05 +00:00
, DownloadFailed
2020-04-10 17:27:17 +00:00
, NoCompatibleArch
, NoCompatiblePlatform
2020-01-11 20:15:05 +00:00
, NoDownload
, NotInstalled
, PatchFailed
2020-01-11 20:15:05 +00:00
, UnknownArchive
]
m
()
compileCabal dls tver bghc jobs patchdir = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
2020-01-11 20:15:05 +00:00
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled tver >>= \a ->
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)
2020-01-11 20:15:05 +00:00
-- 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
2020-04-10 17:27:17 +00:00
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
2020-01-11 20:15:05 +00:00
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
2020-04-22 16:12:40 +00:00
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin
(bindir </> destFileName)
Overwrite
2020-01-11 20:15:05 +00:00
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
2020-01-11 20:15:05 +00:00
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
2020-01-11 20:15:05 +00:00
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
2020-01-11 20:15:05 +00:00
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')
]
2020-01-11 20:15:05 +00:00
tmp <- lift withGHCupTmpDir
liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
2020-01-11 20:15:05 +00:00
2020-03-21 21:19:37 +00:00
lEM $ liftIO $ execLogged "./bootstrap.sh"
2020-01-11 20:15:05 +00:00
False
2020-03-21 21:19:37 +00:00
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
2020-03-24 15:49:18 +00:00
[rel|cabal-bootstrap|]
2020-01-11 20:15:05 +00:00
(Just workdir)
(Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])
2020-01-11 20:15:05 +00:00
---------------------
--[ Upgrade GHCup ]--
---------------------
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
2020-01-11 20:15:05 +00:00
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NoUpdate
2020-01-11 20:15:05 +00:00
]
m
Version
upgradeGHCup dls mtarget force = do
2020-01-11 20:15:05 +00:00
lift $ $(logInfo) [i|Upgrading GHCup...|]
2020-03-16 09:49:34 +00:00
let latestVer = fromJust $ getLatest dls GHCup
2020-04-15 13:37:29 +00:00
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
2020-04-10 17:27:17 +00:00
pfreq <- liftE platformRequest
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
2020-03-16 09:47:09 +00:00
let fn = [rel|ghcup|]
2020-01-11 20:15:05 +00:00
p <- liftE $ download dli tmp (Just fn)
2020-04-12 18:22:16 +00:00
let fileMode' =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
2020-01-11 20:15:05 +00:00
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir
liftIO $ hideError NoSuchThing $ deleteFile (dest </> fn)
2020-01-11 20:15:05 +00:00
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
(dest </> fn)
Overwrite
2020-04-12 18:22:16 +00:00
liftIO $ setFileMode (toFilePath (dest </> fn)) fileMode'
Just fullDest -> do
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
2020-04-12 18:22:16 +00:00
liftIO $ setFileMode (toFilePath fullDest) fileMode'
2020-01-11 20:15:05 +00:00
pure latestVer
-------------
--[ Other ]--
-------------
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
2020-04-25 10:06:41 +00:00
postGHCInstall ver@GHCTargetVersion{..} = do
void $ liftE $ setGHC ver SetGHC_XYZ
2020-01-11 20:15:05 +00:00
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
2020-04-25 10:06:41 +00:00
(mj, mi) <- getMajorMinorV _tvVersion
getGHCForMajor mj mi _tvTarget >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)