Basic version of 'downloadURL'
This commit is contained in:
parent
3fb5c612c1
commit
92531045f8
33
README.md
33
README.md
@ -1 +1,34 @@
|
|||||||
# ghcup
|
# ghcup
|
||||||
|
|
||||||
|
A rewrite of ghcup in haskell. This can be used as a library
|
||||||
|
and may be redistributed as a binary in the future.
|
||||||
|
|
||||||
|
## Motivation
|
||||||
|
|
||||||
|
ghcup has increasingly become difficult to maintain. A few reasons:
|
||||||
|
|
||||||
|
* few maintainers
|
||||||
|
* increasing LOC
|
||||||
|
* platform incompatibilities regularly causing breaking bugs:
|
||||||
|
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
|
||||||
|
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
|
||||||
|
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
|
||||||
|
* refactoring being difficult due to POSIX sh
|
||||||
|
|
||||||
|
More benefits of a rewrite:
|
||||||
|
|
||||||
|
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
|
||||||
|
* Refactoring will be easier
|
||||||
|
* Better tool support (such as linting the downloads file)
|
||||||
|
* saner downloads file format (such as JSON)
|
||||||
|
|
||||||
|
However, the downside will be:
|
||||||
|
|
||||||
|
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
|
||||||
|
* still bootstrapping those binaries via a POSIX sh script
|
||||||
|
|
||||||
|
## Goals
|
||||||
|
|
||||||
|
* Correct low-level code
|
||||||
|
* Good exception handling
|
||||||
|
* Easier user interface (possibly interactive and non-interactive ones)
|
||||||
|
12
TODO.md
Normal file
12
TODO.md
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
# TODOs and Remarks
|
||||||
|
|
||||||
|
* handling of SIGTERM and SIGUSR
|
||||||
|
* add support for RC/alpha/HEAD versions
|
||||||
|
* redo/rethink how tool tags works
|
||||||
|
* installing multiple versions in parallel?
|
||||||
|
|
||||||
|
* exception handling (checked exception library? Maybe effects system all the way?)
|
||||||
|
* how to version and extend the format of the downloads file? Compatibility?
|
||||||
|
* how to propagate updates? Automatically? Might solve the versioning problem
|
||||||
|
|
||||||
|
|
@ -1,2 +1,9 @@
|
|||||||
packages: ./ghcup.cabal
|
packages: ./ghcup.cabal
|
||||||
|
|
||||||
|
optimization: 2
|
||||||
|
|
||||||
|
package streamly
|
||||||
|
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||||
|
|
||||||
|
package ghcup
|
||||||
|
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||||
|
11
ghcup.cabal
11
ghcup.cabal
@ -20,6 +20,7 @@ source-repository head
|
|||||||
type: git
|
type: git
|
||||||
location: https://github.com/hasufell/ghcup-hs
|
location: https://github.com/hasufell/ghcup-hs
|
||||||
|
|
||||||
|
common aeson { build-depends: aeson >= 1.4 }
|
||||||
common ascii-string { build-depends: ascii-string >= 1.0 }
|
common ascii-string { build-depends: ascii-string >= 1.0 }
|
||||||
common base { build-depends: base >= 4.12.0.0 && < 5 }
|
common base { build-depends: base >= 4.12.0.0 && < 5 }
|
||||||
common bytestring { build-depends: bytestring >= 0.10 }
|
common bytestring { build-depends: bytestring >= 0.10 }
|
||||||
@ -36,12 +37,16 @@ common streamly { build-depends: streamly >= 0.7 }
|
|||||||
common strict-base { build-depends: strict-base >= 0.4 }
|
common strict-base { build-depends: strict-base >= 0.4 }
|
||||||
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 transformers { build-depends: transformers >= 0.5 }
|
common transformers { build-depends: transformers >= 0.5 }
|
||||||
common unix { build-depends: unix >= 2.7 }
|
common unix { build-depends: unix >= 2.7 }
|
||||||
common url { build-depends: url >= 2.1 }
|
common url { build-depends: url >= 2.1 }
|
||||||
common utf8-string { build-depends: utf8-string >= 1.0 }
|
common utf8-string { build-depends: utf8-string >= 1.0 }
|
||||||
common vector { build-depends: vector >= 0.12 }
|
common vector { build-depends: vector >= 0.12 }
|
||||||
common waargonaut { build-depends: waargonaut >= 0.8 }
|
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||||
|
common async { build-depends: async >= 0.8 }
|
||||||
|
common mtl { build-depends: mtl >= 2.2 }
|
||||||
|
common versions { build-depends: versions >= 3.5 }
|
||||||
|
|
||||||
|
|
||||||
common config
|
common config
|
||||||
@ -53,7 +58,9 @@ library
|
|||||||
import: config
|
import: config
|
||||||
, base
|
, base
|
||||||
-- deps
|
-- deps
|
||||||
|
, aeson
|
||||||
, ascii-string
|
, ascii-string
|
||||||
|
, async
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, generics-sop
|
, generics-sop
|
||||||
@ -61,6 +68,7 @@ library
|
|||||||
, hpath-filepath
|
, hpath-filepath
|
||||||
, hpath-io
|
, hpath-io
|
||||||
, language-bash
|
, language-bash
|
||||||
|
, mtl
|
||||||
, optics
|
, optics
|
||||||
, parsec
|
, parsec
|
||||||
, safe-exceptions
|
, safe-exceptions
|
||||||
@ -68,12 +76,13 @@ library
|
|||||||
, strict-base
|
, strict-base
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text
|
, text
|
||||||
|
, text-icu
|
||||||
, transformers
|
, transformers
|
||||||
, unix
|
, unix
|
||||||
, url
|
, url
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, vector
|
, vector
|
||||||
, waargonaut
|
, versions
|
||||||
exposed-modules: GHCup
|
exposed-modules: GHCup
|
||||||
GHCup.Bash
|
GHCup.Bash
|
||||||
GHCup.File
|
GHCup.File
|
||||||
|
219
lib/GHCup.hs
219
lib/GHCup.hs
@ -10,44 +10,46 @@
|
|||||||
-- TODO: handle SIGTERM, SIGUSR
|
-- TODO: handle SIGTERM, SIGUSR
|
||||||
module GHCup where
|
module GHCup where
|
||||||
|
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.Strict.Maybe
|
import Control.Monad
|
||||||
import Data.Version
|
import Data.Foldable ( asum )
|
||||||
import GHCup.Prelude
|
import Data.Text ( Text )
|
||||||
|
import Data.Versions
|
||||||
import GHCup.Bash
|
import GHCup.Bash
|
||||||
import GHCup.File
|
import GHCup.File
|
||||||
|
import GHCup.Prelude
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Types.Optics
|
import GHCup.Types.Optics
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO
|
import HPath.IO
|
||||||
import Network.URL
|
import Network.URL
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
|
||||||
import Optics
|
import Optics
|
||||||
import Prelude hiding ( abs
|
import Prelude hiding ( abs
|
||||||
, Maybe
|
, readFile
|
||||||
, Just
|
|
||||||
, Nothing
|
|
||||||
)
|
)
|
||||||
import System.Info
|
import System.Info
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.ICU as ICU
|
||||||
|
import Data.Maybe ( isJust )
|
||||||
import qualified Data.Map.Strict as Map
|
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 :: AvailableDownloads
|
||||||
availableDownloads = Map.fromList
|
availableDownloads = Map.fromList
|
||||||
[ ( GHC
|
[ ( GHC
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( mkV [8, 6, 5]
|
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( A_64
|
[ ( A_64
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( Linux UnknownLinux
|
[ ( Linux UnknownLinux
|
||||||
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
, Map.fromList
|
||||||
|
[ ( Nothing
|
||||||
|
, mkGHCUrl
|
||||||
|
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
||||||
|
)
|
||||||
|
]
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
@ -57,101 +59,170 @@ availableDownloads = Map.fromList
|
|||||||
)
|
)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
mkV = makeVersion
|
|
||||||
mkGHCUrl path = URL
|
mkGHCUrl path = URL
|
||||||
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing
|
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
|
||||||
, url_path = path
|
, url_path = path
|
||||||
, url_params = []
|
, url_params = []
|
||||||
}
|
}
|
||||||
|
|
||||||
downloadURL :: Tool
|
|
||||||
|
downloadURL :: ToolRequest
|
||||||
|
-> Maybe PlatformRequest
|
||||||
|
-> URLSource
|
||||||
|
-> IO (Maybe URL) -- TODO: better error handling
|
||||||
|
downloadURL (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
|
||||||
|
pure $ PlatformRequest ar rp rv
|
||||||
|
|
||||||
|
dls <- case urlSource of
|
||||||
|
GHCupURL -> fail "Not implemented"
|
||||||
|
OwnSource url -> fail "Not implemented"
|
||||||
|
OwnSpec dls -> pure dls
|
||||||
|
|
||||||
|
pure $ downloadURL' t v arch plat ver dls
|
||||||
|
|
||||||
|
|
||||||
|
downloadURL' :: Tool
|
||||||
-> Version
|
-> Version
|
||||||
|
-- ^ tool version
|
||||||
-> Architecture
|
-> Architecture
|
||||||
|
-- ^ user arch
|
||||||
-> Platform
|
-> Platform
|
||||||
|
-- ^ user platform
|
||||||
|
-> Maybe Versioning
|
||||||
|
-- ^ optional version of the platform
|
||||||
-> AvailableDownloads
|
-> AvailableDownloads
|
||||||
-> Maybe URL
|
-> Maybe URL
|
||||||
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro
|
downloadURL' t v a p mv dls =
|
||||||
|
with_distro <|> without_distro_ver <|> without_distro
|
||||||
|
|
||||||
where
|
where
|
||||||
with_distro = distro_preview id
|
with_distro = distro_preview id id
|
||||||
without_distro = distro_preview withoutDistro
|
without_distro = distro_preview (set _Linux UnknownLinux) id
|
||||||
without_ver = distro_preview withoutVer
|
without_distro_ver = distro_preview id (const Nothing)
|
||||||
|
|
||||||
distro_preview f =
|
distro_preview f g =
|
||||||
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) 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
|
||||||
|
|
||||||
-- | 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,
|
getArchitecture :: Either String Architecture
|
||||||
-- 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
|
getArchitecture = case arch of
|
||||||
"x86_64" -> pure A_64
|
"x86_64" -> pure A_64
|
||||||
"i386" -> pure A_32
|
"i386" -> pure A_32
|
||||||
what -> fail ("Could not find compatible architecture. Was: " <> what)
|
what -> Left ("Could not find compatible architecture. Was: " <> what)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
getPlatform :: IO Platform
|
getPlatform :: IO PlatformResult
|
||||||
getPlatform = case os of
|
getPlatform = case os of
|
||||||
"linux" -> do
|
"linux" -> do
|
||||||
distro <- getLinuxDistro
|
(distro, ver) <- getLinuxDistro
|
||||||
pure $ Linux distro
|
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||||
-- TODO: these are not verified
|
-- TODO: these are not verified
|
||||||
"darwin" -> pure $ Darwin
|
"darwin" ->
|
||||||
|
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||||
"freebsd" -> do
|
"freebsd" -> do
|
||||||
ver <- getFreeBSDVersion
|
ver <- getFreeBSDVersion
|
||||||
pure $ FreeBSD ver
|
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||||
what -> fail ("Could not find compatible platform. Was: " <> what)
|
what -> fail ("Could not find compatible platform. Was: " <> what)
|
||||||
|
where getFreeBSDVersion = pure Nothing
|
||||||
|
|
||||||
where
|
|
||||||
getLinuxDistro :: IO LinuxDistro
|
getLinuxDistro :: IO (LinuxDistro, Maybe Versioning)
|
||||||
getLinuxDistro = do
|
getLinuxDistro = do
|
||||||
let os_release = [abs|/etc/os-release|]
|
(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 (T.pack <$> ["debian"]) -> Debian
|
||||||
|
| hasWord name (T.pack <$> ["ubuntu"]) -> Ubuntu
|
||||||
|
| hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
|
||||||
|
| hasWord name (T.pack <$> ["fedora"]) -> Fedora
|
||||||
|
| hasWord name (T.pack <$> ["centos"]) -> CentOS
|
||||||
|
| hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
|
||||||
|
| hasWord name (T.pack <$> ["alpine"]) -> Alpine
|
||||||
|
| hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
|
||||||
|
| hasWord name (T.pack <$> ["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
|
||||||
|
matches
|
||||||
|
|
||||||
|
os_release :: Path Abs
|
||||||
|
os_release = [abs|/etc/os-release|]
|
||||||
|
lsb_release :: Path Abs
|
||||||
lsb_release = [abs|/etc/lsb-release|]
|
lsb_release = [abs|/etc/lsb-release|]
|
||||||
|
lsb_release_cmd :: Path Fn
|
||||||
|
lsb_release_cmd = [fn|lsb-release|]
|
||||||
|
redhat_release :: Path Abs
|
||||||
redhat_release = [abs|/etc/redhat-release|]
|
redhat_release = [abs|/etc/redhat-release|]
|
||||||
|
debian_version :: Path Abs
|
||||||
debian_version = [abs|/etc/debian_version|]
|
debian_version = [abs|/etc/debian_version|]
|
||||||
|
|
||||||
pure undefined
|
try_os_release :: IO (Text, Maybe Text)
|
||||||
|
|
||||||
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
|
try_os_release = do
|
||||||
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case
|
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||||
P.Just s -> pure $ s
|
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||||
P.Nothing -> fail "No value found"
|
pure (T.pack name, fmap T.pack ver)
|
||||||
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID"
|
|
||||||
pure (name, version)
|
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||||
|
try_lsb_release_cmd = do
|
||||||
|
(Just _ ) <- findExecutable lsb_release_cmd
|
||||||
|
(Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
|
||||||
|
ver <- executeOut lsb_release_cmd [fS "-sr"]
|
||||||
|
pure (lBS2sT name, fmap (lBS2sT . fst) 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)
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,58 +1,47 @@
|
|||||||
module GHCup.Bash where
|
module GHCup.Bash
|
||||||
|
( findAssignment
|
||||||
|
, equalsAssignmentWith
|
||||||
|
, getRValue
|
||||||
|
, getAssignmentValueFor
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.ByteString
|
import Language.Bash.Parse
|
||||||
import Language.Bash.Parse.Word
|
|
||||||
import Language.Bash.Word
|
import Language.Bash.Word
|
||||||
import Language.Bash.Syntax
|
import Language.Bash.Syntax
|
||||||
import Text.Parsec
|
|
||||||
import HPath
|
import HPath
|
||||||
|
import HPath.IO
|
||||||
import Data.ByteString.UTF8 ( toString )
|
import Data.ByteString.UTF8 ( toString )
|
||||||
import Streamly
|
|
||||||
import GHCup.File
|
|
||||||
import GHCup.Prelude ( internalError )
|
|
||||||
import qualified Streamly.Prelude as S
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||||
|
import Prelude hiding ( readFile )
|
||||||
|
import Data.List
|
||||||
|
|
||||||
|
|
||||||
-- | Parse a single assignment of the given line.
|
extractAssignments :: List -> [Assign]
|
||||||
parseAssignment :: SourceName -- ^ file/location of the parser
|
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||||
-> ByteString -- ^ the line as a bytestring
|
where
|
||||||
-> Either ParseError Assign
|
getCommands :: [Statement] -> [Command]
|
||||||
parseAssignment = runParser assign ()
|
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||||
|
where
|
||||||
|
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||||
|
findPipes _ = Nothing
|
||||||
|
|
||||||
|
getAssign :: Command -> [Assign]
|
||||||
-- | Parse assignments in a stream.
|
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||||
parseAssignments :: Monad m
|
getAssign _ = []
|
||||||
=> 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.
|
-- | Find an assignment matching the predicate in the given file.
|
||||||
findAssignment :: Path b
|
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||||
-> (Assign -> Bool) -- ^ predicate
|
|
||||||
-> IO (Maybe Assign)
|
|
||||||
findAssignment p predicate = do
|
findAssignment p predicate = do
|
||||||
let fn' = toString . toFilePath $ p
|
fileContents <- readFile p
|
||||||
stream <- fmap (parseAssignments fn') $ readFileLines p
|
-- TODO: this should accept bytestring:
|
||||||
res <-
|
-- https://github.com/knrafto/language-bash/issues/37
|
||||||
S.find -- empties the stream on first match, but doesn't terminate it
|
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||||
(\case
|
Left e -> fail $ show e
|
||||||
Right ass -> predicate ass
|
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||||
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
|
-- | Check that the assignment is of the form Foo= ignoring the
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
module GHCup.File where
|
module GHCup.File where
|
||||||
|
|
||||||
import Data.ByteString hiding (putStrLn)
|
import Data.ByteString
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@ -14,7 +14,9 @@ import Control.Monad
|
|||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import System.Posix.Files.ByteString
|
import System.Posix.Files.ByteString
|
||||||
import System.Posix.IO.ByteString hiding (openFd)
|
import System.IO
|
||||||
|
import System.Posix.IO.ByteString
|
||||||
|
hiding ( openFd )
|
||||||
import qualified System.Posix.Process.ByteString
|
import qualified System.Posix.Process.ByteString
|
||||||
as SPPB
|
as SPPB
|
||||||
import System.Posix.Types
|
import System.Posix.Types
|
||||||
@ -24,19 +26,11 @@ import qualified Streamly.Internal.Memory.ArrayStream
|
|||||||
import qualified Streamly.FileSystem.Handle as FH
|
import qualified Streamly.FileSystem.Handle as FH
|
||||||
import qualified Streamly.Internal.Data.Unfold as SU
|
import qualified Streamly.Internal.Data.Unfold as SU
|
||||||
import qualified Streamly.Prelude as S
|
import qualified Streamly.Prelude as S
|
||||||
import System.IO
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import qualified Streamly.Data.Fold as FL
|
import qualified Streamly.Data.Fold as FL
|
||||||
import Data.ByteString.Builder
|
import Data.ByteString.Builder
|
||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
import GHCup.Prelude
|
import GHCup.Prelude
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import HPath.Internal
|
|
||||||
import System.Posix.FD
|
|
||||||
(
|
|
||||||
openFd
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- |Checks whether a file is executable. Follows symlinks.
|
-- |Checks whether a file is executable. Follows symlinks.
|
||||||
@ -66,20 +60,12 @@ readFd fd = do
|
|||||||
-- terminates (either through exception or because it's drained).
|
-- terminates (either through exception or because it's drained).
|
||||||
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||||
readFileLines p = do
|
readFileLines p = do
|
||||||
stream <- readFileStream' p
|
stream <- readFileStream p
|
||||||
pure
|
pure
|
||||||
. (>>= arrayToByteString)
|
. (>>= arrayToByteString)
|
||||||
. AS.splitOn (fromIntegral $ ord '\n')
|
. AS.splitOn (fromIntegral $ ord '\n')
|
||||||
. (>>= byteStringToArray)
|
. (>>= byteStringToArray)
|
||||||
$ stream
|
$ 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.
|
-- | Find the given executable by searching all *absolute* PATH components.
|
||||||
@ -92,42 +78,32 @@ findExecutable ex = do
|
|||||||
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||||
-- We don't want exceptions to mess up our result. If we can't
|
-- 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.
|
-- figure out if a file exists, then treat it as a negative result.
|
||||||
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap
|
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||||
-- asum for short-circuiting behavior
|
-- asum for short-circuiting behavior
|
||||||
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
|
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
|
||||||
sPaths
|
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.
|
-- | Execute the given command and collect the stdout and the exit code.
|
||||||
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
||||||
-> [ByteString] -- ^ arguments to the command
|
-> [ByteString] -- ^ arguments to the command
|
||||||
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
||||||
executeOut path args = withFnPath path $ \fp -> do
|
executeOut path args = withFnPath path $ \fp -> do
|
||||||
(readE, writeE) <- createPipe
|
(parentRead, childWrite) <- createPipe
|
||||||
pid <- SPPB.forkProcess $ do
|
pid <- SPPB.forkProcess $ do
|
||||||
whileM_
|
whileM_
|
||||||
(dupTo writeE stdOutput)
|
(dupTo childWrite stdOutput)
|
||||||
(\r ->
|
(\r ->
|
||||||
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
|
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
|
||||||
)
|
)
|
||||||
closeFd writeE
|
closeFd childWrite
|
||||||
closeFd readE
|
closeFd parentRead
|
||||||
|
closeFd stdInput
|
||||||
SPPB.executeFile fp True args Nothing
|
SPPB.executeFile fp True args Nothing
|
||||||
|
|
||||||
closeFd writeE
|
closeFd childWrite
|
||||||
|
|
||||||
-- readFd will take care of closing the fd
|
|
||||||
SPPB.getProcessStatus True True pid >>= \case
|
SPPB.getProcessStatus True True pid >>= \case
|
||||||
Just (SPPB.Exited es) -> do
|
-- readE will take care of closing the fd
|
||||||
out <- readFd readE
|
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
|
||||||
pure $ Just (out, es)
|
_ -> closeFd parentRead $> Nothing
|
||||||
_ -> pure Nothing
|
|
||||||
|
@ -5,16 +5,21 @@
|
|||||||
module GHCup.Prelude where
|
module GHCup.Prelude where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
|
import Control.Monad
|
||||||
import Data.Strict.Maybe
|
import Data.Strict.Maybe
|
||||||
import Data.Monoid ( (<>) )
|
import Data.Monoid ( (<>) )
|
||||||
import Prelude ( Monad
|
import Prelude ( Monad
|
||||||
, Bool
|
, Bool
|
||||||
, return
|
, return
|
||||||
, (.)
|
, (.)
|
||||||
, (>>=)
|
|
||||||
)
|
)
|
||||||
import qualified Prelude as P
|
import qualified Prelude as P
|
||||||
import Data.String
|
import Data.String
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
fS :: IsString a => P.String -> a
|
fS :: IsString a => P.String -> a
|
||||||
@ -23,9 +28,15 @@ fS = fromString
|
|||||||
fromStrictMaybe :: Maybe a -> P.Maybe a
|
fromStrictMaybe :: Maybe a -> P.Maybe a
|
||||||
fromStrictMaybe = maybe P.Nothing P.Just
|
fromStrictMaybe = maybe P.Nothing P.Just
|
||||||
|
|
||||||
|
fSM :: Maybe a -> P.Maybe a
|
||||||
|
fSM = fromStrictMaybe
|
||||||
|
|
||||||
toStrictMaybe :: P.Maybe a -> Maybe a
|
toStrictMaybe :: P.Maybe a -> Maybe a
|
||||||
toStrictMaybe = P.maybe Nothing Just
|
toStrictMaybe = P.maybe Nothing Just
|
||||||
|
|
||||||
|
tSM :: P.Maybe a -> Maybe a
|
||||||
|
tSM = toStrictMaybe
|
||||||
|
|
||||||
instance Applicative Maybe where
|
instance Applicative Maybe where
|
||||||
pure = Just
|
pure = Just
|
||||||
|
|
||||||
@ -61,6 +72,17 @@ ifM ~b ~t ~f = do
|
|||||||
b' <- b
|
b' <- b
|
||||||
if b' then t else f
|
if b' then t else f
|
||||||
|
|
||||||
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
whileM :: Monad m => m a -> (a -> m Bool) -> m a
|
||||||
whileM_ action f = whenM (action >>= f) (whileM_ action f)
|
whileM ~action ~f = do
|
||||||
|
a <- action
|
||||||
|
b' <- f a
|
||||||
|
if b' then whileM action f else pure a
|
||||||
|
|
||||||
|
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||||
|
whileM_ ~action = void . whileM action
|
||||||
|
|
||||||
|
guardM :: (Monad m, Alternative m) => m Bool -> m ()
|
||||||
|
guardM f = guard =<< f
|
||||||
|
|
||||||
|
lBS2sT :: L.ByteString -> Text
|
||||||
|
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||||
|
@ -3,49 +3,65 @@
|
|||||||
module GHCup.Types where
|
module GHCup.Types where
|
||||||
|
|
||||||
import Data.Map.Strict ( Map )
|
import Data.Map.Strict ( Map )
|
||||||
import Data.Strict.Maybe
|
|
||||||
import Data.Text
|
|
||||||
import Data.Version
|
|
||||||
import Network.URL
|
import Network.URL
|
||||||
import Prelude hiding (
|
|
||||||
Maybe
|
|
||||||
, Just
|
|
||||||
, Nothing)
|
|
||||||
|
|
||||||
import qualified GHC.Generics as GHC
|
import qualified GHC.Generics as GHC
|
||||||
|
import Data.Versions
|
||||||
|
|
||||||
|
|
||||||
-- | Requested tool to be installed. User input.
|
|
||||||
data Tool = GHC
|
data Tool = GHC
|
||||||
| Cabal
|
| Cabal
|
||||||
| Stack
|
| Stack
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
-- | Architecture we run on.
|
data ToolRequest = ToolRequest {
|
||||||
|
_tool :: Tool
|
||||||
|
, _toolVersion :: Version
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
data Architecture = A_64
|
data Architecture = A_64
|
||||||
| A_32
|
| A_32
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
data LinuxDistro = Debian (Maybe CustomVersion)
|
data LinuxDistro = Debian
|
||||||
| Ubuntu (Maybe CustomVersion)
|
| Ubuntu
|
||||||
| Mint (Maybe CustomVersion)
|
| Mint
|
||||||
| Fedora (Maybe CustomVersion)
|
| Fedora
|
||||||
|
| CentOS
|
||||||
|
| RedHat
|
||||||
|
| Alpine
|
||||||
|
-- rolling
|
||||||
|
| Gentoo
|
||||||
|
| Exherbo
|
||||||
-- not known
|
-- not known
|
||||||
| UnknownLinux
|
| UnknownLinux
|
||||||
-- ^ must exit
|
-- ^ must exit
|
||||||
deriving (Eq, GHC.Generic, Ord, Show)
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
data Platform = Linux LinuxDistro
|
data Platform = Linux LinuxDistro
|
||||||
-- ^ must exit
|
-- ^ must exit
|
||||||
| Darwin
|
| Darwin
|
||||||
-- ^ must exit
|
-- ^ must exit
|
||||||
| FreeBSD (Maybe CustomVersion)
|
| FreeBSD
|
||||||
deriving (Eq, GHC.Generic, Ord, Show)
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
type CustomVersion = Text
|
data PlatformResult = PlatformResult {
|
||||||
type PlatformSpec = Map Platform URL
|
_platform :: Platform
|
||||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
, _distroVersion :: Maybe Versioning
|
||||||
type VersionSpec = Map Version ArchitectureSpec
|
} deriving (Eq, Show)
|
||||||
type AvailableDownloads = Map Tool VersionSpec
|
|
||||||
|
|
||||||
|
data PlatformRequest = PlatformRequest {
|
||||||
|
_rArch :: Architecture
|
||||||
|
, _rPlatform :: Platform
|
||||||
|
, _rVersion :: Maybe Versioning
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
type PlatformVersionSpec = Map (Maybe Versioning) URL
|
||||||
|
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||||
|
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||||
|
type ToolVersionSpec = Map Version ArchitectureSpec
|
||||||
|
type AvailableDownloads = Map Tool ToolVersionSpec
|
||||||
|
|
||||||
|
|
||||||
|
data URLSource = GHCupURL
|
||||||
|
| OwnSource URL
|
||||||
|
| OwnSpec AvailableDownloads
|
||||||
|
@ -1,18 +0,0 @@
|
|||||||
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)
|
|
@ -11,30 +11,19 @@ module GHCup.Types.JSON where
|
|||||||
|
|
||||||
import Data.Strict.Maybe
|
import Data.Strict.Maybe
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import Generics.SOP.TH
|
import Prelude hiding ( Maybe )
|
||||||
import Prelude hiding (
|
import Data.Versions
|
||||||
Maybe
|
import Data.Aeson
|
||||||
, Just
|
import Data.Aeson.TH
|
||||||
, Nothing)
|
|
||||||
import Waargonaut.Generic (
|
|
||||||
JsonEncode
|
|
||||||
, JsonDecode
|
|
||||||
, GWaarg)
|
|
||||||
|
|
||||||
|
|
||||||
deriveGeneric ''Maybe
|
deriveJSON defaultOptions ''Architecture
|
||||||
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a)
|
deriveJSON defaultOptions ''LinuxDistro
|
||||||
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a)
|
deriveJSON defaultOptions ''Maybe
|
||||||
|
deriveJSON defaultOptions ''Mess
|
||||||
deriveGeneric ''Tool
|
deriveJSON defaultOptions ''SemVer
|
||||||
instance JsonEncode GWaarg Tool
|
deriveJSON defaultOptions ''Tool
|
||||||
instance JsonDecode GWaarg Tool
|
deriveJSON defaultOptions ''VSep
|
||||||
|
deriveJSON defaultOptions ''VUnit
|
||||||
deriveGeneric ''Architecture
|
deriveJSON defaultOptions ''Version
|
||||||
instance JsonEncode GWaarg Architecture
|
deriveJSON defaultOptions ''Versioning
|
||||||
instance JsonDecode GWaarg Architecture
|
|
||||||
|
|
||||||
deriveGeneric ''LinuxDistro
|
|
||||||
instance JsonEncode GWaarg LinuxDistro
|
|
||||||
instance JsonDecode GWaarg LinuxDistro
|
|
||||||
|
|
||||||
|
@ -2,4 +2,15 @@
|
|||||||
|
|
||||||
module GHCup.Types.Optics where
|
module GHCup.Types.Optics where
|
||||||
|
|
||||||
|
import GHCup.Types
|
||||||
|
import Optics
|
||||||
|
|
||||||
|
makePrisms ''Tool
|
||||||
|
makePrisms ''Architecture
|
||||||
|
makePrisms ''LinuxDistro
|
||||||
|
makePrisms ''Platform
|
||||||
|
|
||||||
|
makeLenses ''PlatformResult
|
||||||
|
makeLenses ''ToolRequest
|
||||||
|
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user