From ac91cbd32b2aac740bb3ab50fbf846158cd7677e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 22 Feb 2020 19:21:10 +0100 Subject: [PATCH] Lol --- app/Main.hs | 149 +++++++++++++++- cabal.project | 5 + ghcup.cabal | 15 +- lib/GHCup.hs | 365 +++++++++++++++++++++++++++----------- lib/GHCup/File.hs | 61 +++++-- lib/GHCup/Prelude.hs | 69 +++++++ lib/GHCup/Types.hs | 21 ++- lib/GHCup/Types/Optics.hs | 4 + 8 files changed, 570 insertions(+), 119 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 60d904e..6e5c067 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where -import qualified MyLib (someFunc) +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.IO.Class +import Data.Bifunctor +import Data.ByteString ( ByteString ) +import Data.Functor ( (<&>) ) +import Data.Maybe +import Data.Semigroup ( (<>) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Traversable +import Data.Versions +import GHCup +import GHCup.File +import GHCup.Prelude +import GHCup.Types +import Haskus.Utils.Variant.Excepts +import HPath +import Options.Applicative +import System.Console.Pretty +import System.Exit + + + +data Options = Options + { optVerbose :: Bool + , optCache :: Bool + , optCommand :: Command + } + +data Command + = InstallGHC InstallGHCOptions + | InstallCabal InstallCabalOptions + +data InstallGHCOptions = InstallGHCOptions + { + ghcVer :: Maybe Version + } + +data InstallCabalOptions = InstallCabalOptions + { + cabalVer :: Maybe Version + } + + +opts :: Parser Options +opts = + Options + <$> switch + (short 'v' <> long "verbose" <> help "Whether to enable verbosity") + <*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads") + <*> com + + +com :: Parser Command +com = subparser + ( command + "install-ghc" + ( InstallGHC + <$> (info (installGHCOpts <**> helper) + (progDesc "Install a GHC version") + ) + ) + <> command + "install-cabal" + ( InstallCabal + <$> (info (installCabalOpts <**> helper) + (progDesc "Install a cabal-install version") + ) + ) + ) + +installGHCOpts :: Parser InstallGHCOptions +installGHCOpts = InstallGHCOptions <$> optional + (option + (eitherReader + (\s -> bimap (const "Not a valid version") id . version . T.pack $ s) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The GHC version to install" + ) + ) + + +installCabalOpts :: Parser InstallCabalOptions +installCabalOpts = InstallCabalOptions <$> optional + (option + (eitherReader + (\s -> bimap (const "Not a valid version") id . version . T.pack $ s) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The Cabal version to install" + ) + ) + + +toSettings :: Options -> Settings +toSettings Options{..} = + let cache = optCache + in Settings{..} + main :: IO () main = do - putStrLn "Hello, Haskell!" - MyLib.someFunc + e <- + customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) + >>= \opt@Options {..} -> do + let settings = toSettings opt + -- wrapper to run effects with settings + let run = flip runReaderT settings . runStderrLoggingT . runE + @'[ FileError + , ArchiveError + , ProcessError + , URLException + , PlatformResultError + , NoDownload + , NoCompatibleArch + , DistroNotFound + , TagNotFound + ] + + case optCommand of + InstallGHC (InstallGHCOptions {..}) -> + run + $ do + d <- liftIO $ ghcupBaseDir + case ghcVer of + Just ver -> liftE $ installTool (ToolRequest GHC ver) + Nothing + (OwnSpec availableDownloads) + Nothing -> do + ver <- + getRecommended availableDownloads GHC + ?? TagNotFound Recommended GHC + liftE $ installTool (ToolRequest GHC ver) Nothing (OwnSpec availableDownloads) + InstallCabal (InstallCabalOptions {..}) -> undefined + + pure () + + + -- print error, if any + -- case e of + -- Right () -> pure () + -- Left t -> die (color Red $ t) diff --git a/cabal.project b/cabal.project index debba56..621237e 100644 --- a/cabal.project +++ b/cabal.project @@ -14,3 +14,8 @@ source-repository-package type: git location: https://github.com/composewell/streamly tag: 4eb53e7f868bdc08afcc4b5210ab5916b9a4dfbc + +source-repository-package + type: git + location: https://github.com/hasufell/tar-bytestring + tag: 64707be1abb534e88007e3320090598a0a9490a7 diff --git a/ghcup.cabal b/ghcup.cabal index cead7f5..2aecf3b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -38,10 +38,13 @@ common http-io-streams { build-depends: http-io-streams >= 0.1 } common io-streams { build-depends: io-streams >= 1.5 } common language-bash { build-depends: language-bash >= 0.9 } common lzma { build-depends: lzma >= 0.0.0.3 } +common monad-logger { build-depends: monad-logger >= 0.3.31 } common mtl { build-depends: mtl >= 2.2 } common optics { build-depends: optics >= 0.2 } common optics-vl { build-depends: optics-vl >= 0.2 } +common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 } common parsec { build-depends: parsec >= 3.1 } +common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common streamly { build-depends: streamly >= 0.7 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } @@ -65,7 +68,7 @@ common zlib { build-depends: zlib >= 0.6.2.1 } common config default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded default-extensions: LambdaCase , MultiWayIf , PackageImports @@ -96,6 +99,7 @@ library , io-streams , language-bash , lzma + , monad-logger , mtl , optics , optics-vl @@ -132,6 +136,15 @@ library executable ghcup import: config , base + , bytestring + , haskus-utils-variant + , monad-logger + , mtl + , optparse-applicative + , text + , versions + , hpath + , pretty-terminal main-is: Main.hs -- other-modules: -- other-extensions: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index b14b046..418551c 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -14,7 +14,10 @@ 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 ) @@ -83,6 +86,12 @@ import URI.ByteString.QQ +data Settings = Settings { + cache :: Bool +} deriving Show + + + --------------------------- --[ Excepts Error types ]-- @@ -107,11 +116,18 @@ data ArchiveError = UnknownArchive ByteString data URLException = UnsupportedURL deriving Show +data FileError = CopyError + deriving Show + +data TagNotFound = TagNotFound Tag Tool + deriving Show - ---------------------- - --[ Download stuff ]-- - ---------------------- + + + -------------------------------- + --[ AvailableDownloads stuff ]-- + -------------------------------- -- TODO: version quasiquoter @@ -119,24 +135,60 @@ availableDownloads :: AvailableDownloads availableDownloads = Map.fromList [ ( GHC , Map.fromList - [ ( (\(Right x) -> x) $ version [s|8.6.5|] - , Map.fromList + [ ( [ver|8.6.5|] + , VersionInfo [Latest] $ Map.fromList [ ( A_64 , Map.fromList [ ( Linux UnknownLinux , Map.fromList [ ( Nothing - , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|] + , 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 - , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|] + , 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 $ (\(Right x) -> x) $ versioning [s|8|] - , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|] + , ( 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 ) ] ) @@ -150,15 +202,40 @@ availableDownloads = Map.fromList -getDownloadURL :: (MonadCatch m, MonadIO m) - => ToolRequest - -> Maybe PlatformRequest - -> URLSource - -> Excepts - '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] - m - URI -getDownloadURL (ToolRequest t v) mpfReq urlSource = do +-- | 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 @@ -171,21 +248,21 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do OwnSource url -> fail "Not implemented" OwnSpec dls -> pure dls - lE $ getDownloadURL' t v arch plat ver dls + lE $ getDownloadInfo' t v arch plat ver dls -getDownloadURL' :: Tool - -> Version - -- ^ tool version - -> Architecture - -- ^ user arch - -> Platform - -- ^ user platform - -> Maybe Versioning - -- ^ optional version of the platform - -> AvailableDownloads - -> Either NoDownload URI -getDownloadURL' t v a p mv dls = maybe +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) @@ -196,8 +273,7 @@ getDownloadURL' t v a p mv dls = maybe without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) distro_preview f g = - preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls - atJust x = at x % _Just + 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 @@ -221,25 +297,27 @@ download https host path port dest mfn = do -- throw an exception if the url type or host protocol is not supported. -- -- Only Absolute HTTP/HTTPS is supported. -download' :: MonadIO m - => URI +download' :: (MonadLogger m, MonadIO m) + => DownloadInfo -> Path Abs -- ^ destination dir -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[URLException] m (Path Abs) -download' url dest mfn - | view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True - | view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False +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 (authorityL' % _Just % authorityHostL' % hostBSL') url + preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli ?? UnsupportedURL - let path = view pathL' url + let path = view (dlUri % pathL') dli let port = preview - (authorityL' % _Just % authorityPortL' % _Just % portNumberL') - url + (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. @@ -308,8 +386,7 @@ downloadInternal https host path port dest = do in fmap (, fp) $ createRegularFileFd newFilePerms fp Nothing -> do -- ...otherwise try to infer the filename from the URL path - let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path - fn' <- parseRel urlBaseName + fn' <- urlBaseName path let fp = dest fn' fmap (, fp) $ createRegularFileFd newFilePerms fp @@ -328,22 +405,25 @@ getArchitecture = case arch of -getPlatform :: (MonadCatch m, MonadIO m) +getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[PlatformResultError, DistroNotFound] m PlatformResult -getPlatform = 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 +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 @@ -374,7 +454,7 @@ getLinuxDistro = do hasWord t matches = foldr (\x y -> ( isJust - . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|])) + . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|])) $ t ) || y @@ -421,14 +501,13 @@ getLinuxDistro = do join . fmap (ICU.group 0) . ICU.find - (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|]) - ) + (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|]) + (ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|]) $ t (Just name) <- pure (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat") @@ -440,58 +519,142 @@ getLinuxDistro = do pure (T.pack "debian", Just $ lBS2sT ver) +-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads +-- parseAvailableDownloads = undefined - ------------------------ - --[ GHC installation ]-- - ------------------------ +-- TODO: subdir to configure script in availableDownloads? --- TODO: quasiquote for ascii bytestrings + ------------------------- + --[ Tool installation ]-- + ------------------------- --- | Unpack an archive to a temporary directory and return that path. -unpackToTmpDir :: Path Abs -- ^ archive path - -> IO (Either ArchiveError (Path Abs)) -unpackToTmpDir av = do - fn <- basename av - let (fnrest, ext) = splitExtension $ toFilePath fn - let ext2 = takeExtension fnrest - tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|] - tmp <- mkdtemp $ (tmpdir FP. [s|ghcup-|]) - let untar bs = do - Tar.unpack tmp . Tar.read $ bs - Right <$> parseAbs tmp +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 - -- extract, depending on file extension - if - | ext == [s|.gz|] && ext2 == [s|.tar|] - -> untar . GZip.decompress =<< readFile av - | ext == [s|.xz|] && ext2 == [s|.tar|] - -> do - filecontents <- readFile av - let decompressed = Lzma.decompress filecontents - -- putStrLn $ show decompressed - untar decompressed - | ext == [s|.bz2|] && ext2 == [s|.tar|] - -> untar . BZip.decompress =<< readFile av - | ext == [s|.tar|] - -> untar =<< readFile av - | otherwise - -> pure $ Left $ UnknownArchive ext + -- the subdir of the archive where we do the work + let archiveSubdir = maybe unpacked (unpacked ) (view dlSubdir dlinfo) - where - isTar ext | ext == [s|.tar|] = pure () - | otherwise = throwE $ UnknownArchive ext + case treq of + (ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir + (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir + pure () -- | Install an unpacked GHC distribution. -installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist +installGHC :: (MonadLogger m, MonadIO m) + => Path Abs -- ^ Path to the unpacked GHC bindist -> Path Abs -- ^ Path to install to - -> IO () + -> Excepts '[ProcessError] m () installGHC path inst = do - exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path) - exec [s|make|] [[s|install|]] True (Just path) + 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 () --- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads --- parseAvailableDownloads = undefined + +-- | 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 diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 5edd922..6792bdb 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module GHCup.File where @@ -6,6 +7,7 @@ import Data.ByteString import qualified Data.ByteString.Lazy as L import Data.Char import Data.Maybe +import Data.String.QQ import HPath import HPath.IO import Optics @@ -19,14 +21,18 @@ import Control.Exception.Safe import Data.Functor import System.Posix.Files.ByteString import System.Posix.Foreign ( oExcl ) +import System.Posix.Env.ByteString import System.IO +import qualified System.Posix.FilePath as FP import "unix" System.Posix.IO.ByteString hiding ( openFd ) import qualified System.Posix.Process.ByteString as SPPB import System.Posix.Directory.ByteString import System.Posix.Process ( ProcessStatus(..) ) +import System.Posix.Temp.ByteString import System.Posix.Types +import qualified System.Posix.User as PU import qualified Streamly.Internal.Memory.ArrayStream as AS @@ -41,12 +47,17 @@ import GHCup.Prelude import Control.Concurrent.Async import Control.Concurrent import System.Posix.FD as FD +import qualified Data.ByteString.UTF8 as UTF8 +import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) +import GHC.IO.Encoding ( getLocaleEncoding ) +import GHC.Foreign ( peekCStringLen ) -data ProcessError = NonZeroExit Int - | PTerminated - | PStopped - | NoSuchPid + +data ProcessError = NonZeroExit Int ByteString [ByteString] + | PTerminated ByteString [ByteString] + | PStopped ByteString [ByteString] + | NoSuchPid ByteString [ByteString] deriving Show @@ -169,13 +180,41 @@ exec exe args spath chdir = do maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir SPPB.executeFile exe spath args Nothing - fmap toProcessError $ SPPB.getProcessStatus True True pid + fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid -toProcessError :: Maybe ProcessStatus -> Either ProcessError () -toProcessError mps = case mps of - Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i +toProcessError :: ByteString + -> [ByteString] + -> Maybe ProcessStatus + -> Either ProcessError () +toProcessError exe args mps = case mps of + Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args Just (SPPB.Exited ExitSuccess ) -> Right () - Just (Terminated _ _ ) -> Left $ PTerminated - Just (Stopped _ ) -> Left $ PStopped - Nothing -> Left $ NoSuchPid + Just (Terminated _ _ ) -> Left $ PTerminated exe args + Just (Stopped _ ) -> Left $ PStopped exe args + Nothing -> Left $ NoSuchPid exe args + + +mkGhcupTmpDir :: IO (Path Abs) +mkGhcupTmpDir = do + tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|] + tmp <- mkdtemp $ (tmpdir FP. [s|ghcup-|]) + parseAbs tmp + + +getHomeDirectory :: IO (Path Abs) +getHomeDirectory = do + e <- getEnv [s|HOME|] + case e of + Just fp -> parseAbs fp + Nothing -> do + h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID) + parseAbs $ UTF8.fromString h -- this is a guess + + +-- | Convert the String to a ByteString with the current +-- system encoding. +unsafePathToString :: Path b -> IO FilePath +unsafePathToString (Path p) = do + enc <- getLocaleEncoding + unsafeUseAsCStringLen p (peekCStringLen enc) diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index a96048b..bc80a92 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -3,6 +3,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} module GHCup.Prelude where @@ -10,15 +13,23 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans.Class ( lift ) import Control.Exception.Safe +import Data.ByteString (ByteString) import qualified Data.Strict.Maybe as S import Data.Monoid ( (<>) ) import Data.String import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy as TL import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Versions import qualified Data.ByteString.Lazy as L import Haskus.Utils.Variant.Excepts import System.IO.Error +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Exp(..), Lift) +import qualified Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import GHC.Base @@ -44,6 +55,9 @@ iE :: String -> IO a iE = internalError +showT :: Show a => a -> Text +showT = fS . show + -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () whenM ~b ~t = ifM b t (return ()) @@ -99,3 +113,58 @@ lEM em = lift em >>= lE fromEither :: Either a b -> VEither '[a] b fromEither = either (VLeft . V) VRight + + + +deriving instance Lift Versioning +deriving instance Lift Version +deriving instance Lift SemVer +deriving instance Lift Mess +deriving instance Lift PVP +deriving instance Lift (NonEmpty Word) +deriving instance Lift VSep +deriving instance Lift VUnit +instance Lift Text + +qq :: (Text -> Q Exp) -> QuasiQuoter +qq quoteExp' = + QuasiQuoter + { quoteExp = (\s -> quoteExp' . T.pack $ s) + , quotePat = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + } + +ver :: QuasiQuoter +ver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . version + +mver :: QuasiQuoter +mver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . mess + +sver :: QuasiQuoter +sver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . semver + +vers :: QuasiQuoter +vers = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . versioning + +pver :: QuasiQuoter +pver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . pvp + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 95e9a6c..accd550 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -2,15 +2,29 @@ module GHCup.Types where +import HPath import Data.Map.Strict ( Map ) import qualified GHC.Generics as GHC import Data.Versions import URI.ByteString +data Tag = Latest + | Recommended + deriving (Eq, Show) + +data VersionInfo = VersionInfo { + _viTags :: [Tag] + , _viArch :: ArchitectureSpec +} deriving (Eq, Show) + +data DownloadInfo = DownloadInfo { + _dlUri :: URI + , _dlSubdir :: Maybe (Path Rel) +} deriving (Eq, Show) + data Tool = GHC | Cabal - | Stack deriving (Eq, GHC.Generic, Ord, Show) data ToolRequest = ToolRequest { @@ -55,13 +69,14 @@ data PlatformRequest = PlatformRequest { , _rVersion :: Maybe Versioning } deriving (Eq, Show) -type PlatformVersionSpec = Map (Maybe Versioning) URI +type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo type PlatformSpec = Map Platform PlatformVersionSpec type ArchitectureSpec = Map Architecture PlatformSpec -type ToolVersionSpec = Map Version ArchitectureSpec +type ToolVersionSpec = Map Version VersionInfo type AvailableDownloads = Map Tool ToolVersionSpec data URLSource = GHCupURL | OwnSource URI | OwnSpec AvailableDownloads + deriving Show diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index 2d2b832..016612f 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -11,9 +11,13 @@ makePrisms ''Tool makePrisms ''Architecture makePrisms ''LinuxDistro makePrisms ''Platform +makePrisms ''Tag makeLenses ''PlatformResult makeLenses ''ToolRequest +makeLenses ''DownloadInfo +makeLenses ''Tag +makeLenses ''VersionInfo uriSchemeL' :: Lens' (URIRef Absolute) Scheme