1064 lines
33 KiB
Haskell
1064 lines
33 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.Bash
|
|
import GHCup.File
|
|
import GHCup.Prelude
|
|
import GHCup.Types
|
|
import GHCup.Types.Optics
|
|
import GHCup.Types.JSON ( )
|
|
|
|
import Control.Applicative
|
|
import Control.Exception.Safe
|
|
import Control.Monad
|
|
import Control.Monad.Fail ( MonadFail )
|
|
import Control.Monad.Logger
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Class ( lift )
|
|
import Control.Monad.Trans.Resource
|
|
hiding ( throwM )
|
|
import Data.Aeson
|
|
import Data.Attoparsec.ByteString
|
|
import Data.ByteString ( ByteString )
|
|
import Data.ByteString.Builder
|
|
import Data.Foldable
|
|
import Data.IORef
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.String.Interpolate
|
|
import Data.String.QQ
|
|
import Data.Text ( Text )
|
|
import Data.Versions
|
|
import Data.Word8
|
|
import GHC.IO.Exception
|
|
import HPath
|
|
import HPath.IO
|
|
import Haskus.Utils.Variant.Excepts
|
|
import Network.Http.Client hiding ( URL )
|
|
import Optics
|
|
import Prelude hiding ( abs
|
|
, readFile
|
|
)
|
|
import Safe
|
|
import System.IO.Error
|
|
import System.Info
|
|
import System.Posix.Env.ByteString ( getEnv )
|
|
import System.Posix.FilePath ( takeFileName )
|
|
import System.Posix.Files.ByteString ( readSymbolicLink )
|
|
import "unix" System.Posix.IO.ByteString
|
|
hiding ( fdWrite )
|
|
import "unix-bytestring" System.Posix.IO.ByteString
|
|
( fdWrite )
|
|
import System.Posix.RawFilePath.Directory.Errors
|
|
( hideError )
|
|
import System.Posix.Types
|
|
import URI.ByteString
|
|
import URI.ByteString.QQ
|
|
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import qualified Codec.Compression.BZip as BZip
|
|
import qualified Codec.Compression.GZip as GZip
|
|
import qualified Codec.Compression.Lzma as Lzma
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import qualified Data.Text.ICU as ICU
|
|
import qualified System.IO.Streams as Streams
|
|
import qualified System.Posix.FilePath as FP
|
|
import qualified System.Posix.RawFilePath.Directory
|
|
as RD
|
|
|
|
|
|
|
|
|
|
|
|
data Settings = Settings
|
|
{ cache :: Bool
|
|
, urlSource :: URLSource
|
|
}
|
|
deriving Show
|
|
|
|
getUrlSource :: MonadReader Settings m => m URLSource
|
|
getUrlSource = ask <&> urlSource
|
|
|
|
getCache :: MonadReader Settings m => m Bool
|
|
getCache = ask <&> cache
|
|
|
|
|
|
|
|
---------------------------
|
|
--[ Excepts Error types ]--
|
|
---------------------------
|
|
|
|
|
|
data PlatformResultError = NoCompatiblePlatform String
|
|
deriving Show
|
|
|
|
data NoDownload = NoDownload
|
|
deriving Show
|
|
|
|
data NoCompatibleArch = NoCompatibleArch String
|
|
deriving Show
|
|
|
|
data DistroNotFound = DistroNotFound
|
|
deriving Show
|
|
|
|
data ArchiveError = UnknownArchive ByteString
|
|
deriving Show
|
|
|
|
data URLException = UnsupportedURL
|
|
deriving Show
|
|
|
|
data FileError = CopyError String
|
|
deriving Show
|
|
|
|
data TagNotFound = TagNotFound Tag Tool
|
|
deriving Show
|
|
|
|
data AlreadyInstalled = AlreadyInstalled ToolRequest
|
|
deriving Show
|
|
|
|
data NotInstalled = NotInstalled ToolRequest
|
|
deriving Show
|
|
|
|
data NotSet = NotSet Tool
|
|
deriving Show
|
|
|
|
data JSONError = JSONDecodeError String
|
|
deriving Show
|
|
|
|
data ParseError = ParseError String
|
|
deriving Show
|
|
|
|
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
|
deriving Show
|
|
|
|
instance Exception ParseError
|
|
|
|
|
|
|
|
--------------------------------
|
|
--[ AvailableDownloads stuff ]--
|
|
--------------------------------
|
|
|
|
|
|
ghcupURL :: URI
|
|
ghcupURL =
|
|
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
|
|
|
|
|
|
-- | Get the tool versions that have this tag.
|
|
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
|
|
getTagged av tool tag = toListOf
|
|
( ix tool
|
|
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
|
% to Map.keys
|
|
% folded
|
|
)
|
|
av
|
|
|
|
getLatest :: AvailableDownloads -> Tool -> Maybe Version
|
|
getLatest av tool = headOf folded $ getTagged av tool Latest
|
|
|
|
getRecommended :: AvailableDownloads -> Tool -> Maybe Version
|
|
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
|
|
|
|
|
getDownloads :: ( FromJSONKey Tool
|
|
, FromJSONKey Version
|
|
, FromJSON VersionInfo
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
, MonadReader Settings m
|
|
)
|
|
=> Excepts
|
|
'[FileDoesNotExistError , URLException , JSONError]
|
|
m
|
|
AvailableDownloads
|
|
getDownloads = lift getUrlSource >>= \case
|
|
GHCupURL -> do
|
|
bs <- liftE $ downloadBS ghcupURL
|
|
lE' JSONDecodeError $ eitherDecode' bs
|
|
(OwnSource url) -> do
|
|
bs <- liftE $ downloadBS url
|
|
lE' JSONDecodeError $ eitherDecode' bs
|
|
(OwnSpec av) -> pure $ av
|
|
|
|
|
|
|
|
----------------------
|
|
--[ Download stuff ]--
|
|
----------------------
|
|
|
|
|
|
getDownloadInfo :: ( MonadLogger m
|
|
, MonadCatch m
|
|
, MonadIO m
|
|
, MonadReader Settings m
|
|
)
|
|
=> ToolRequest
|
|
-> Maybe PlatformRequest
|
|
-> Excepts
|
|
'[ DistroNotFound
|
|
, FileDoesNotExistError
|
|
, JSONError
|
|
, NoCompatibleArch
|
|
, NoDownload
|
|
, PlatformResultError
|
|
, URLException
|
|
]
|
|
m
|
|
DownloadInfo
|
|
getDownloadInfo (ToolRequest t v) mpfReq = do
|
|
urlSource <- lift getUrlSource
|
|
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
|
-- lift $ monadLoggerLog undefined undefined undefined ""
|
|
(PlatformRequest arch' plat ver) <- case mpfReq of
|
|
Just x -> pure x
|
|
Nothing -> do
|
|
(PlatformResult rp rv) <- liftE getPlatform
|
|
ar <- lE getArchitecture
|
|
pure $ PlatformRequest ar rp rv
|
|
|
|
dls <- liftE $ getDownloads
|
|
|
|
lE $ getDownloadInfo' t v arch' plat ver dls
|
|
|
|
|
|
getDownloadInfo' :: Tool
|
|
-> Version
|
|
-- ^ tool version
|
|
-> Architecture
|
|
-- ^ user arch
|
|
-> Platform
|
|
-- ^ user platform
|
|
-> Maybe Versioning
|
|
-- ^ optional version of the platform
|
|
-> AvailableDownloads
|
|
-> Either NoDownload DownloadInfo
|
|
getDownloadInfo' t v a p mv dls = maybe
|
|
(Left NoDownload)
|
|
Right
|
|
(with_distro <|> without_distro_ver <|> without_distro)
|
|
|
|
where
|
|
with_distro = distro_preview id id
|
|
without_distro_ver = distro_preview id (const Nothing)
|
|
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
|
|
|
distro_preview f g =
|
|
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
|
|
|
|
|
-- | Same as `download'`, except uses URL type. As such, this might
|
|
-- throw an exception if the url type or host protocol is not supported.
|
|
--
|
|
-- Only Absolute HTTP/HTTPS is supported.
|
|
download :: (MonadLogger m, MonadIO m)
|
|
=> DownloadInfo
|
|
-> Path Abs -- ^ destination dir
|
|
-> Maybe (Path Rel) -- ^ optional filename
|
|
-> Excepts '[URLException] m (Path Abs)
|
|
download dli dest mfn
|
|
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
|
|
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
|
|
| otherwise = throwE UnsupportedURL
|
|
|
|
where
|
|
dl https = do
|
|
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
|
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
|
host <-
|
|
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
|
?? UnsupportedURL
|
|
let path = view (dlUri % pathL') dli
|
|
let port = preview
|
|
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
|
dli
|
|
liftIO $ download' https host path port dest mfn
|
|
|
|
|
|
-- | This is used for downloading the JSON.
|
|
downloadBS :: (MonadCatch m, MonadIO m)
|
|
=> URI
|
|
-> Excepts
|
|
'[FileDoesNotExistError , URLException]
|
|
m
|
|
L.ByteString
|
|
downloadBS uri'
|
|
| scheme == [s|https|]
|
|
= dl True
|
|
| scheme == [s|http|]
|
|
= dl False
|
|
| scheme == [s|file|]
|
|
= liftException doesNotExistErrorType (FileDoesNotExistError path)
|
|
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
|
|
| otherwise
|
|
= throwE UnsupportedURL
|
|
|
|
where
|
|
scheme = view (uriSchemeL' % schemeBSL') uri'
|
|
path = view pathL' uri'
|
|
dl https = do
|
|
host <-
|
|
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
|
|
?? UnsupportedURL
|
|
let port = preview
|
|
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
|
uri'
|
|
liftIO $ downloadBS' https host path port
|
|
|
|
|
|
-- | Tries to download from the given http or https url
|
|
-- and saves the result in continuous memory into a file.
|
|
-- If the filename is not provided, then we:
|
|
-- 1. try to guess the filename from the url path
|
|
-- 2. otherwise create a random file
|
|
--
|
|
-- The file must not exist.
|
|
download' :: Bool -- ^ https?
|
|
-> ByteString -- ^ host (e.g. "www.example.com")
|
|
-> ByteString -- ^ path (e.g. "/my/file")
|
|
-> Maybe Int -- ^ optional port (e.g. 3000)
|
|
-> Path Abs -- ^ destination directory to download into
|
|
-> Maybe (Path Rel) -- ^ optionally provided filename
|
|
-> IO (Path Abs)
|
|
download' https host path port dest mfn = do
|
|
(fd, fp) <- getFile
|
|
let stepper = fdWrite fd
|
|
flip finally (closeFd fd) $ downloadInternal https host path port stepper
|
|
pure fp
|
|
where
|
|
-- Manage to find a file we can write the body into.
|
|
getFile :: IO (Fd, Path Abs)
|
|
getFile = do
|
|
-- destination dir must exist
|
|
hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
|
case mfn of
|
|
-- if a filename was provided, try that
|
|
Just x ->
|
|
let fp = dest </> x
|
|
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
|
Nothing -> do
|
|
-- ...otherwise try to infer the filename from the URL path
|
|
fn' <- urlBaseName path
|
|
let fp = dest </> fn'
|
|
fmap (, fp) $ createRegularFileFd newFilePerms fp
|
|
|
|
|
|
-- | Load the result of this download into memory at once.
|
|
downloadBS' :: Bool -- ^ https?
|
|
-> ByteString -- ^ host (e.g. "www.example.com")
|
|
-> ByteString -- ^ path (e.g. "/my/file")
|
|
-> Maybe Int -- ^ optional port (e.g. 3000)
|
|
-> IO (L.ByteString)
|
|
downloadBS' https host path port = do
|
|
bref <- newIORef (mempty :: Builder)
|
|
let stepper bs = modifyIORef bref (<> byteString bs)
|
|
downloadInternal https host path port stepper
|
|
readIORef bref <&> toLazyByteString
|
|
|
|
|
|
downloadInternal :: Bool
|
|
-> ByteString
|
|
-> ByteString
|
|
-> Maybe Int
|
|
-> (ByteString -> IO a) -- ^ the consuming step function
|
|
-> IO ()
|
|
downloadInternal https host path port consumer = do
|
|
c <- case https of
|
|
True -> do
|
|
ctx <- baselineContextSSL
|
|
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
|
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
|
|
|
|
let q = buildRequest1 $ http GET path
|
|
|
|
sendRequest c q emptyBody
|
|
|
|
receiveResponse
|
|
c
|
|
(\_ i' -> do
|
|
outStream <- Streams.makeOutputStream
|
|
(\case
|
|
Just bs -> void $ consumer bs
|
|
Nothing -> pure ()
|
|
)
|
|
Streams.connect i' outStream
|
|
)
|
|
|
|
closeConnection c
|
|
|
|
|
|
|
|
--------------------------
|
|
--[ Platform detection ]--
|
|
--------------------------
|
|
|
|
|
|
getArchitecture :: Either NoCompatibleArch Architecture
|
|
getArchitecture = case arch of
|
|
"x86_64" -> Right A_64
|
|
"i386" -> Right A_32
|
|
what -> Left (NoCompatibleArch what)
|
|
|
|
|
|
|
|
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
|
=> Excepts
|
|
'[PlatformResultError , DistroNotFound]
|
|
m
|
|
PlatformResult
|
|
getPlatform = do
|
|
pfr <- case os of
|
|
"linux" -> do
|
|
(distro, ver) <- liftE getLinuxDistro
|
|
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
|
-- TODO: these are not verified
|
|
"darwin" ->
|
|
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
|
"freebsd" -> do
|
|
ver <- getFreeBSDVersion
|
|
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
|
what -> throwE $ NoCompatiblePlatform what
|
|
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
|
pure pfr
|
|
where getFreeBSDVersion = pure Nothing
|
|
|
|
|
|
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
|
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
|
getLinuxDistro = do
|
|
-- TODO: don't do alternative on IO, because it hides bugs
|
|
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
|
[ try_os_release
|
|
, try_lsb_release_cmd
|
|
, try_lsb_release
|
|
, try_redhat_release
|
|
, try_debian_version
|
|
]
|
|
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
|
distro = if
|
|
| hasWord name ["debian"] -> Debian
|
|
| hasWord name ["ubuntu"] -> Ubuntu
|
|
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
|
| hasWord name ["fedora"] -> Fedora
|
|
| hasWord name ["centos"] -> CentOS
|
|
| hasWord name ["Red Hat"] -> RedHat
|
|
| hasWord name ["alpine"] -> Alpine
|
|
| hasWord name ["exherbo"] -> Exherbo
|
|
| hasWord name ["gentoo"] -> Gentoo
|
|
| otherwise -> UnknownLinux
|
|
pure (distro, parsedVer)
|
|
where
|
|
hasWord t matches = foldr
|
|
(\x y ->
|
|
( isJust
|
|
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
|
|
$ t
|
|
)
|
|
|| y
|
|
)
|
|
False
|
|
(T.pack <$> matches)
|
|
|
|
os_release :: Path Abs
|
|
os_release = [abs|/etc/os-release|]
|
|
lsb_release :: Path Abs
|
|
lsb_release = [abs|/etc/lsb-release|]
|
|
lsb_release_cmd :: Path Rel
|
|
lsb_release_cmd = [rel|lsb-release|]
|
|
redhat_release :: Path Abs
|
|
redhat_release = [abs|/etc/redhat-release|]
|
|
debian_version :: Path Abs
|
|
debian_version = [abs|/etc/debian_version|]
|
|
|
|
try_os_release :: IO (Text, Maybe Text)
|
|
try_os_release = do
|
|
(Just name) <- getAssignmentValueFor os_release "NAME"
|
|
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
|
pure (T.pack name, fmap T.pack ver)
|
|
|
|
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
|
try_lsb_release_cmd = do
|
|
(Just _) <- findExecutable lsb_release_cmd
|
|
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
|
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
|
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
|
|
|
try_lsb_release :: IO (Text, Maybe Text)
|
|
try_lsb_release = do
|
|
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
|
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
|
pure (T.pack name, fmap T.pack ver)
|
|
|
|
try_redhat_release :: IO (Text, Maybe Text)
|
|
try_redhat_release = do
|
|
t <- fmap lBS2sT $ readFile redhat_release
|
|
let nameRe n =
|
|
join
|
|
. fmap (ICU.group 0)
|
|
. ICU.find
|
|
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
|
|
$ t
|
|
verRe =
|
|
join
|
|
. fmap (ICU.group 0)
|
|
. ICU.find
|
|
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
|
|
$ t
|
|
(Just name) <- pure
|
|
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
|
pure (name, verRe)
|
|
|
|
try_debian_version :: IO (Text, Maybe Text)
|
|
try_debian_version = do
|
|
ver <- readFile debian_version
|
|
pure (T.pack "debian", Just $ lBS2sT ver)
|
|
|
|
|
|
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
|
-- parseAvailableDownloads = undefined
|
|
|
|
|
|
|
|
-------------------------
|
|
--[ Tool installation ]--
|
|
-------------------------
|
|
|
|
-- TODO: custom logger intepreter and pretty printing
|
|
|
|
-- | Install a tool, such as GHC or cabal. This also sets
|
|
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
|
|
--
|
|
-- This can fail in many ways. You may want to explicitly catch
|
|
-- `AlreadyInstalled` to not make it fatal.
|
|
installTool :: ( MonadThrow m
|
|
, MonadReader Settings m
|
|
, MonadLogger m
|
|
, MonadCatch m
|
|
, MonadIO m
|
|
, MonadFail m
|
|
, MonadResource m
|
|
) -- tmp file
|
|
=> 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 <- lift withGHCupTmpDir
|
|
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/<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
|
|
destdir <- liftIO $ ghcupBinDir
|
|
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir
|
|
|
|
-- for ghc tools (ghc, ghci, haddock, ...)
|
|
verfiles <- ghcToolFiles ver
|
|
forM_ verfiles $ \file -> do
|
|
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
|
|
targetFile <- case sghc of
|
|
SetGHCOnly -> pure file
|
|
SetGHCMajor -> do
|
|
major' <-
|
|
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
|
<$> getGHCMajor ver
|
|
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
|
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
|
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
|
(destdir </> targetFile)
|
|
liftIO $ createSymlink (destdir </> targetFile)
|
|
(ghcLinkDestination (toFilePath file) ver)
|
|
|
|
-- create symlink for share dir
|
|
liftIO $ symlinkShareDir ghcdir verBS
|
|
|
|
pure ()
|
|
|
|
where
|
|
|
|
symlinkShareDir :: Path Abs -> ByteString -> IO ()
|
|
symlinkShareDir ghcdir verBS = do
|
|
destdir <- ghcupBaseDir
|
|
case sghc of
|
|
SetGHCOnly -> do
|
|
let sharedir = [rel|share|] :: Path Rel
|
|
let fullsharedir = ghcdir </> sharedir
|
|
whenM (doesDirectoryExist fullsharedir) $ do
|
|
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
|
(destdir </> sharedir)
|
|
createSymlink
|
|
(destdir </> sharedir)
|
|
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
|
|
_ -> pure ()
|
|
|
|
|
|
|
|
|
|
------------------
|
|
--[ List tools ]--
|
|
------------------
|
|
|
|
|
|
data ListCriteria = ListInstalled
|
|
| ListSet
|
|
deriving Show
|
|
|
|
data ListResult = ListResult
|
|
{ lTool :: Tool
|
|
, lVer :: Version
|
|
, lTag :: [Tag]
|
|
, lInstalled :: Bool
|
|
, lSet :: Bool
|
|
}
|
|
deriving Show
|
|
|
|
|
|
availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])]
|
|
availableToolVersions av tool = toListOf
|
|
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
|
|
av
|
|
|
|
|
|
listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m)
|
|
=> Maybe Tool
|
|
-> Maybe ListCriteria
|
|
-> Excepts
|
|
'[FileDoesNotExistError , URLException , JSONError]
|
|
m
|
|
[ListResult]
|
|
listVersions lt criteria = do
|
|
dls <- liftE $ getDownloads
|
|
liftIO $ listVersions' dls lt criteria
|
|
|
|
|
|
listVersions' :: AvailableDownloads
|
|
-> Maybe Tool
|
|
-> Maybe ListCriteria
|
|
-> IO [ListResult]
|
|
listVersions' av lt criteria = case lt of
|
|
Just t -> do
|
|
filter' <$> forM (availableToolVersions av t) (toListResult t)
|
|
Nothing -> do
|
|
ghcvers <- listVersions' av (Just GHC) criteria
|
|
cabalvers <- listVersions' av (Just Cabal) criteria
|
|
pure (ghcvers <> cabalvers)
|
|
|
|
where
|
|
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
|
|
toListResult t (v, tags) = case t of
|
|
GHC -> do
|
|
lSet <- fmap (maybe False (== v)) $ ghcSet
|
|
lInstalled <- ghcInstalled v
|
|
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
|
Cabal -> do
|
|
lSet <- fmap (== v) $ cabalSet
|
|
lInstalled <- cabalInstalled v
|
|
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
|
|
|
filter' :: [ListResult] -> [ListResult]
|
|
filter' lr = case criteria of
|
|
Nothing -> lr
|
|
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
|
|
Just ListSet -> filter (\ListResult {..} -> lSet) lr
|
|
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ GHC rm ]--
|
|
--------------
|
|
|
|
|
|
-- | This function may throw and crash in various ways.
|
|
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
|
=> Version
|
|
-> Excepts '[NotInstalled] m ()
|
|
rmGHCVer ver = do
|
|
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
|
|
dir <- liftIO $ ghcupGHCDir ver
|
|
let d' = toFilePath dir
|
|
exists <- liftIO $ doesDirectoryExist dir
|
|
|
|
toolsFiles <- liftE $ ghcToolFiles ver
|
|
|
|
if exists
|
|
then do
|
|
-- this isn't atomic, order matters
|
|
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
|
|
liftIO $ deleteDirRecursive dir
|
|
|
|
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
|
liftIO $ rmMinorSymlinks
|
|
|
|
lift $ $(logInfo) [i|Removing/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 { .. }
|
|
|
|
|
|
|
|
-----------------
|
|
--[ Utilities ]--
|
|
-----------------
|
|
|
|
|
|
ghcupBaseDir :: IO (Path Abs)
|
|
ghcupBaseDir = do
|
|
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
|
|
|
ghcupGHCBaseDir :: IO (Path Abs)
|
|
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
|
|
|
ghcupGHCDir :: Version -> IO (Path Abs)
|
|
ghcupGHCDir ver = do
|
|
ghcbasedir <- ghcupGHCBaseDir
|
|
verdir <- parseRel (verToBS ver)
|
|
pure (ghcbasedir </> verdir)
|
|
|
|
|
|
-- | The symlink destination of a ghc tool.
|
|
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
|
-> Version
|
|
-> ByteString
|
|
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
|
|
|
|
|
-- | Extract the version part of the result of `ghcLinkDestination`.
|
|
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
|
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
|
where
|
|
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
|
verParser = many1' (notWord8 _slash) >>= \t ->
|
|
case version $ E.decodeUtf8 $ B.pack t of
|
|
Left e -> fail $ show e
|
|
Right r -> pure r
|
|
|
|
|
|
ghcInstalled :: Version -> IO Bool
|
|
ghcInstalled ver = do
|
|
ghcdir <- ghcupGHCDir ver
|
|
doesDirectoryExist ghcdir
|
|
|
|
|
|
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
|
ghcSet = do
|
|
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
|
|
|
-- link destination is of the form ../ghc/<ver>/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 :: (MonadResource m -- temp file
|
|
, 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
|
|
tmp <- toFilePath <$> lift withGHCupTmpDir
|
|
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/<ver>/bin/*
|
|
-- while ignoring *-<ver> 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 <ver> 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
|