hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Stuff

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
cabal.project
View File

@ -12,10 +12,10 @@ package ghcup
source-repository-package source-repository-package
type: git type: git
location: https://github.com/composewell/streamly location: https://github.com/hasufell/streamly
tag: b8178cd08f7fc8180e4de83bde4b239cb0cfb31c tag: a343c4b99b20ea6f8207a220d5dccb3a88cecefa
source-repository-package source-repository-package
type: git type: git
location: https://github.com/hasufell/tar-bytestring location: https://github.com/psibi/streamly-bytestring
tag: c774ebdbc75d514648c8d4993abd188103182513 tag: fed14ce44e0219f68162f450b5c107fea20a6521

24
cabal.project.freeze
View File

@ -33,6 +33,7 @@ constraints: any.Cabal ==2.4.0.1,
any.bytestring ==0.10.8.2, any.bytestring ==0.10.8.2,
any.bytestring-builder ==0.10.8.2.0, any.bytestring-builder ==0.10.8.2.0,
bytestring-builder +bytestring_has_builder, bytestring-builder +bytestring_has_builder,
any.bzlib ==0.5.0.5,
any.cabal-doctest ==1.0.8, any.cabal-doctest ==1.0.8,
any.call-stack ==0.2.0, any.call-stack ==0.2.0,
any.case-insensitive ==1.2.1.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.filepath ==1.4.2.1,
any.focus ==1.0.1.3, any.focus ==1.0.1.3,
any.foldl ==1.4.6, any.foldl ==1.4.6,
any.fusion-plugin ==0.1.1,
any.gauge ==0.2.5, any.gauge ==0.2.5,
gauge +analysis, gauge +analysis,
any.generics-sop ==0.5.0.0, 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-boot-th ==8.6.5,
any.ghc-heap ==8.6.5,
any.ghc-prim ==0.5.3, any.ghc-prim ==0.5.3,
any.ghci ==8.6.5,
any.hashable ==1.3.0.0, any.hashable ==1.3.0.0,
hashable -examples +integer-gmp +sse2 -sse41, hashable -examples +integer-gmp +sse2 -sse41,
any.heaps ==0.3.6.1, any.heaps ==0.3.6.1,
any.hpath ==0.11.0, 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-filepath ==0.10.4,
any.hpath-io ==0.13.1, any.hpath-io ==0.13.1,
any.hpath-posix ==0.13.1, any.hpath-posix ==0.13.1,
any.hpc ==0.6.0.3,
any.hsc2hs ==0.68.6, any.hsc2hs ==0.68.6,
hsc2hs -in-ghc-tree, hsc2hs -in-ghc-tree,
any.hspec ==2.7.1, any.hspec ==2.7.1,
@ -87,6 +94,7 @@ constraints: any.Cabal ==2.4.0.1,
any.language-bash ==0.9.0, any.language-bash ==0.9.0,
any.list-t ==1.0.4, any.list-t ==1.0.4,
any.lockfree-queue ==0.2.3.1, any.lockfree-queue ==0.2.3.1,
any.lzma ==0.0.0.3,
any.math-functions ==0.3.3.0, any.math-functions ==0.3.3.0,
math-functions +system-erf +system-expm1, math-functions +system-erf +system-expm1,
any.megaparsec ==8.0.0, any.megaparsec ==8.0.0,
@ -95,7 +103,7 @@ constraints: any.Cabal ==2.4.0.1,
any.monad-control ==1.0.2.3, any.monad-control ==1.0.2.3,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.mwc-random ==0.14.0.0, 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.network-uri ==2.6.2.0,
any.openssl-streams ==1.2.2.0, any.openssl-streams ==1.2.2.0,
any.optics ==0.2, any.optics ==0.2,
@ -106,13 +114,13 @@ constraints: any.Cabal ==2.4.0.1,
any.parser-combinators ==1.2.1, any.parser-combinators ==1.2.1,
parser-combinators -dev, parser-combinators -dev,
any.pretty ==1.1.3.6, any.pretty ==1.1.3.6,
any.prettyprinter ==1.6.0, any.prettyprinter ==1.6.1,
prettyprinter -buildreadme, prettyprinter -buildreadme,
any.primitive ==0.7.0.0, any.primitive ==0.7.0.0,
any.primitive-extras ==0.8, any.primitive-extras ==0.8,
any.primitive-unlifted ==0.1.3.0, any.primitive-unlifted ==0.1.3.0,
any.process ==1.6.5.0, any.process ==1.6.5.0,
any.profunctors ==5.5.1, any.profunctors ==5.5.2,
any.quickcheck-io ==0.2.0, any.quickcheck-io ==0.2.0,
any.random ==1.1, any.random ==1.1,
any.rts ==1.0, any.rts ==1.0,
@ -128,13 +136,15 @@ constraints: any.Cabal ==2.4.0.1,
any.splitmix ==0.0.3, any.splitmix ==0.0.3,
splitmix -optimised-mixer +random, splitmix -optimised-mixer +random,
any.stm ==2.5.0.0, any.stm ==2.5.0.0,
streamly -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk, streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
any.streamly-bytestring ==0.1.0.1, any.streamly-bytestring ==0.1.2,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
any.syb ==0.7.1,
any.tagged ==0.8.6, any.tagged ==0.8.6,
tagged +deepseq +transformers, 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.template-haskell ==2.14.0.0,
any.terminfo ==0.4.1.2,
any.text ==1.2.3.1, any.text ==1.2.3.1,
any.text-icu ==0.7.0.1, any.text-icu ==0.7.0.1,
any.text-short ==0.1.3, any.text-short ==0.1.3,

16
ghcup.cabal
View File

@ -26,8 +26,10 @@ common ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 } common async { build-depends: async >= 0.8 }
common base { build-depends: base >= 4.12 && < 5 } common base { build-depends: base >= 4.12 && < 5 }
common bytestring { build-depends: bytestring >= 0.10 } common bytestring { build-depends: bytestring >= 0.10 }
common bzlib { build-depends: bzlib >= 0.5.0.5 }
common containers { build-depends: containers >= 0.6 } common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 } 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 { build-depends: hpath >= 0.11 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
common hpath-io { build-depends: hpath-io >= 0.13.1 } 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 http-io-streams { build-depends: http-io-streams >= 0.1 }
common io-streams { build-depends: io-streams >= 1.5 } common io-streams { build-depends: io-streams >= 1.5 }
common language-bash { build-depends: language-bash >= 0.9 } 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 mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 } common optics { build-depends: optics >= 0.2 }
common parsec { build-depends: parsec >= 3.1 } common parsec { build-depends: parsec >= 3.1 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } 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 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 template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 } common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 } 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 vector { build-depends: vector >= 0.12 }
common versions { build-depends: versions >= 3.5 } common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 } common waargonaut { build-depends: waargonaut >= 0.8 }
common zlib { build-depends: zlib >= 0.6.2.1 }
common config common config
default-language: Haskell2010 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 default-extensions: LambdaCase
, MultiWayIf , MultiWayIf
, PackageImports , PackageImports
@ -76,8 +81,10 @@ library
, ascii-string , ascii-string
, async , async
, bytestring , bytestring
, bzlib
, containers , containers
, generics-sop , generics-sop
, haskus-utils-variant
, hpath , hpath
, hpath-filepath , hpath-filepath
, hpath-io , hpath-io
@ -85,11 +92,13 @@ library
, http-io-streams , http-io-streams
, io-streams , io-streams
, language-bash , language-bash
, lzma
, mtl , mtl
, optics , optics
, parsec , parsec
, safe-exceptions , safe-exceptions
, streamly , streamly
, streamly-bytestring
, strict-base , strict-base
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
@ -102,6 +111,7 @@ library
, utf8-string , utf8-string
, vector , vector
, versions , versions
, zlib
exposed-modules: GHCup exposed-modules: GHCup
GHCup.Bash GHCup.Bash
GHCup.File GHCup.File
@ -109,7 +119,7 @@ library
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.Optics GHCup.Types.Optics
other-modules: Streamly.ByteString -- other-modules:
-- other-extensions: -- other-extensions:
hs-source-dirs: lib hs-source-dirs: lib

372
lib/GHCup.hs
View File

@ -11,11 +11,13 @@
module GHCup where module GHCup where
import qualified Codec.Archive.Tar as Tar
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Exception.Safe import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Foldable ( asum ) import Data.Foldable ( asum )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
@ -39,12 +41,19 @@ import Data.Maybe
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import GHC.IO.Exception import GHC.IO.Exception
import GHC.IO.Handle import GHC.IO.Handle
import Haskus.Utils.Variant.Excepts
import Haskus.Utils.Variant.VEither
import Network.Http.Client hiding ( URL ) import Network.Http.Client hiding ( URL )
import System.IO.Streams ( InputStream import System.IO.Streams ( InputStream
, OutputStream , OutputStream
, stdout , stdout
) )
import qualified System.IO.Streams as Streams 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 System.Posix.Temp.ByteString
import "unix" System.Posix.IO.ByteString import "unix" System.Posix.IO.ByteString
hiding ( fdWrite ) hiding ( fdWrite )
@ -58,6 +67,40 @@ import System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite ) ( 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 availableDownloads :: AvailableDownloads
@ -103,16 +146,20 @@ availableDownloads = Map.fromList
} }
getDownloadURL :: ToolRequest getDownloadURL :: (MonadCatch m, MonadIO m)
=> ToolRequest
-> Maybe PlatformRequest -> Maybe PlatformRequest
-> URLSource -> URLSource
-> IO (Maybe URL) -- TODO: better error handling -> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
URL
getDownloadURL (ToolRequest t v) mpfReq urlSource = do getDownloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of (PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x Just x -> pure x
Nothing -> do Nothing -> do
(PlatformResult rp rv) <- getPlatform (PlatformResult rp rv) <- liftE getPlatform
let ar = (\(Right x) -> x) getArchitecture ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv pure $ PlatformRequest ar rp rv
dls <- case urlSource of dls <- case urlSource of
@ -120,7 +167,7 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do
OwnSource url -> fail "Not implemented" OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls OwnSpec dls -> pure dls
pure $ getDownloadURL' t v arch plat ver dls lE $ getDownloadURL' t v arch plat ver dls
getDownloadURL' :: Tool getDownloadURL' :: Tool
@ -133,136 +180,22 @@ getDownloadURL' :: Tool
-> Maybe Versioning -> Maybe Versioning
-- ^ optional version of the platform -- ^ optional version of the platform
-> AvailableDownloads -> AvailableDownloads
-> Maybe URL -> Either NoDownload URL
getDownloadURL' t v a p mv dls = getDownloadURL' t v a p mv dls = maybe
with_distro <|> without_distro_ver <|> without_distro (Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
where where
with_distro = distro_preview id id with_distro = distro_preview id id
without_distro = distro_preview (set _Linux UnknownLinux) id
without_distro_ver = distro_preview id (const Nothing) without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
distro_preview f g = distro_preview f g =
preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
atJust x = at x % _Just 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 -- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file. -- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we: -- 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. -- throw an exception if the url type or host protocol is not supported.
-- --
-- Only Absolute HTTP/HTTPS is 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 download' url dest mfn = case url of
URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] } URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] }
-> download https host path port dest mfn -> 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. -- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout. -- print to stdout.
downloadFd :: Bool -- ^ https? downloadFd :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com") -> String -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file") -> String -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000) -> 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 :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined -- parseAvailableDownloads = undefined

26
lib/GHCup/File.hs
View File

@ -9,7 +9,8 @@ import Data.Maybe
import HPath import HPath
import HPath.IO import HPath.IO
import Optics import Optics
import Streamly.ByteString import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import Streamly import Streamly
import System.Posix.FilePath hiding ( (</>) ) import System.Posix.FilePath hiding ( (</>) )
import Data.Foldable import Data.Foldable
@ -23,6 +24,7 @@ import "unix" System.Posix.IO.ByteString
hiding ( openFd ) hiding ( openFd )
import qualified System.Posix.Process.ByteString import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import System.Posix.Directory.ByteString
import System.Posix.Types import System.Posix.Types
import qualified Streamly.Internal.Memory.ArrayStream import qualified Streamly.Internal.Memory.ArrayStream
@ -52,10 +54,7 @@ makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString readFd :: Fd -> IO L.ByteString
readFd fd = do readFd fd = do
handle' <- fdToHandle fd handle' <- fdToHandle fd
let stream = fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
(S.unfold (SU.finallyIO 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 -- | 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 readFileLines p = do
stream <- readFileStream p stream <- readFileStream p
pure pure
. (>>= arrayToByteString) . (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n') . AS.splitOn (fromIntegral $ ord '\n')
. (>>= byteStringToArray) . (fmap toArray)
$ stream $ stream
@ -89,11 +88,14 @@ findExecutable ex = do
-- | Execute the given command and collect the stdout, stderr and the exit code. -- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess. -- The command is run in a subprocess.
executeOut :: Path Rel -- ^ command as filename, e.g. 'ls' executeOut :: Path Rel -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command -> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO (Maybe CapturedProcess) -> IO (Maybe CapturedProcess)
executeOut path args = withRelPath path executeOut path args chdir = withRelPath path
$ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing $ \fp -> captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile fp True args Nothing
-- | Capture the stdout and stderr of the given action, which -- | 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. -- 'race' this to make sure it terminates.
captureOutStreams :: IO a captureOutStreams :: IO a
-- ^ the action to execute in a subprocess -- ^ the action to execute in a subprocess
-> IO (Maybe CapturedProcess) -> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe
captureOutStreams action = captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) -> actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do

25
lib/GHCup/Prelude.hs
View File

@ -1,11 +1,14 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Prelude where module GHCup.Prelude where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe import Control.Exception.Safe
import qualified Data.Strict.Maybe as S import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
@ -14,6 +17,7 @@ import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text ( Text ) import Data.Text ( Text )
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Haskus.Utils.Variant.Excepts
import System.IO.Error import System.IO.Error
@ -74,3 +78,24 @@ handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
handleIO' err handler = handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) 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

57
lib/Streamly/ByteString.hs
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