From d4ed158acbe4977e3970a501001b34fca72464b4 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 18 Feb 2020 09:40:01 +0100 Subject: [PATCH] Stuff --- cabal.project | 8 +- cabal.project.freeze | 24 ++- ghcup.cabal | 16 +- lib/GHCup.hs | 372 ++++++++++++++++++++++++------------- lib/GHCup/File.hs | 26 +-- lib/GHCup/Prelude.hs | 25 +++ lib/Streamly/ByteString.hs | 57 ------ 7 files changed, 314 insertions(+), 214 deletions(-) delete mode 100644 lib/Streamly/ByteString.hs diff --git a/cabal.project b/cabal.project index c8ce2d9..74db8d3 100644 --- a/cabal.project +++ b/cabal.project @@ -12,10 +12,10 @@ package ghcup source-repository-package type: git - location: https://github.com/composewell/streamly - tag: b8178cd08f7fc8180e4de83bde4b239cb0cfb31c + location: https://github.com/hasufell/streamly + tag: a343c4b99b20ea6f8207a220d5dccb3a88cecefa source-repository-package type: git - location: https://github.com/hasufell/tar-bytestring - tag: c774ebdbc75d514648c8d4993abd188103182513 + location: https://github.com/psibi/streamly-bytestring + tag: fed14ce44e0219f68162f450b5c107fea20a6521 diff --git a/cabal.project.freeze b/cabal.project.freeze index 6a8e7a2..12188fe 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -33,6 +33,7 @@ constraints: any.Cabal ==2.4.0.1, any.bytestring ==0.10.8.2, any.bytestring-builder ==0.10.8.2.0, bytestring-builder +bytestring_has_builder, + any.bzlib ==0.5.0.5, any.cabal-doctest ==1.0.8, any.call-stack ==0.2.0, any.case-insensitive ==1.2.1.0, @@ -58,19 +59,25 @@ constraints: any.Cabal ==2.4.0.1, any.filepath ==1.4.2.1, any.focus ==1.0.1.3, any.foldl ==1.4.6, + any.fusion-plugin ==0.1.1, any.gauge ==0.2.5, gauge +analysis, any.generics-sop ==0.5.0.0, + any.ghc ==8.6.5, + any.ghc-boot ==8.6.5, any.ghc-boot-th ==8.6.5, + any.ghc-heap ==8.6.5, any.ghc-prim ==0.5.3, + any.ghci ==8.6.5, any.hashable ==1.3.0.0, hashable -examples +integer-gmp +sse2 -sse41, any.heaps ==0.3.6.1, any.hpath ==0.11.0, - any.hpath-directory ==0.13.1, + any.hpath-directory ==0.13.2, any.hpath-filepath ==0.10.4, any.hpath-io ==0.13.1, any.hpath-posix ==0.13.1, + any.hpc ==0.6.0.3, any.hsc2hs ==0.68.6, hsc2hs -in-ghc-tree, any.hspec ==2.7.1, @@ -87,6 +94,7 @@ constraints: any.Cabal ==2.4.0.1, any.language-bash ==0.9.0, any.list-t ==1.0.4, any.lockfree-queue ==0.2.3.1, + any.lzma ==0.0.0.3, any.math-functions ==0.3.3.0, math-functions +system-erf +system-expm1, any.megaparsec ==8.0.0, @@ -95,7 +103,7 @@ constraints: any.Cabal ==2.4.0.1, any.monad-control ==1.0.2.3, any.mtl ==2.2.2, any.mwc-random ==0.14.0.0, - any.network ==2.8.0.1, + any.network ==3.0.1.1, any.network-uri ==2.6.2.0, any.openssl-streams ==1.2.2.0, any.optics ==0.2, @@ -106,13 +114,13 @@ constraints: any.Cabal ==2.4.0.1, any.parser-combinators ==1.2.1, parser-combinators -dev, any.pretty ==1.1.3.6, - any.prettyprinter ==1.6.0, + any.prettyprinter ==1.6.1, prettyprinter -buildreadme, any.primitive ==0.7.0.0, any.primitive-extras ==0.8, any.primitive-unlifted ==0.1.3.0, any.process ==1.6.5.0, - any.profunctors ==5.5.1, + any.profunctors ==5.5.2, any.quickcheck-io ==0.2.0, any.random ==1.1, any.rts ==1.0, @@ -128,13 +136,15 @@ constraints: any.Cabal ==2.4.0.1, any.splitmix ==0.0.3, splitmix -optimised-mixer +random, any.stm ==2.5.0.0, - streamly -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk, - any.streamly-bytestring ==0.1.0.1, + streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk, + any.streamly-bytestring ==0.1.2, any.strict-base ==0.4.0.0, + any.syb ==0.7.1, any.tagged ==0.8.6, tagged +deepseq +transformers, - any.tar-bytestring ==0.6.1.2, + any.tar-bytestring ==0.6.1.3, any.template-haskell ==2.14.0.0, + any.terminfo ==0.4.1.2, any.text ==1.2.3.1, any.text-icu ==0.7.0.1, any.text-short ==0.1.3, diff --git a/ghcup.cabal b/ghcup.cabal index 068a3e9..320d96c 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -26,8 +26,10 @@ common ascii-string { build-depends: ascii-string >= 1.0 } common async { build-depends: async >= 0.8 } common base { build-depends: base >= 4.12 && < 5 } common bytestring { build-depends: bytestring >= 0.10 } +common bzlib { build-depends: bzlib >= 0.5.0.5 } common containers { build-depends: containers >= 0.6 } common generics-sop { build-depends: generics-sop >= 0.5 } +common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } common hpath { build-depends: hpath >= 0.11 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-io { build-depends: hpath-io >= 0.13.1 } @@ -35,13 +37,15 @@ common hpath-posix { build-depends: hpath-posix >= 0.11.1 } 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 mtl { build-depends: mtl >= 2.2 } common optics { build-depends: optics >= 0.2 } common parsec { build-depends: parsec >= 3.1 } 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 } common strict-base { build-depends: strict-base >= 0.4 } -common tar-bytestring { build-depends: tar-bytestring >= 0.6.1 } +common tar-bytestring { build-depends: tar-bytestring >= 0.6.1.3 } common template-haskell { build-depends: template-haskell >= 2.7 } common text { build-depends: text >= 1.2 } common text-icu { build-depends: text-icu >= 0.7 } @@ -53,11 +57,12 @@ common utf8-string { build-depends: utf8-string >= 1.0 } common vector { build-depends: vector >= 0.12 } common versions { build-depends: versions >= 3.5 } common waargonaut { build-depends: waargonaut >= 0.8 } +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 -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates default-extensions: LambdaCase , MultiWayIf , PackageImports @@ -76,8 +81,10 @@ library , ascii-string , async , bytestring + , bzlib , containers , generics-sop + , haskus-utils-variant , hpath , hpath-filepath , hpath-io @@ -85,11 +92,13 @@ library , http-io-streams , io-streams , language-bash + , lzma , mtl , optics , parsec , safe-exceptions , streamly + , streamly-bytestring , strict-base , tar-bytestring , template-haskell @@ -102,6 +111,7 @@ library , utf8-string , vector , versions + , zlib exposed-modules: GHCup GHCup.Bash GHCup.File @@ -109,7 +119,7 @@ library GHCup.Types GHCup.Types.JSON GHCup.Types.Optics - other-modules: Streamly.ByteString + -- other-modules: -- other-extensions: hs-source-dirs: lib diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4979790..bdda943 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -11,11 +11,13 @@ module GHCup where +import qualified Codec.Archive.Tar as Tar import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import Control.Exception.Safe +import Data.ByteString ( ByteString ) import Data.Foldable ( asum ) import Data.Text ( Text ) import Data.Versions @@ -39,12 +41,19 @@ import Data.Maybe import qualified Data.Map.Strict as Map 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 ) @@ -58,6 +67,40 @@ 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 + + + + --------------------------- + --[ 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 + + + + ---------------------- + --[ Download stuff ]-- + ---------------------- + availableDownloads :: AvailableDownloads @@ -103,16 +146,20 @@ availableDownloads = Map.fromList } -getDownloadURL :: ToolRequest +getDownloadURL :: (MonadCatch m, MonadIO m) + => ToolRequest -> Maybe PlatformRequest -> URLSource - -> IO (Maybe URL) -- TODO: better error handling + -> Excepts + '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] + m + URL getDownloadURL (ToolRequest t v) mpfReq urlSource = do (PlatformRequest arch plat ver) <- case mpfReq of Just x -> pure x Nothing -> do - (PlatformResult rp rv) <- getPlatform - let ar = (\(Right x) -> x) getArchitecture + (PlatformResult rp rv) <- liftE getPlatform + ar <- lE getArchitecture pure $ PlatformRequest ar rp rv dls <- case urlSource of @@ -120,7 +167,7 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do OwnSource url -> fail "Not implemented" OwnSpec dls -> pure dls - pure $ getDownloadURL' t v arch plat ver dls + lE $ getDownloadURL' t v arch plat ver dls getDownloadURL' :: Tool @@ -133,136 +180,22 @@ getDownloadURL' :: Tool -> Maybe Versioning -- ^ optional version of the platform -> AvailableDownloads - -> Maybe URL -getDownloadURL' t v a p mv dls = - with_distro <|> without_distro_ver <|> without_distro + -> Either NoDownload URL +getDownloadURL' 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 = distro_preview (set _Linux UnknownLinux) id without_distro_ver = distro_preview id (const Nothing) + 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 -getArchitecture :: Either String Architecture -getArchitecture = case arch of - "x86_64" -> pure A_64 - "i386" -> pure A_32 - what -> Left ("Could not find compatible architecture. Was: " <> what) - - - -getPlatform :: IO PlatformResult -getPlatform = case os of - "linux" -> do - (distro, ver) <- 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 -> fail ("Could not find compatible platform. Was: " <> what) - where getFreeBSDVersion = pure Nothing - - -getLinuxDistro :: IO (LinuxDistro, Maybe Versioning) -getLinuxDistro = do - (name, ver) <- 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 - recreateSymlink undefined undefined Overwrite - pure (distro, parsedVer) - where - hasWord t matches = foldr - (\x y -> - ( isJust - . ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\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 [fS "-si"] - ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [fS "-sr"] - pure (lBS2sT name, fmap lBS2sT 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] (fS "\\b" <> fS n <> fS "\\b") - ) - $ t - verRe = - join - . fmap (ICU.group 0) - . ICU.find - (ICU.regex [ICU.CaseInsensitive] (fS "\\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 - True <- doesFileExist debian_version - ver <- readFile debian_version - pure (T.pack "debian", Just $ lBS2sT ver) - - -- | 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: @@ -284,7 +217,10 @@ 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' :: URL -> Path Abs -> Maybe (Path Rel) -> IO (Path Abs) +download' :: URL + -> Path Abs -- ^ destination dir + -> Maybe (Path Rel) -- ^ optional filename + -> IO (Path Abs) download' url dest mfn = case url of URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] } -> download https host path port dest mfn @@ -293,7 +229,7 @@ download' url dest mfn = case url of -- | Same as 'download', except with a file descriptor. Allows to e.g. -- print to stdout. -downloadFd :: Bool -- ^ https? +downloadFd :: Bool -- ^ https? -> String -- ^ host (e.g. "www.example.com") -> String -- ^ path (e.g. "/my/file") -> Maybe Integer -- ^ optional port (e.g. 3000) @@ -372,11 +308,185 @@ downloadInternal https host path port dest = do --- unpack :: Path Abs -> IO (Path Abs) --- unpack = undefined + -------------------------- + --[ Platform detection ]-- + -------------------------- --- install :: DownloadURL -> IO (Path Abs) --- install = undefined + +getArchitecture :: Either NoCompatibleArch Architecture +getArchitecture = case arch of + "x86_64" -> Right A_64 + "i386" -> Right A_32 + what -> Left (NoCompatibleArch what) + + + +getPlatform :: (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 + 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] (fS "\\b" <> x <> fS "\\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 [fS "-si"] Nothing + ver <- (fmap . fmap) _stdOut + $ executeOut lsb_release_cmd [fS "-sr"] Nothing + pure (lBS2sT name, fmap lBS2sT 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] (fS "\\b" <> fS n <> fS "\\b") + ) + $ t + verRe = + join + . fmap (ICU.group 0) + . ICU.find + (ICU.regex [ICU.CaseInsensitive] (fS "\\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) + + + + ------------------------ + --[ GHC installation ]-- + ------------------------ + + +-- TODO: quasiquote for ascii bytestrings + + +-- | 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 (fS "TMPDIR") (fS "/tmp") + tmp <- mkdtemp $ (tmpdir FP. fS "ghcup-") + let untar bs = do + Tar.unpack tmp . Tar.read $ bs + Right <$> parseAbs tmp + + -- extract, depending on file extension + if + | ext == fS ".gz" && ext2 == fS ".tar" + -> untar . GZip.decompress =<< readFile av + | ext == fS ".xz" && ext2 == fS ".tar" + -> do + filecontents <- readFile av + let decompressed = Lzma.decompress filecontents + -- putStrLn $ show decompressed + untar decompressed + | ext == fS ".bz2" && ext2 == fS ".tar" + -> untar . BZip.decompress =<< readFile av + | ext == fS ".tar" && ext2 == fS ".tar" + -> untar =<< readFile av + | otherwise + -> pure $ Left $ UnknownArchive ext + + where + isTar ext | ext == fS ".tar" = pure () + | otherwise = throwE $ UnknownArchive ext + + +-- | Install an unpacked GHC distribution. +installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist + -> Path Abs -- ^ Path to install to + -> IO () +installGHC path inst = do + let c = [rel|./configure|] :: Path Rel + executeOut c [fS "--prefix=" <> toFilePath inst] (Just path) + let m = [rel|make|] :: Path Rel + executeOut m [fS "install"] (Just path) + pure () -- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads -- parseAvailableDownloads = undefined diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index c6dd418..62ee1b3 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -9,7 +9,8 @@ import Data.Maybe import HPath import HPath.IO import Optics -import Streamly.ByteString +import Streamly.External.ByteString +import Streamly.External.ByteString.Lazy import Streamly import System.Posix.FilePath hiding ( () ) import Data.Foldable @@ -23,6 +24,7 @@ import "unix" System.Posix.IO.ByteString hiding ( openFd ) import qualified System.Posix.Process.ByteString as SPPB +import System.Posix.Directory.ByteString import System.Posix.Types import qualified Streamly.Internal.Memory.ArrayStream @@ -52,10 +54,7 @@ makeLenses ''CapturedProcess readFd :: Fd -> IO L.ByteString readFd fd = do handle' <- fdToHandle fd - let stream = - (S.unfold (SU.finallyIO hClose FH.readChunks) handle') - >>= arrayToByteString - toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream) + fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle') -- | Read the lines of a file into a stream. The stream holds @@ -65,9 +64,9 @@ readFileLines :: Path b -> IO (SerialT IO ByteString) readFileLines p = do stream <- readFileStream p pure - . (>>= arrayToByteString) + . (fmap fromArray) . AS.splitOn (fromIntegral $ ord '\n') - . (>>= byteStringToArray) + . (fmap toArray) $ stream @@ -89,11 +88,14 @@ findExecutable ex = do -- | Execute the given command and collect the stdout, stderr and the exit code. -- The command is run in a subprocess. -executeOut :: Path Rel -- ^ command as filename, e.g. 'ls' - -> [ByteString] -- ^ arguments to the command +executeOut :: Path Rel -- ^ command as filename, e.g. 'ls' + -> [ByteString] -- ^ arguments to the command + -> Maybe (Path Abs) -- ^ chdir to this path -> IO (Maybe CapturedProcess) -executeOut path args = withRelPath path - $ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing +executeOut path args chdir = withRelPath path + $ \fp -> captureOutStreams $ do + maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir + SPPB.executeFile fp True args Nothing -- | Capture the stdout and stderr of the given action, which @@ -101,7 +103,7 @@ executeOut path args = withRelPath path -- 'race' this to make sure it terminates. captureOutStreams :: IO a -- ^ the action to execute in a subprocess - -> IO (Maybe CapturedProcess) + -> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe captureOutStreams action = actionWithPipes $ \(parentStdoutRead, childStdoutWrite) -> actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index 6d24915..a96048b 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -1,11 +1,14 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} module GHCup.Prelude where import Control.Applicative import Control.Monad +import Control.Monad.Trans.Class ( lift ) import Control.Exception.Safe import qualified Data.Strict.Maybe as S import Data.Monoid ( (<>) ) @@ -14,6 +17,7 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy as TL import Data.Text ( Text ) import qualified Data.ByteString.Lazy as L +import Haskus.Utils.Variant.Excepts import System.IO.Error @@ -74,3 +78,24 @@ handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO () handleIO' err handler = handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) + +(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a +(??) m e = maybe (throwE e) pure m + + +(!?) :: forall e es a m + . (Monad m, e :< es) + => m (Maybe a) + -> e + -> Excepts es m a +(!?) em e = lift em >>= (?? e) + + +lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a +lE = liftE . veitherToExcepts . fromEither + +lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a +lEM em = lift em >>= lE + +fromEither :: Either a b -> VEither '[a] b +fromEither = either (VLeft . V) VRight diff --git a/lib/Streamly/ByteString.hs b/lib/Streamly/ByteString.hs deleted file mode 100644 index 2cee0a1..0000000 --- a/lib/Streamly/ByteString.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Streamly.ByteString where - -import Control.Monad.IO.Class -import Data.ByteString hiding (length) -import qualified Data.ByteString as BS -import Data.ByteString.Unsafe -import Data.Word (Word8) -import Foreign.ForeignPtr -import Foreign.ForeignPtr.Unsafe -import Foreign.Ptr (castPtr, minusPtr, plusPtr) -import Prelude hiding (length) -import Streamly -import Streamly.Internal.Memory.Array.Types -import Streamly.Memory.Array -import qualified Streamly.Prelude as S - -toByteString :: - forall m. (MonadIO m, MonadAsync m) - => SerialT m (Array Word8) - -> m ByteString -toByteString stream = - let xs = S.mapM arrayToByteString stream - ys = S.foldlM' (\a b -> pure $ a <> b) mempty xs - in ys - -arrayToByteString :: (MonadIO m) => Array Word8 -> m ByteString -arrayToByteString arr - | length arr == 0 = return mempty -arrayToByteString Array {..} = - liftIO $ - withForeignPtr aStart $ \ptr -> - unsafePackCStringFinalizer ptr aLen (return ()) - where - aLen = - let p = unsafeForeignPtrToPtr aStart - in aEnd `minusPtr` p - -byteStringToArray :: (MonadIO m) => ByteString -> m (Array Word8) -byteStringToArray bs = - liftIO $ - unsafeUseAsCStringLen - bs - (\(ptr, _) -> do - let endPtr pr = (castPtr pr `plusPtr` (BS.length bs)) - fptr <- newForeignPtr_ (castPtr ptr) - return $ Array {aStart = fptr, aEnd = endPtr ptr, aBound = endPtr ptr}) - -fromByteString :: - forall m. (MonadIO m) - => ByteString - -> m (Array Word8) -fromByteString bs = byteStringToArray bs