This commit is contained in:
Julian Ospald 2020-02-18 09:40:01 +01:00
parent e4754f4e4e
commit d4ed158acb
7 changed files with 314 additions and 214 deletions

View File

@ -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

View File

@ -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,

View File

@ -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

View File

@ -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
@ -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

View File

@ -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
@ -91,9 +90,12 @@ findExecutable ex = do
-- The command is run in a subprocess.
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

View File

@ -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

View File

@ -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