From 3fb5c612c1a8d19450cf38365c681babd1457f4d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 14 Jan 2020 22:55:34 +0100 Subject: [PATCH] First take --- ghcup.cabal | 86 ++++++++++++++++--- lib/GHCup.hs | 169 +++++++++++++++++++++++++++++++++++++ lib/GHCup/Bash.hs | 79 +++++++++++++++++ lib/GHCup/File.hs | 133 +++++++++++++++++++++++++++++ lib/GHCup/Prelude.hs | 66 +++++++++++++++ lib/GHCup/Types.hs | 51 +++++++++++ lib/GHCup/Types/Foo.hs | 18 ++++ lib/GHCup/Types/JSON.hs | 40 +++++++++ lib/GHCup/Types/Optics.hs | 5 ++ lib/MyLib.hs | 4 - lib/Streamly/ByteString.hs | 57 +++++++++++++ 11 files changed, 692 insertions(+), 16 deletions(-) create mode 100644 lib/GHCup.hs create mode 100644 lib/GHCup/Bash.hs create mode 100644 lib/GHCup/File.hs create mode 100644 lib/GHCup/Prelude.hs create mode 100644 lib/GHCup/Types.hs create mode 100644 lib/GHCup/Types/Foo.hs create mode 100644 lib/GHCup/Types/JSON.hs create mode 100644 lib/GHCup/Types/Optics.hs delete mode 100644 lib/MyLib.hs create mode 100644 lib/Streamly/ByteString.hs diff --git a/ghcup.cabal b/ghcup.cabal index 957380b..878cea7 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,35 +1,97 @@ -cabal-version: 2.0 --- Initial package description 'ghcup.cabal' generated by 'cabal init'. --- For further documentation, see http://haskell.org/cabal/users-guide/ +cabal-version: 2.2 name: ghcup version: 0.1.0.0 synopsis: ghc toolchain installer as an exe/library --- description: +description: A rewrite of the shell script ghcup, for providing + a more stable user experience and exposing an API. homepage: https://github.com/hasufell/ghcup-hs --- bug-reports: -license: LGPL-3 +bug-reports: https://github.com/hasufell/ghcup-hs/issues +license: LGPL-3.0-only license-file: LICENSE author: Julian Ospald maintainer: hasufell@posteo.de --- copyright: +copyright: Julian Ospald 2020 category: System build-type: Simple extra-source-files: CHANGELOG.md +source-repository head + type: git + location: https://github.com/hasufell/ghcup-hs + +common ascii-string { build-depends: ascii-string >= 1.0 } +common base { build-depends: base >= 4.12.0.0 && < 5 } +common bytestring { build-depends: bytestring >= 0.10 } +common containers { build-depends: containers >= 0.6 } +common generics-sop { build-depends: generics-sop >= 0.5 } +common hpath { build-depends: hpath >= 0.10.1 } +common hpath-filepath { build-depends: hpath-filepath >= 0.10 } +common hpath-io { build-depends: hpath-io >= 0.10.1 } +common language-bash { build-depends: language-bash >= 0.9 } +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 strict-base { build-depends: strict-base >= 0.4 } +common template-haskell { build-depends: template-haskell >= 2.7 } +common text { build-depends: text >= 1.2 } +common transformers { build-depends: transformers >= 0.5 } +common unix { build-depends: unix >= 2.7 } +common url { build-depends: url >= 2.1 } +common utf8-string { build-depends: utf8-string >= 1.0 } +common vector { build-depends: vector >= 0.12 } +common waargonaut { build-depends: waargonaut >= 0.8 } + + +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 + default-extensions: LambdaCase, MultiWayIf, ScopedTypeVariables, StrictData, Strict, TupleSections + library - exposed-modules: MyLib - -- other-modules: + import: config + , base + -- deps + , ascii-string + , bytestring + , containers + , generics-sop + , hpath + , hpath-filepath + , hpath-io + , language-bash + , optics + , parsec + , safe-exceptions + , streamly + , strict-base + , template-haskell + , text + , transformers + , unix + , url + , utf8-string + , vector + , waargonaut + exposed-modules: GHCup + GHCup.Bash + GHCup.File + GHCup.Prelude + GHCup.Types + GHCup.Types.JSON + GHCup.Types.Optics + other-modules: Streamly.ByteString -- other-extensions: - build-depends: base ^>=4.12.0.0 hs-source-dirs: lib - default-language: Haskell2010 executable ghcup + import: config + , base main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base ^>=4.12.0.0, ghcup + build-depends: ghcup hs-source-dirs: app default-language: Haskell2010 diff --git a/lib/GHCup.hs b/lib/GHCup.hs new file mode 100644 index 0000000..362a7a4 --- /dev/null +++ b/lib/GHCup.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +-- TODO: handle SIGTERM, SIGUSR +module GHCup where + +import Control.Applicative +import Data.Strict.Maybe +import Data.Version +import GHCup.Prelude +import GHCup.Bash +import GHCup.File +import GHCup.Types +import GHCup.Types.Optics +import HPath +import HPath.IO +import Network.URL +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Optics +import Prelude hiding ( abs + , Maybe + , Just + , Nothing + ) +import System.Info + +import qualified Data.Map.Strict as Map +import qualified GHC.Exts as GE +import qualified Prelude as P +import qualified System.Posix.Process.ByteString + as SPPB + + + +availableDownloads :: AvailableDownloads +availableDownloads = Map.fromList + [ ( GHC + , Map.fromList + [ ( mkV [8, 6, 5] + , Map.fromList + [ ( A_64 + , Map.fromList + [ ( Linux UnknownLinux + , mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz" + ) + ] + ) + ] + ) + ] + ) + ] + where + mkV = makeVersion + mkGHCUrl path = URL + { url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing + , url_path = path + , url_params = [] + } + +downloadURL :: Tool + -> Version + -> Architecture + -> Platform + -> AvailableDownloads + -> Maybe URL +downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro + + where + with_distro = distro_preview id + without_distro = distro_preview withoutDistro + without_ver = distro_preview withoutVer + + distro_preview f = + toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls + atJust x = at x % _Just + + -- | If we can't find a version with the given distro, + -- then just try with the platform. + withoutDistro :: Platform -> Platform + withoutDistro (Linux _) = Linux UnknownLinux + withoutDistro Darwin = Darwin + withoutDistro (FreeBSD _) = FreeBSD Nothing + + -- | If we can't find a match with the given distro version, + -- we gotta try without it. + withoutVer :: Platform -> Platform + withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing + withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing + withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing + withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing + withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux + withoutVer Darwin = Darwin + withoutVer (FreeBSD _) = FreeBSD Nothing + + +getArchitecture :: IO Architecture +getArchitecture = case arch of + "x86_64" -> pure A_64 + "i386" -> pure A_32 + what -> fail ("Could not find compatible architecture. Was: " <> what) + + + +getPlatform :: IO Platform +getPlatform = case os of + "linux" -> do + distro <- getLinuxDistro + pure $ Linux distro + -- TODO: these are not verified + "darwin" -> pure $ Darwin + "freebsd" -> do + ver <- getFreeBSDVersion + pure $ FreeBSD ver + what -> fail ("Could not find compatible platform. Was: " <> what) + + where + getLinuxDistro :: IO LinuxDistro + getLinuxDistro = do + let os_release = [abs|/etc/os-release|] + lsb_release = [abs|/etc/lsb-release|] + redhat_release = [abs|/etc/redhat-release|] + debian_version = [abs|/etc/debian_version|] + + pure undefined + + getFreeBSDVersion = pure Nothing + + -- Try various methods for getting distro name and version. + -- Failure is signalled with an IO exception. +try_os_release :: IO (String, P.Maybe String) +try_os_release = do + name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case + P.Just s -> pure $ s + P.Nothing -> fail "No value found" + version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID" + pure (name, version) + +try_lsb_release_cmd :: IO (String, P.Maybe String) +try_lsb_release_cmd = findExecutable ([fn|lsb_release|] :: Path Fn) >>= \case + P.Nothing -> fail "lsb_release not found" + P.Just path -> do + name <- executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] >>= \case + P.Just (out, _) -> pure out + _ -> fail "Barfed output of lsb_release" + version <- (fmap . fmap) (UTF8.toString . fst) + $ executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] + pure (UTF8.toString name, version) + + + + +-- download :: URL -> Path Abs -> IO (Path Abs) +-- download = undefined + +-- unpack :: Path Abs -> IO (Path Abs) +-- unpack = undefined + +-- install :: DownloadURL -> IO (Path Abs) +-- install = undefined + +-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads +-- parseAvailableDownloads = undefined diff --git a/lib/GHCup/Bash.hs b/lib/GHCup/Bash.hs new file mode 100644 index 0000000..a3bf8e2 --- /dev/null +++ b/lib/GHCup/Bash.hs @@ -0,0 +1,79 @@ +module GHCup.Bash where + +import Data.ByteString +import Language.Bash.Parse.Word +import Language.Bash.Word +import Language.Bash.Syntax +import Text.Parsec +import HPath +import Data.ByteString.UTF8 ( toString ) +import Streamly +import GHCup.File +import GHCup.Prelude ( internalError ) +import qualified Streamly.Prelude as S +import Control.Monad +import Data.Maybe + + +-- | Parse a single assignment of the given line. +parseAssignment :: SourceName -- ^ file/location of the parser + -> ByteString -- ^ the line as a bytestring + -> Either ParseError Assign +parseAssignment = runParser assign () + + +-- | Parse assignments in a stream. +parseAssignments :: Monad m + => SourceName -- ^ file/location of the parser + -> SerialT m (ByteString) + -> SerialT m (Either ParseError Assign) +parseAssignments sn = fmap (parseAssignment sn) + + +-- | Find an assignment matching the predicate in the given file. +findAssignment :: Path b + -> (Assign -> Bool) -- ^ predicate + -> IO (Maybe Assign) +findAssignment p predicate = do + let fn' = toString . toFilePath $ p + stream <- fmap (parseAssignments fn') $ readFileLines p + res <- + S.find -- empties the stream on first match, but doesn't terminate it + (\case + Right ass -> predicate ass + Left _ -> False + ) + stream + >>= \case + Just (Right x) -> pure (Just x) + Just (Left _) -> + internalError "unexpected Left in findAssignment" + Nothing -> pure Nothing + -- Closes the file handle. Because if there was a match, then + -- the stream is not terminated. + when (isJust res) $ S.drain stream + pure res + + +-- | Check that the assignment is of the form Foo= ignoring the +-- right hand-side. +equalsAssignmentWith :: String -> Assign -> Bool +equalsAssignmentWith n ass = case ass of + (Assign (Parameter name' Nothing) Equals _) -> n == name' + _ -> False + + +-- | This pretty-prints the right hand of an Equals assignment, removing +-- quotations. No evaluation is performed. +getRValue :: Assign -> Maybe String +getRValue ass = case ass of + (Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w + _ -> Nothing + + +-- | Given a bash assignment such as Foo="Bar" in the given file, +-- will return "Bar" (without quotations). +getAssignmentValueFor :: Path b -> String -> IO (Maybe String) +getAssignmentValueFor p n = do + mass <- findAssignment p (equalsAssignmentWith n) + pure (mass >>= getRValue) diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs new file mode 100644 index 0000000..012f09a --- /dev/null +++ b/lib/GHCup/File.hs @@ -0,0 +1,133 @@ +module GHCup.File where + +import Data.ByteString hiding (putStrLn) +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Maybe +import HPath +import HPath.IO +import Streamly.ByteString +import Streamly +import System.Posix.FilePath hiding ( () ) +import Data.Foldable +import Control.Monad +import Control.Exception.Safe +import Data.Functor +import System.Posix.Files.ByteString +import System.Posix.IO.ByteString hiding (openFd) +import qualified System.Posix.Process.ByteString + as SPPB +import System.Posix.Types + +import qualified Streamly.Internal.Memory.ArrayStream + as AS +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.Data.Unfold as SU +import qualified Streamly.Prelude as S +import System.IO +import System.Exit +import qualified Streamly.Data.Fold as FL +import Data.ByteString.Builder +import Foreign.C.Error +import GHCup.Prelude +import Control.Monad.Trans.Maybe +import HPath.Internal +import System.Posix.FD + ( + openFd + ) + + + +-- |Checks whether a file is executable. Follows symlinks. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +-- +-- Note: calls `access` +isExecutable :: Path b -> IO Bool +isExecutable p = fileAccess (toFilePath p) False False True + + +readFd :: Fd -> IO L.ByteString +readFd fd = do + handle' <- fdToHandle fd + let stream = + (S.unfold (SU.finally hClose FH.readChunks) handle') + >>= arrayToByteString + toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream) + + +-- | Read the lines of a file into a stream. The stream holds +-- a file handle as a resource and will close it once the stream +-- terminates (either through exception or because it's drained). +readFileLines :: Path b -> IO (SerialT IO ByteString) +readFileLines p = do + stream <- readFileStream' p + pure + . (>>= arrayToByteString) + . AS.splitOn (fromIntegral $ ord '\n') + . (>>= byteStringToArray) + $ stream + where + readFileStream' :: Path b + -> IO (SerialT IO ByteString) + readFileStream' (MkPath fp) = do + fd <- openFd fp ReadOnly [] Nothing + handle' <- fdToHandle fd + let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString + pure stream + + +-- | Find the given executable by searching all *absolute* PATH components. +-- Relative paths in PATH are ignored. +-- +-- This shouldn't throw IO exceptions, unless getting the environment variable +-- PATH does. +findExecutable :: RelC r => Path r -> IO (Maybe (Path Abs)) +findExecutable ex = do + sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath + -- We don't want exceptions to mess up our result. If we can't + -- figure out if a file exists, then treat it as a negative result. + asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap + -- asum for short-circuiting behavior + (\s -> (isExecutable (s ex) >>= guard) $> (Just (s ex))) + sPaths + + +findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs)) +findExecutablee ex = do + sPaths <- mapMaybe parseAbs <$> getSearchPath + runMaybeT $ asum (MaybeT . eExists <$> sPaths) + where + eExists sp = let path = sp ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path + + +-- TODO: fd leak +-- | Execute the given command and collect the stdout and the exit code. +executeOut :: Path Fn -- ^ command as filename, e.g. 'ls' + -> [ByteString] -- ^ arguments to the command + -> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout +executeOut path args = withFnPath path $ \fp -> do + (readE, writeE) <- createPipe + pid <- SPPB.forkProcess $ do + whileM_ + (dupTo writeE stdOutput) + (\r -> + getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR + ) + closeFd writeE + closeFd readE + SPPB.executeFile fp True args Nothing + + closeFd writeE + + -- readFd will take care of closing the fd + SPPB.getProcessStatus True True pid >>= \case + Just (SPPB.Exited es) -> do + out <- readFd readE + pure $ Just (out, es) + _ -> pure Nothing diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs new file mode 100644 index 0000000..dce1002 --- /dev/null +++ b/lib/GHCup/Prelude.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Prelude where + +import Control.Applicative +import Data.Strict.Maybe +import Data.Monoid ( (<>) ) +import Prelude ( Monad + , Bool + , return + , (.) + , (>>=) + ) +import qualified Prelude as P +import Data.String + + +fS :: IsString a => P.String -> a +fS = fromString + +fromStrictMaybe :: Maybe a -> P.Maybe a +fromStrictMaybe = maybe P.Nothing P.Just + +toStrictMaybe :: P.Maybe a -> Maybe a +toStrictMaybe = P.maybe Nothing Just + +instance Applicative Maybe where + pure = Just + + Just f <*> m = P.fmap f m + Nothing <*> _m = Nothing + + liftA2 f (Just x) (Just y) = Just (f x y) + liftA2 _ _ _ = Nothing + + Just _m1 *> m2 = m2 + Nothing *> _m2 = Nothing + +instance Alternative Maybe where + empty = Nothing + Nothing <|> r = r + l <|> _ = l + + +internalError :: P.String -> P.IO a +internalError = P.fail . ("Internal error: " <>) + +-- | Like 'when', but where the test can be monadic. +whenM :: Monad m => m Bool -> m () -> m () +whenM ~b ~t = ifM b t (return ()) + +-- | Like 'unless', but where the test can be monadic. +unlessM :: Monad m => m Bool -> m () -> m () +unlessM ~b ~f = ifM b (return ()) f + +-- | Like @if@, but where the test can be monadic. +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM ~b ~t ~f = do + b' <- b + if b' then t else f + +whileM_ :: Monad m => m a -> (a -> m Bool) -> m () +whileM_ action f = whenM (action >>= f) (whileM_ action f) + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs new file mode 100644 index 0000000..0b8c70b --- /dev/null +++ b/lib/GHCup/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} + +module GHCup.Types where + +import Data.Map.Strict (Map) +import Data.Strict.Maybe +import Data.Text +import Data.Version +import Network.URL +import Prelude hiding ( + Maybe + , Just + , Nothing) + +import qualified GHC.Generics as GHC + + +-- | Requested tool to be installed. User input. +data Tool = GHC + | Cabal + | Stack + deriving (Eq, Ord, Show) + +-- | Architecture we run on. +data Architecture = A_64 + | A_32 + deriving (Eq, Ord, Show) + +data LinuxDistro = Debian (Maybe CustomVersion) + | Ubuntu (Maybe CustomVersion) + | Mint (Maybe CustomVersion) + | Fedora (Maybe CustomVersion) + -- not known + | UnknownLinux + -- ^ must exit + deriving (Eq, GHC.Generic, Ord, Show) + + +data Platform = Linux LinuxDistro + -- ^ must exit + | Darwin + -- ^ must exit + | FreeBSD (Maybe CustomVersion) + deriving (Eq, GHC.Generic, Ord, Show) + +type CustomVersion = Text +type PlatformSpec = Map Platform URL +type ArchitectureSpec = Map Architecture PlatformSpec +type VersionSpec = Map Version ArchitectureSpec +type AvailableDownloads = Map Tool VersionSpec + diff --git a/lib/GHCup/Types/Foo.hs b/lib/GHCup/Types/Foo.hs new file mode 100644 index 0000000..8802c5a --- /dev/null +++ b/lib/GHCup/Types/Foo.hs @@ -0,0 +1,18 @@ +encToJsonNoSpaces + :: ( Monoid t + , Applicative f + ) + => AReview Json (b, t) + -> (a -> b) + -> Encoder f a +encToJsonNoSpaces c f = + encodeA (pure . review c . (, mempty) . f) + +bytestring :: Applicative f => Encoder f ByteString +bytestring = encToJsonNoSpaces _JStr (_JStringBS #) + +_JStringBS :: (Profunctor p, Applicative f) + => p ByteString (f ByteString) + -> p JString (f JString) +_JStringBS = iso (C.pack . review _JString) + (JString' . V.fromList . fmap utf8CharToJChar . C.unpack) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs new file mode 100644 index 0000000..a410b86 --- /dev/null +++ b/lib/GHCup/Types/JSON.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module GHCup.Types.JSON where + +import Data.Strict.Maybe +import GHCup.Types +import Generics.SOP.TH +import Prelude hiding ( + Maybe + , Just + , Nothing) +import Waargonaut.Generic ( + JsonEncode + , JsonDecode + , GWaarg) + + +deriveGeneric ''Maybe +instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a) +instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a) + +deriveGeneric ''Tool +instance JsonEncode GWaarg Tool +instance JsonDecode GWaarg Tool + +deriveGeneric ''Architecture +instance JsonEncode GWaarg Architecture +instance JsonDecode GWaarg Architecture + +deriveGeneric ''LinuxDistro +instance JsonEncode GWaarg LinuxDistro +instance JsonDecode GWaarg LinuxDistro + diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs new file mode 100644 index 0000000..d392cfa --- /dev/null +++ b/lib/GHCup/Types/Optics.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Types.Optics where + + diff --git a/lib/MyLib.hs b/lib/MyLib.hs deleted file mode 100644 index e657c44..0000000 --- a/lib/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/lib/Streamly/ByteString.hs b/lib/Streamly/ByteString.hs new file mode 100644 index 0000000..2cee0a1 --- /dev/null +++ b/lib/Streamly/ByteString.hs @@ -0,0 +1,57 @@ +{-# 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