ghcup-hs/lib/GHCup.hs

807 lines
27 KiB
Haskell
Raw Normal View History

2020-01-14 21:55:34 +00:00
{-# LANGUAGE DataKinds #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE DeriveGeneric #-}
2020-01-14 21:55:34 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
2020-01-14 21:55:34 +00:00
{-# LANGUAGE TemplateHaskell #-}
2020-02-19 19:54:23 +00:00
{-# LANGUAGE TypeFamilies #-}
2020-02-24 13:56:13 +00:00
{-# LANGUAGE TypeApplications #-}
2020-01-14 21:55:34 +00:00
-- TODO: handle SIGTERM, SIGUSR
module GHCup where
2020-01-16 22:27:38 +00:00
2020-02-18 08:40:01 +00:00
import qualified Codec.Archive.Tar as Tar
2020-01-14 21:55:34 +00:00
import Control.Applicative
2020-01-16 22:27:38 +00:00
import Control.Monad
2020-02-24 13:56:13 +00:00
import Control.Monad.Fail ( MonadFail )
2020-02-22 18:21:10 +00:00
import Control.Monad.Reader
import Control.Monad.Logger
2020-02-24 13:56:13 +00:00
import Control.Monad.Cont
2020-01-17 22:29:16 +00:00
import Control.Monad.Trans.Maybe
2020-02-22 18:21:10 +00:00
import Control.Monad.Trans.Class ( lift )
2020-01-17 22:29:16 +00:00
import Control.Monad.IO.Class
import Control.Exception.Safe
2020-02-18 08:40:01 +00:00
import Data.ByteString ( ByteString )
2020-01-16 22:27:38 +00:00
import Data.Foldable ( asum )
2020-02-19 19:54:23 +00:00
import Data.String.QQ
2020-01-16 22:27:38 +00:00
import Data.Text ( Text )
import Data.Versions
2020-01-14 21:55:34 +00:00
import GHCup.Bash
import GHCup.File
2020-01-16 22:27:38 +00:00
import GHCup.Prelude
2020-01-14 21:55:34 +00:00
import GHCup.Types
import GHCup.Types.Optics
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
2020-01-16 22:27:38 +00:00
, readFile
2020-01-14 21:55:34 +00:00
)
import System.Info
2020-01-17 22:29:16 +00:00
import System.IO.Error
2020-01-16 22:27:38 +00:00
import qualified Data.Text as T
2020-02-19 19:54:23 +00:00
import qualified Data.Text.Encoding as E
2020-01-16 22:27:38 +00:00
import qualified Data.Text.ICU as ICU
2020-01-17 22:29:16 +00:00
import Data.Maybe
2020-01-14 21:55:34 +00:00
import qualified Data.Map.Strict as Map
2020-02-19 19:54:23 +00:00
import Data.Word8
2020-01-17 22:29:16 +00:00
import GHC.IO.Exception
import GHC.IO.Handle
2020-02-18 08:40:01 +00:00
import Haskus.Utils.Variant.Excepts
import Haskus.Utils.Variant.VEither
2020-01-17 22:29:16 +00:00
import Network.Http.Client hiding ( URL )
import System.IO.Streams ( InputStream
, OutputStream
, stdout
)
import qualified System.IO.Streams as Streams
2020-02-18 08:40:01 +00:00
import System.Posix.FilePath ( takeExtension
2020-02-24 13:56:13 +00:00
, takeFileName
2020-02-18 08:40:01 +00:00
, splitExtension
)
import qualified System.Posix.FilePath as FP
2020-02-24 13:56:13 +00:00
import System.Posix.Files.ByteString ( readSymbolicLink )
2020-02-18 08:40:01 +00:00
import System.Posix.Env.ByteString ( getEnvDefault )
2020-01-17 22:29:16 +00:00
import System.Posix.Temp.ByteString
2020-02-24 13:56:13 +00:00
import System.Posix.RawFilePath.Directory.Errors
( hideError )
2020-01-17 22:29:16 +00:00
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import System.Posix.FD as FD
2020-02-16 21:06:07 +00:00
import System.Posix.Foreign ( oTrunc )
2020-01-17 22:29:16 +00:00
import qualified Data.ByteString as B
import OpenSSL ( withOpenSSL )
import qualified Data.ByteString.Char8 as C
import Data.Functor ( ($>) )
import System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
2020-02-18 08:40:01 +00:00
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Codec.Compression.BZip as BZip
import qualified Data.ByteString.UTF8 as UTF8
2020-02-19 12:30:18 +00:00
import qualified System.Posix.Process.ByteString
as SPPB
2020-02-19 19:54:23 +00:00
import System.Posix.Directory.ByteString
( changeWorkingDirectory )
import URI.ByteString
import URI.ByteString.QQ
2020-02-19 12:30:18 +00:00
2020-02-18 08:40:01 +00:00
2020-02-24 13:56:13 +00:00
data Settings = Settings
{ cache :: Bool
}
deriving Show
2020-02-22 18:21:10 +00:00
2020-02-18 08:40:01 +00:00
---------------------------
--[ Excepts Error types ]--
---------------------------
data PlatformResultError = NoCompatiblePlatform
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data NoDownload = NoDownload
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data NoCompatibleArch = NoCompatibleArch String
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data DistroNotFound = DistroNotFound
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
data ArchiveError = UnknownArchive ByteString
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-18 08:40:01 +00:00
2020-02-19 19:54:23 +00:00
data URLException = UnsupportedURL
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-19 19:54:23 +00:00
2020-02-24 13:56:13 +00:00
data FileError = CopyError String
deriving Show
2020-02-22 18:21:10 +00:00
data TagNotFound = TagNotFound Tag Tool
2020-02-24 13:56:13 +00:00
deriving Show
2020-02-22 18:21:10 +00:00
2020-02-24 13:56:13 +00:00
data AlreadyInstalled = AlreadyInstalled ToolRequest
deriving Show
data NotInstalled = NotInstalled ToolRequest
deriving Show
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
--------------------------------
--[ AvailableDownloads stuff ]--
--------------------------------
2020-02-18 08:40:01 +00:00
2020-01-14 21:55:34 +00:00
2020-02-19 19:54:23 +00:00
-- TODO: version quasiquoter
2020-01-14 21:55:34 +00:00
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
2020-02-22 18:21:10 +00:00
[ ( [ver|8.6.5|]
, VersionInfo [Latest] $ Map.fromList
2020-01-14 21:55:34 +00:00
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
2020-01-16 22:27:38 +00:00
, Map.fromList
[ ( Nothing
2020-02-22 18:21:10 +00:00
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Ubuntu
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
2020-01-16 22:27:38 +00:00
)
]
2020-01-14 21:55:34 +00:00
)
2020-01-17 00:50:01 +00:00
, ( Linux Debian
, Map.fromList
[ ( Nothing
2020-02-22 18:21:10 +00:00
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
2020-01-17 00:50:01 +00:00
)
2020-02-22 18:21:10 +00:00
, ( Just $ [vers|8|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
]
)
]
)
]
)
, ( Cabal
, Map.fromList
[ ( [ver|3.0.0.0|]
2020-02-24 13:56:13 +00:00
, VersionInfo [Recommended, Latest] $ Map.fromList
2020-02-22 18:21:10 +00:00
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
Nothing
2020-01-17 00:50:01 +00:00
)
]
)
2020-01-14 21:55:34 +00:00
]
)
]
)
]
)
]
2020-02-19 19:54:23 +00:00
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
2020-02-22 18:21:10 +00:00
-- | 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
----------------------
--[ Download stuff ]--
----------------------
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> Excepts
2020-02-24 13:56:13 +00:00
'[ PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
]
2020-02-22 18:21:10 +00:00
m
DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource)
-- lift $ monadLoggerLog undefined undefined undefined ""
2020-01-16 22:27:38 +00:00
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
2020-02-18 08:40:01 +00:00
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
2020-01-16 22:27:38 +00:00
pure $ PlatformRequest ar rp rv
dls <- case urlSource of
2020-02-24 13:56:13 +00:00
-- TODO
2020-01-16 22:27:38 +00:00
GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
2020-02-22 18:21:10 +00:00
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
2020-02-18 08:40:01 +00:00
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
2020-01-14 21:55:34 +00:00
where
2020-01-16 22:27:38 +00:00
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
2020-02-18 08:40:01 +00:00
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
distro_preview f g =
2020-02-22 18:21:10 +00:00
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
2020-01-17 22:29:16 +00:00
-- | 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.
2020-01-24 22:43:11 +00:00
download :: Bool -- ^ https?
2020-02-19 19:54:23 +00:00
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
2020-01-24 22:43:11 +00:00
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename
2020-01-17 22:29:16 +00:00
-> IO (Path Abs)
download https host path port dest mfn = do
fromJust <$> downloadInternal https host path port (Right (dest, mfn))
-- | 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.
2020-02-22 18:21:10 +00:00
download' :: (MonadLogger m, MonadIO m)
=> DownloadInfo
2020-02-18 08:40:01 +00:00
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
2020-02-19 19:54:23 +00:00
-> Excepts '[URLException] m (Path Abs)
2020-02-22 18:21:10 +00:00
download' dli dest mfn
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
2020-02-19 19:54:23 +00:00
| otherwise = throwE UnsupportedURL
2020-01-17 22:29:16 +00:00
2020-02-19 19:54:23 +00:00
where
dl https = do
2020-02-22 18:21:10 +00:00
lift $ $(logInfo)
([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli)))
2020-02-19 19:54:23 +00:00
host <-
2020-02-22 18:21:10 +00:00
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
2020-02-19 19:54:23 +00:00
?? UnsupportedURL
2020-02-22 18:21:10 +00:00
let path = view (dlUri % pathL') dli
2020-02-19 19:54:23 +00:00
let port = preview
2020-02-22 18:21:10 +00:00
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
2020-02-19 19:54:23 +00:00
liftIO $ download https host path port dest mfn
2020-01-17 22:29:16 +00:00
-- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout.
2020-02-18 08:40:01 +00:00
downloadFd :: Bool -- ^ https?
2020-02-19 19:54:23 +00:00
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
2020-01-17 22:29:16 +00:00
-> Fd -- ^ function creating an Fd to write the body into
-> IO ()
downloadFd https host path port fd =
void $ downloadInternal https host path port (Left fd)
downloadInternal :: Bool
2020-02-19 19:54:23 +00:00
-> ByteString
-> ByteString
-> Maybe Int
2020-01-24 22:43:11 +00:00
-> Either Fd (Path Abs, Maybe (Path Rel))
2020-01-17 22:29:16 +00:00
-> IO (Maybe (Path Abs))
downloadInternal https host path port dest = do
c <- case https of
True -> do
ctx <- baselineContextSSL
2020-02-19 19:54:23 +00:00
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
2020-01-17 22:29:16 +00:00
2020-02-19 19:54:23 +00:00
let q = buildRequest1 $ http GET ([s|/|] <> path)
2020-01-17 22:29:16 +00:00
sendRequest c q emptyBody
(fd, mfp) <- case dest of
Right (dest, mfn) -> getFile dest mfn <&> (<&> Just)
Left fd -> pure (fd, Nothing)
-- wrapper so we can close Fds we created
let receiveResponse' c b = case dest of
Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b
Left _ -> receiveResponse c b
receiveResponse'
c
(\p i -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ fdWrite fd bs
Nothing -> pure ()
)
Streams.connect i outStream
)
closeConnection c
pure mfp
where
-- Manage to find a file we can write the body into.
2020-01-24 22:43:11 +00:00
getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs)
2020-01-17 22:29:16 +00:00
getFile dest mfn = 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
2020-02-19 19:54:23 +00:00
Nothing -> do
2020-01-17 22:29:16 +00:00
-- ...otherwise try to infer the filename from the URL path
2020-02-22 18:21:10 +00:00
fn' <- urlBaseName path
2020-02-19 19:54:23 +00:00
let fp = dest </> fn'
fmap (, fp) $ createRegularFileFd newFilePerms fp
2020-01-14 21:55:34 +00:00
2020-02-18 08:40:01 +00:00
--------------------------
--[ Platform detection ]--
--------------------------
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
2020-01-14 21:55:34 +00:00
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
2020-02-18 08:40:01 +00:00
=> Excepts
2020-02-24 13:56:13 +00:00
'[PlatformResultError , DistroNotFound]
2020-02-18 08:40:01 +00:00
m
PlatformResult
2020-02-22 18:21:10 +00:00
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
lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr)
pure pfr
2020-02-18 08:40:01 +00:00
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
2020-02-24 13:56:13 +00:00
-- TODO: don't do alternative on IO, because it hides bugs
2020-02-18 08:40:01 +00:00
(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
2020-02-22 18:21:10 +00:00
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
2020-02-18 08:40:01 +00:00
$ 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
2020-02-24 13:56:13 +00:00
(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)
2020-02-18 08:40:01 +00:00
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
2020-02-22 18:21:10 +00:00
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
2020-02-18 08:40:01 +00:00
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
2020-02-22 18:21:10 +00:00
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
2020-02-18 08:40:01 +00:00
$ 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)
2020-02-22 18:21:10 +00:00
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined
-------------------------
--[ Tool installation ]--
-------------------------
2020-02-24 13:56:13 +00:00
-- TODO: custom logger intepreter and pretty printing
2020-02-22 18:21:10 +00:00
2020-02-24 13:56:13 +00:00
-- | Install a tool, such as GHC or cabal.
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
2020-02-22 18:21:10 +00:00
installTool :: ( MonadThrow m
, MonadReader Settings m
, MonadLogger m
, MonadCatch m
, MonadIO m
)
=> ToolRequest
2020-02-24 13:56:13 +00:00
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
2020-02-22 18:21:10 +00:00
-> URLSource
-> Excepts
2020-02-24 13:56:13 +00:00
'[ AlreadyInstalled
, FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
]
2020-02-22 18:21:10 +00:00
m
()
installTool treq mpfReq urlSource = do
lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
2020-02-24 13:56:13 +00:00
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource
dl <- case cache of
2020-02-22 18:21:10 +00:00
True -> do
cachedir <- liftIO $ ghcupCacheDir
fn <- urlBaseName $ view (dlUri % pathL') dlinfo
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> pure $ cachfile
| otherwise -> liftE $ download' dlinfo cachedir Nothing
False -> do
tmp <- liftIO mkGhcupTmpDir
liftE $ download' dlinfo tmp Nothing
2020-02-24 13:56:13 +00:00
-- unpack
2020-02-22 18:21:10 +00:00
unpacked <- liftE $ unpackToTmpDir dl
2020-02-24 13:56:13 +00:00
-- prepare paths
ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq)
bindir <- liftIO ghcupBinDir
2020-02-22 18:21:10 +00:00
-- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
2020-02-24 13:56:13 +00:00
-- TODO: test if tool is already installed
2020-02-22 18:21:10 +00:00
case treq of
(ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure ()
2020-02-24 13:56:13 +00:00
toolAlreadyInstalled :: ToolRequest -> IO Bool
toolAlreadyInstalled ToolRequest {..} = case _tool of
GHC -> ghcInstalled _toolVersion
Cabal -> cabalInstalled _toolVersion
2020-02-22 18:21:10 +00:00
-- | Install an unpacked GHC distribution.
installGHC :: (MonadLogger m, MonadIO m)
2020-02-24 13:56:13 +00:00
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
2020-02-22 18:21:10 +00:00
-> 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)
2020-02-24 13:56:13 +00:00
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
2020-02-22 18:21:10 +00:00
-> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m ()
installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|])
let cabalFile = [rel|cabal|] :: Path Rel
2020-02-24 13:56:13 +00:00
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> cabalFile)
Overwrite
2020-02-22 18:21:10 +00:00
2020-02-18 08:40:01 +00:00
2020-02-24 13:56:13 +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-<ver>
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
--
-- 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 = E.encodeUtf8 $ prettyVer ver -- as ByteString
ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination
destdir <- liftIO $ ghcupBinDir
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ghcdir
forM verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHCMajor -> do
major <- E.encodeUtf8 <$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major)
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ createSymlink
(destdir </> targetFile)
([s|../ghc/|] <> verBS <> [s|/bin/|] <> toFilePath file)
-- create symlink for share dir
liftIO $ symlinkShareDir ghcdir destdir verBS
pure ()
where
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ghcdir = do
-- fail if ghc is not installed
exists <- liftIO $ doesDirectoryExist ghcdir
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
symlinkShareDir :: Path Abs -> Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir destdir verBS = 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 ()
2020-02-18 08:40:01 +00:00
2020-02-22 18:21:10 +00:00
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
2020-02-24 13:56:13 +00:00
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (E.encodeUtf8 $ prettyVer ver)
pure (ghcbasedir </> verdir)
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
2020-02-22 18:21:10 +00:00
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
2020-02-24 13:56:13 +00:00
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 == (E.encodeUtf8 $ prettyVer ver))
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m Text
getGHCMajor ver = do
semv <- case semver $ prettyVer ver of
Right v -> pure v
Left e -> throwM e
pure $ T.pack (show (_svMajor semv)) <> T.pack "." <> T.pack
(show (_svMinor semv))
2020-02-22 18:21:10 +00:00
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
2020-02-18 08:40:01 +00:00
-- | Unpack an archive to a temporary directory and return that path.
2020-02-22 18:21:10 +00:00
unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs)
2020-02-18 08:40:01 +00:00
unpackToTmpDir av = do
2020-02-22 18:21:10 +00:00
lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
2020-02-24 13:56:13 +00:00
fn <- toFilePath <$> basename av
2020-02-22 18:21:10 +00:00
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
2020-02-18 08:40:01 +00:00
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
2020-02-22 18:21:10 +00:00
parseAbs tmp
2020-02-18 08:40:01 +00:00
-- extract, depending on file extension
if
2020-02-24 13:56:13 +00:00
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
2020-02-22 18:21:10 +00:00
(untar . GZip.decompress =<< readFile av)
2020-02-24 13:56:13 +00:00
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
2020-02-22 18:21:10 +00:00
filecontents <- liftIO $ readFile av
2020-02-18 08:40:01 +00:00
let decompressed = Lzma.decompress filecontents
2020-02-22 18:21:10 +00:00
liftIO $ untar decompressed
2020-02-24 13:56:13 +00:00
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
2020-02-22 18:21:10 +00:00
(untar . BZip.decompress =<< readFile av)
2020-02-24 13:56:13 +00:00
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn