Stuff
This commit is contained in:
Julian Ospald
parent
e4754f4e4e
commit
d4ed158acb
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
16
ghcup.cabal
16
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
|
||||
|
||||
|
|
|
|||
372
lib/GHCup.hs
372
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue