{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- TODO: handle SIGTERM, SIGUSR module GHCup where import qualified Codec.Archive.Tar as Tar import Control.Applicative import Control.Monad import Control.Monad.Reader import Control.Monad.Logger import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class ( lift ) import Control.Monad.IO.Class import Control.Exception.Safe import Data.ByteString ( ByteString ) import Data.Foldable ( asum ) import Data.String.QQ import Data.Text ( Text ) import Data.Versions import GHCup.Bash import GHCup.File import GHCup.Prelude import GHCup.Types import GHCup.Types.Optics import HPath import HPath.IO import Optics import Prelude hiding ( abs , readFile ) import System.Info import System.IO.Error import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.ICU as ICU import Data.Maybe import qualified Data.Map.Strict as Map import Data.Word8 import GHC.IO.Exception import GHC.IO.Handle import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.VEither import Network.Http.Client hiding ( URL ) import System.IO.Streams ( InputStream , OutputStream , stdout ) import qualified System.IO.Streams as Streams import System.Posix.FilePath ( takeExtension , splitExtension ) import qualified System.Posix.FilePath as FP import System.Posix.Env.ByteString ( getEnvDefault ) import System.Posix.Temp.ByteString import "unix" System.Posix.IO.ByteString hiding ( fdWrite ) import System.Posix.FD as FD import System.Posix.Foreign ( oTrunc ) 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 ) 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 import qualified System.Posix.Process.ByteString as SPPB import System.Posix.Directory.ByteString ( changeWorkingDirectory ) import URI.ByteString import URI.ByteString.QQ data Settings = Settings { cache :: Bool } deriving Show --------------------------- --[ Excepts Error types ]-- --------------------------- data PlatformResultError = NoCompatiblePlatform 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 deriving Show data TagNotFound = TagNotFound Tag Tool deriving Show -------------------------------- --[ AvailableDownloads stuff ]-- -------------------------------- -- TODO: version quasiquoter availableDownloads :: AvailableDownloads availableDownloads = Map.fromList [ ( GHC , Map.fromList [ ( [ver|8.6.5|] , VersionInfo [Latest] $ Map.fromList [ ( A_64 , Map.fromList [ ( Linux UnknownLinux , Map.fromList [ ( Nothing , 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)) ) ] ) , ( Linux Debian , Map.fromList [ ( Nothing , 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)) ) , ( 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|] , VersionInfo [Latest] $ Map.fromList [ ( 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 ) ] ) ] ) ] ) ] ) ] -- | 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 '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] m DownloadInfo getDownloadInfo (ToolRequest t v) mpfReq urlSource = do lift $ $(logDebug) ([s|Receiving download info from: |] <> showT 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 <- case urlSource of GHCupURL -> fail "Not implemented" OwnSource url -> fail "Not implemented" OwnSpec dls -> pure dls 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 -- | 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 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. 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 lift $ $(logInfo) ([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli))) 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 -- | Same as 'download', except with a file descriptor. Allows to e.g. -- print to stdout. downloadFd :: Bool -- ^ https? -> ByteString -- ^ host (e.g. "www.example.com") -> ByteString -- ^ path (e.g. "/my/file") -> Maybe Int -- ^ optional port (e.g. 3000) -> 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 -> ByteString -> ByteString -> Maybe Int -> Either Fd (Path Abs, Maybe (Path Rel)) -> IO (Maybe (Path Abs)) downloadInternal https host path port dest = 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 ([s|/|] <> path) 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. getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs) 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 Nothing -> do -- ...otherwise try to infer the filename from the URL path fn' <- urlBaseName path let fp = dest fn' fmap (, fp) $ createRegularFileFd newFilePerms fp -------------------------- --[ 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 lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr) pure pfr where getFreeBSDVersion = pure Nothing getLinuxDistro :: (MonadCatch m, MonadIO m) => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning) getLinuxDistro = do (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 (Just name) <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing pure (E.decodeUtf8 name, fmap 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 -- TODO: subdir to configure script in availableDownloads? ------------------------- --[ Tool installation ]-- ------------------------- installTool :: ( MonadThrow m , MonadReader Settings m , MonadLogger m , MonadCatch m , MonadIO m ) => ToolRequest -> Maybe PlatformRequest -> URLSource -> Excepts '[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] m () installTool treq mpfReq urlSource = do Settings {..} <- lift ask lift $ $(logDebug) ([s|Requested to install: |] <> showT treq) dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource 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 <- liftIO mkGhcupTmpDir liftE $ download' dlinfo tmp Nothing unpacked <- liftE $ unpackToTmpDir dl ghcdir <- liftIO $ do toolsubdir <- ghcupGHCDir versubdir <- parseRel (E.encodeUtf8 . prettyVer . view toolVersion $ treq) pure (toolsubdir versubdir) 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) -> liftE $ installGHC archiveSubdir ghcdir (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir pure () -- | Install an unpacked GHC distribution. installGHC :: (MonadLogger m, MonadIO m) => Path Abs -- ^ Path to the unpacked GHC bindist -> 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 -> Path Abs -- ^ Path to install to -> Excepts '[FileError] m () installCabal path inst = do lift $ $(logInfo) ([s|Installing cabal|]) let cabalFile = [rel|cabal|] :: Path Rel handleIO (\_ -> throwE CopyError) $ liftIO $ copyFile (path cabalFile) (inst cabalFile) Overwrite ----------------- --[ Utilities ]-- ----------------- ghcupBaseDir :: IO (Path Abs) ghcupBaseDir = do home <- liftIO getHomeDirectory pure (home ([rel|.ghcup|] :: Path Rel)) ghcupGHCDir :: IO (Path Abs) ghcupGHCDir = ghcupBaseDir <&> ( ([rel|ghc|] :: Path Rel)) ghcupBinDir :: IO (Path Abs) ghcupBinDir = ghcupBaseDir <&> ( ([rel|bin|] :: Path Rel)) ghcupCacheDir :: IO (Path Abs) ghcupCacheDir = ghcupBaseDir <&> ( ([rel|cache|] :: Path Rel)) 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 :: (MonadLogger m, MonadIO m, MonadThrow m) => Path Abs -- ^ archive path -> Excepts '[ArchiveError] m (Path Abs) unpackToTmpDir av = do lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av)) fn <- basename av let (fnrest, ext) = splitExtension $ toFilePath fn let ext2 = takeExtension fnrest tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) let untar bs = do Tar.unpack tmp . Tar.read $ bs parseAbs tmp -- extract, depending on file extension if | ext == [s|.gz|], ext2 == [s|.tar|] -> liftIO (untar . GZip.decompress =<< readFile av) | ext == [s|.xz|], ext2 == [s|.tar|] -> do filecontents <- liftIO $ readFile av let decompressed = Lzma.decompress filecontents liftIO $ untar decompressed | ext == [s|.bz2|], ext2 == [s|.tar|] -> liftIO (untar . BZip.decompress =<< readFile av) | ext == [s|.tar|] -> liftIO (untar =<< readFile av) | otherwise -> throwE $ UnknownArchive ext