573 lines
18 KiB
Haskell
573 lines
18 KiB
Haskell
{-# 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.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.Version
|
|
|
|
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 Control.Monad.Trans.Resource
|
|
hiding ( throwM )
|
|
import Data.ByteString ( ByteString )
|
|
import Data.Foldable
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.String.Interpolate
|
|
import Data.String.QQ
|
|
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 System.IO.Error
|
|
import System.Posix.Env.ByteString ( getEnvironment )
|
|
import System.Posix.FilePath ( getSearchPath )
|
|
import System.Posix.RawFilePath.Directory.Errors
|
|
( hideError )
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text.Encoding as E
|
|
|
|
|
|
|
|
-------------------------
|
|
--[ 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
|
|
, MonadResource m
|
|
) -- tmp file
|
|
=> BinaryDownloads
|
|
-> ToolRequest
|
|
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
|
-> Excepts
|
|
'[ AlreadyInstalled
|
|
, ArchiveError
|
|
, DistroNotFound
|
|
, FileDoesNotExistError
|
|
, FileError
|
|
, JSONError
|
|
, NoCompatibleArch
|
|
, NoDownload
|
|
, NotInstalled
|
|
, PlatformResultError
|
|
, ProcessError
|
|
, URLException
|
|
, DigestError
|
|
]
|
|
m
|
|
()
|
|
installTool bDls treq mpfReq = do
|
|
lift $ $(logDebug) [i|Requested to install: #{treq}|]
|
|
|
|
-- stop if GHC is already installed, other tools can be overwritten
|
|
case treq of
|
|
(ToolRequest GHC _) ->
|
|
whenM (liftIO $ toolAlreadyInstalled treq)
|
|
$ (throwE $ AlreadyInstalled treq)
|
|
(ToolRequest Cabal _) -> pure ()
|
|
|
|
Settings {..} <- lift ask
|
|
|
|
-- download (or use cached version)
|
|
dlinfo <- liftE $ getDownloadInfo bDls treq mpfReq
|
|
dl <- liftE $ downloadCached dlinfo Nothing
|
|
|
|
-- unpack
|
|
tmpUnpack <- lift withGHCupTmpDir
|
|
liftE $ unpackToDir tmpUnpack 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 tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
|
|
|
case treq of
|
|
(ToolRequest GHC ver) -> do
|
|
liftE $ installGHC archiveSubdir ghcdir
|
|
liftE $ postGHCInstall ver
|
|
(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|]
|
|
False
|
|
[[s|--prefix=|] <> toFilePath inst]
|
|
(Just path)
|
|
Nothing
|
|
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
|
|
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/<ver>/bin/ghc
|
|
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
|
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
|
--
|
|
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
|
-- for `SetGHCOnly` constructor.
|
|
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
|
|
=> Version
|
|
-> SetGHC
|
|
-> Excepts '[NotInstalled] m ()
|
|
setGHC ver sghc = do
|
|
let verBS = verToBS ver
|
|
ghcdir <- liftIO $ ghcupGHCDir ver
|
|
|
|
-- symlink destination
|
|
bindir <- liftIO $ ghcupBinDir
|
|
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
|
|
|
when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)
|
|
|
|
-- for ghc tools (ghc, ghci, haddock, ...)
|
|
verfiles <- ghcToolFiles ver
|
|
forM_ verfiles $ \file -> do
|
|
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> 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
|
|
(bindir </> targetFile)
|
|
liftIO $ createSymlink (bindir </> 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 ()
|
|
|
|
-- The old tool symlinks might be different (e.g. more) than the
|
|
-- requested version. Have to avoid "stray" symlinks.
|
|
delOldSymlinks :: forall m
|
|
. (MonadThrow m, MonadFail m, MonadIO m)
|
|
=> Path Abs
|
|
-> Excepts '[] m ()
|
|
delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
|
|
mv <- ghcSet
|
|
for_ mv $ \ver' -> do
|
|
verfiles <- ghcToolFiles ver'
|
|
for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
|
|
|
|
|
|
|
|
|
|
------------------
|
|
--[ List tools ]--
|
|
------------------
|
|
|
|
|
|
data ListCriteria = ListInstalled
|
|
| ListSet
|
|
deriving Show
|
|
|
|
data ListResult = ListResult
|
|
{ lTool :: Tool
|
|
, lVer :: Version
|
|
, lTag :: [Tag]
|
|
, lInstalled :: Bool
|
|
, lSet :: Bool
|
|
}
|
|
deriving Show
|
|
|
|
|
|
availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])]
|
|
availableToolVersions av tool = toListOf
|
|
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
|
|
av
|
|
|
|
|
|
listVersions :: BinaryDownloads
|
|
-> 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/rewiring 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 { .. }
|
|
|
|
|
|
|
|
---------------
|
|
--[ Compile ]--
|
|
---------------
|
|
|
|
|
|
-- TODO: build config
|
|
compileGHC :: ( MonadReader Settings m
|
|
, MonadThrow m
|
|
, MonadResource m
|
|
, MonadLogger m
|
|
, MonadIO m
|
|
, MonadFail m
|
|
)
|
|
=> SourceDownloads
|
|
-> Version -- ^ version to install
|
|
-> Version -- ^ version to bootstrap with
|
|
-> Maybe Int -- ^ jobs
|
|
-> Maybe (Path Abs) -- ^ build config
|
|
-> Excepts
|
|
'[ AlreadyInstalled
|
|
, NotInstalled
|
|
, GHCNotFound
|
|
, ArchiveError
|
|
, ProcessError
|
|
, URLException
|
|
, DigestError
|
|
, BuildConfigNotFound
|
|
]
|
|
m
|
|
()
|
|
compileGHC dls tver bver jobs mbuildConfig = do
|
|
let treq = ToolRequest GHC tver
|
|
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
|
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
|
|
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
|
|
|
|
-- download source tarball
|
|
dlInfo <- preview (ix tver) dls ?? GHCNotFound
|
|
dl <- liftE $ downloadCached dlInfo Nothing
|
|
|
|
-- unpack
|
|
tmpUnpack <- lift mkGhcupTmpDir
|
|
liftE $ unpackToDir tmpUnpack dl
|
|
|
|
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
|
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
|
|
|
ghcdir <- liftIO $ ghcupGHCDir tver
|
|
if
|
|
| tver >= [vver|8.8.0|] -> do
|
|
cEnv <- liftIO $ getEnvironment
|
|
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
|
bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
|
|
let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
|
|
lEM $ liftIO $ exec [s|./configure|]
|
|
False
|
|
[[s|--prefix=|] <> toFilePath ghcdir]
|
|
(Just workdir)
|
|
(Just newEnv)
|
|
| otherwise -> do
|
|
lEM $ liftIO $ exec
|
|
[s|./configure|]
|
|
False
|
|
[ [s|--prefix=|] <> toFilePath ghcdir
|
|
, [s|--with-ghc=|] <> toFilePath bghc
|
|
]
|
|
(Just workdir)
|
|
Nothing
|
|
|
|
let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
|
|
case mbuildConfig of
|
|
Just bc -> liftIO $ copyFile bc build_mk Overwrite
|
|
Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf
|
|
|
|
lEM $ liftIO $ exec [s|make|]
|
|
True
|
|
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
|
|
(Just workdir)
|
|
Nothing
|
|
|
|
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing
|
|
|
|
liftE $ postGHCInstall tver
|
|
pure ()
|
|
|
|
where
|
|
defaultConf = [s|
|
|
V=0
|
|
BUILD_MAN = NO
|
|
BUILD_SPHINX_HTML = NO
|
|
BUILD_SPHINX_PDF = NO
|
|
HADDOCK_DOCS = YES
|
|
GhcWithLlvmCodeGen = YES|]
|
|
|
|
|
|
|
|
---------------
|
|
--[ Set GHC ]--
|
|
---------------
|
|
|
|
|
|
upgradeGHCup :: ( MonadReader Settings m
|
|
, MonadCatch m
|
|
, MonadLogger m
|
|
, MonadThrow m
|
|
, MonadResource m
|
|
, MonadIO m
|
|
)
|
|
=> BinaryDownloads
|
|
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
|
-> Excepts
|
|
'[ DigestError
|
|
, URLException
|
|
, DistroNotFound
|
|
, PlatformResultError
|
|
, NoCompatibleArch
|
|
, NoDownload
|
|
]
|
|
m
|
|
Version
|
|
upgradeGHCup dls mtarget = do
|
|
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
|
let latestVer = head $ getTagged dls GHCup Latest
|
|
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
|
|
tmp <- lift withGHCupTmpDir
|
|
let fn = [rel|ghcup|] :: Path Rel
|
|
p <- liftE $ download dli tmp (Just fn)
|
|
case mtarget of
|
|
Nothing -> do
|
|
dest <- liftIO $ ghcupBinDir
|
|
liftIO $ copyFile p (dest </> fn) Overwrite
|
|
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
|
|
pure latestVer
|
|
|
|
|
|
|
|
-------------
|
|
--[ Other ]--
|
|
-------------
|
|
|
|
|
|
-- | Creates ghc-x.y.z and ghc-x.y symlinks.
|
|
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
|
|
=> Version
|
|
-> Excepts '[NotInstalled] m ()
|
|
postGHCInstall ver = do
|
|
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)
|