Basic version of 'downloadURL'
This commit is contained in:
Julian Ospald
parent
3fb5c612c1
commit
92531045f8
33
README.md
33
README.md
|
|
@ -1 +1,34 @@
|
|||
# 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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
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
|
||||
location: https://github.com/hasufell/ghcup-hs
|
||||
|
||||
common aeson { build-depends: aeson >= 1.4 }
|
||||
common ascii-string { build-depends: ascii-string >= 1.0 }
|
||||
common base { build-depends: base >= 4.12.0.0 && < 5 }
|
||||
common bytestring { build-depends: bytestring >= 0.10 }
|
||||
|
|
@ -36,12 +37,16 @@ common streamly { build-depends: streamly >= 0.7 }
|
|||
common strict-base { build-depends: strict-base >= 0.4 }
|
||||
common template-haskell { build-depends: template-haskell >= 2.7 }
|
||||
common text { build-depends: text >= 1.2 }
|
||||
common text-icu { build-depends: text-icu >= 0.7 }
|
||||
common transformers { build-depends: transformers >= 0.5 }
|
||||
common unix { build-depends: unix >= 2.7 }
|
||||
common url { build-depends: url >= 2.1 }
|
||||
common utf8-string { build-depends: utf8-string >= 1.0 }
|
||||
common vector { build-depends: vector >= 0.12 }
|
||||
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||
common async { build-depends: async >= 0.8 }
|
||||
common mtl { build-depends: mtl >= 2.2 }
|
||||
common versions { build-depends: versions >= 3.5 }
|
||||
|
||||
|
||||
common config
|
||||
|
|
@ -53,7 +58,9 @@ library
|
|||
import: config
|
||||
, base
|
||||
-- deps
|
||||
, aeson
|
||||
, ascii-string
|
||||
, async
|
||||
, bytestring
|
||||
, containers
|
||||
, generics-sop
|
||||
|
|
@ -61,6 +68,7 @@ library
|
|||
, hpath-filepath
|
||||
, hpath-io
|
||||
, language-bash
|
||||
, mtl
|
||||
, optics
|
||||
, parsec
|
||||
, safe-exceptions
|
||||
|
|
@ -68,12 +76,13 @@ library
|
|||
, strict-base
|
||||
, template-haskell
|
||||
, text
|
||||
, text-icu
|
||||
, transformers
|
||||
, unix
|
||||
, url
|
||||
, utf8-string
|
||||
, vector
|
||||
, waargonaut
|
||||
, versions
|
||||
exposed-modules: GHCup
|
||||
GHCup.Bash
|
||||
GHCup.File
|
||||
|
|
|
|||
233
lib/GHCup.hs
233
lib/GHCup.hs
|
|
@ -10,44 +10,46 @@
|
|||
-- TODO: handle SIGTERM, SIGUSR
|
||||
module GHCup where
|
||||
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Strict.Maybe
|
||||
import Data.Version
|
||||
import GHCup.Prelude
|
||||
import Control.Monad
|
||||
import Data.Foldable ( asum )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import GHCup.Bash
|
||||
import GHCup.File
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Network.URL
|
||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, Maybe
|
||||
, Just
|
||||
, Nothing
|
||||
, readFile
|
||||
)
|
||||
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 GHC.Exts as GE
|
||||
import qualified Prelude as P
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
|
||||
|
||||
|
||||
availableDownloads :: AvailableDownloads
|
||||
availableDownloads = Map.fromList
|
||||
[ ( GHC
|
||||
, Map.fromList
|
||||
[ ( mkV [8, 6, 5]
|
||||
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
|
||||
, Map.fromList
|
||||
[ ( A_64
|
||||
, Map.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
||||
, 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
|
||||
mkV = makeVersion
|
||||
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_params = []
|
||||
}
|
||||
|
||||
downloadURL :: Tool
|
||||
-> Version
|
||||
-> Architecture
|
||||
-> Platform
|
||||
-> AvailableDownloads
|
||||
-> Maybe URL
|
||||
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro
|
||||
|
||||
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
|
||||
-- ^ tool version
|
||||
-> Architecture
|
||||
-- ^ user arch
|
||||
-> Platform
|
||||
-- ^ user platform
|
||||
-> Maybe Versioning
|
||||
-- ^ optional version of the platform
|
||||
-> AvailableDownloads
|
||||
-> Maybe URL
|
||||
downloadURL' t v a p mv dls =
|
||||
with_distro <|> without_distro_ver <|> without_distro
|
||||
|
||||
where
|
||||
with_distro = distro_preview id
|
||||
without_distro = distro_preview withoutDistro
|
||||
without_ver = distro_preview withoutVer
|
||||
with_distro = distro_preview id id
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
|
||||
distro_preview f =
|
||||
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls
|
||||
distro_preview f g =
|
||||
preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
|
||||
atJust x = at x % _Just
|
||||
|
||||
-- | If we can't find a version with the given distro,
|
||||
-- then just try with the platform.
|
||||
withoutDistro :: Platform -> Platform
|
||||
withoutDistro (Linux _) = Linux UnknownLinux
|
||||
withoutDistro Darwin = Darwin
|
||||
withoutDistro (FreeBSD _) = FreeBSD Nothing
|
||||
|
||||
-- | If we can't find a match with the given distro version,
|
||||
-- we gotta try without it.
|
||||
withoutVer :: Platform -> Platform
|
||||
withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing
|
||||
withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing
|
||||
withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing
|
||||
withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing
|
||||
withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux
|
||||
withoutVer Darwin = Darwin
|
||||
withoutVer (FreeBSD _) = FreeBSD Nothing
|
||||
|
||||
|
||||
getArchitecture :: IO Architecture
|
||||
getArchitecture :: Either String Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> pure A_64
|
||||
"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
|
||||
"linux" -> do
|
||||
distro <- getLinuxDistro
|
||||
pure $ Linux distro
|
||||
(distro, ver) <- getLinuxDistro
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
-- TODO: these are not verified
|
||||
"darwin" -> pure $ Darwin
|
||||
"darwin" ->
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ FreeBSD ver
|
||||
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 (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
|
||||
getLinuxDistro :: IO LinuxDistro
|
||||
getLinuxDistro = do
|
||||
let os_release = [abs|/etc/os-release|]
|
||||
lsb_release = [abs|/etc/lsb-release|]
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
hasWord t matches = foldr
|
||||
(\x y ->
|
||||
( isJust
|
||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
|
||||
$ t
|
||||
)
|
||||
|| y
|
||||
)
|
||||
False
|
||||
matches
|
||||
|
||||
pure undefined
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
lsb_release :: Path Abs
|
||||
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|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
getFreeBSDVersion = pure Nothing
|
||||
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 various methods for getting distro name and version.
|
||||
-- Failure is signalled with an IO exception.
|
||||
try_os_release :: IO (String, P.Maybe String)
|
||||
try_os_release = do
|
||||
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case
|
||||
P.Just s -> pure $ s
|
||||
P.Nothing -> fail "No value found"
|
||||
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID"
|
||||
pure (name, version)
|
||||
try_lsb_release_cmd :: IO (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.Word
|
||||
import Language.Bash.Parse
|
||||
import Language.Bash.Word
|
||||
import Language.Bash.Syntax
|
||||
import Text.Parsec
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Data.ByteString.UTF8 ( toString )
|
||||
import Streamly
|
||||
import GHCup.File
|
||||
import GHCup.Prelude ( internalError )
|
||||
import qualified Streamly.Prelude as S
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
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.
|
||||
parseAssignment :: SourceName -- ^ file/location of the parser
|
||||
-> ByteString -- ^ the line as a bytestring
|
||||
-> Either ParseError Assign
|
||||
parseAssignment = runParser assign ()
|
||||
extractAssignments :: List -> [Assign]
|
||||
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||
where
|
||||
getCommands :: [Statement] -> [Command]
|
||||
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||
where
|
||||
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||
findPipes _ = Nothing
|
||||
|
||||
|
||||
-- | Parse assignments in a stream.
|
||||
parseAssignments :: Monad m
|
||||
=> SourceName -- ^ file/location of the parser
|
||||
-> SerialT m (ByteString)
|
||||
-> SerialT m (Either ParseError Assign)
|
||||
parseAssignments sn = fmap (parseAssignment sn)
|
||||
getAssign :: Command -> [Assign]
|
||||
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||
getAssign _ = []
|
||||
|
||||
|
||||
-- | Find an assignment matching the predicate in the given file.
|
||||
findAssignment :: Path b
|
||||
-> (Assign -> Bool) -- ^ predicate
|
||||
-> IO (Maybe Assign)
|
||||
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||
findAssignment p predicate = do
|
||||
let fn' = toString . toFilePath $ p
|
||||
stream <- fmap (parseAssignments fn') $ readFileLines p
|
||||
res <-
|
||||
S.find -- empties the stream on first match, but doesn't terminate it
|
||||
(\case
|
||||
Right ass -> predicate ass
|
||||
Left _ -> False
|
||||
)
|
||||
stream
|
||||
>>= \case
|
||||
Just (Right x) -> pure (Just x)
|
||||
Just (Left _) ->
|
||||
internalError "unexpected Left in findAssignment"
|
||||
Nothing -> pure Nothing
|
||||
-- Closes the file handle. Because if there was a match, then
|
||||
-- the stream is not terminated.
|
||||
when (isJust res) $ S.drain stream
|
||||
pure res
|
||||
fileContents <- readFile p
|
||||
-- TODO: this should accept bytestring:
|
||||
-- https://github.com/knrafto/language-bash/issues/37
|
||||
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||
Left e -> fail $ show e
|
||||
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||
|
||||
|
||||
-- | Check that the assignment is of the form Foo= ignoring the
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module GHCup.File where
|
||||
|
||||
import Data.ByteString hiding (putStrLn)
|
||||
import Data.ByteString
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
|
|
@ -14,7 +14,9 @@ import Control.Monad
|
|||
import Control.Exception.Safe
|
||||
import Data.Functor
|
||||
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
|
||||
as SPPB
|
||||
import System.Posix.Types
|
||||
|
|
@ -24,19 +26,11 @@ import qualified Streamly.Internal.Memory.ArrayStream
|
|||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.Data.Unfold as SU
|
||||
import qualified Streamly.Prelude as S
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import qualified Streamly.Data.Fold as FL
|
||||
import Data.ByteString.Builder
|
||||
import Foreign.C.Error
|
||||
import GHCup.Prelude
|
||||
import Control.Monad.Trans.Maybe
|
||||
import HPath.Internal
|
||||
import System.Posix.FD
|
||||
(
|
||||
openFd
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- |Checks whether a file is executable. Follows symlinks.
|
||||
|
|
@ -66,20 +60,12 @@ readFd fd = do
|
|||
-- terminates (either through exception or because it's drained).
|
||||
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||
readFileLines p = do
|
||||
stream <- readFileStream' p
|
||||
stream <- readFileStream p
|
||||
pure
|
||||
. (>>= arrayToByteString)
|
||||
. AS.splitOn (fromIntegral $ ord '\n')
|
||||
. (>>= byteStringToArray)
|
||||
$ stream
|
||||
where
|
||||
readFileStream' :: Path b
|
||||
-> IO (SerialT IO ByteString)
|
||||
readFileStream' (MkPath fp) = do
|
||||
fd <- openFd fp ReadOnly [] Nothing
|
||||
handle' <- fdToHandle fd
|
||||
let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString
|
||||
pure stream
|
||||
|
||||
|
||||
-- | Find the given executable by searching all *absolute* PATH components.
|
||||
|
|
@ -92,42 +78,32 @@ findExecutable ex = do
|
|||
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||
-- We don't want exceptions to mess up our result. If we can't
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
|
||||
sPaths
|
||||
|
||||
|
||||
findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs))
|
||||
findExecutablee ex = do
|
||||
sPaths <- mapMaybe parseAbs <$> getSearchPath
|
||||
runMaybeT $ asum (MaybeT . eExists <$> sPaths)
|
||||
where
|
||||
eExists sp = let path = sp </> ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path
|
||||
|
||||
|
||||
-- TODO: fd leak
|
||||
-- | Execute the given command and collect the stdout and the exit code.
|
||||
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
||||
executeOut path args = withFnPath path $ \fp -> do
|
||||
(readE, writeE) <- createPipe
|
||||
pid <- SPPB.forkProcess $ do
|
||||
(parentRead, childWrite) <- createPipe
|
||||
pid <- SPPB.forkProcess $ do
|
||||
whileM_
|
||||
(dupTo writeE stdOutput)
|
||||
(dupTo childWrite stdOutput)
|
||||
(\r ->
|
||||
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
|
||||
)
|
||||
closeFd writeE
|
||||
closeFd readE
|
||||
closeFd childWrite
|
||||
closeFd parentRead
|
||||
closeFd stdInput
|
||||
SPPB.executeFile fp True args Nothing
|
||||
|
||||
closeFd writeE
|
||||
closeFd childWrite
|
||||
|
||||
-- readFd will take care of closing the fd
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
Just (SPPB.Exited es) -> do
|
||||
out <- readFd readE
|
||||
pure $ Just (out, es)
|
||||
_ -> pure Nothing
|
||||
-- readE will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
|
||||
_ -> closeFd parentRead $> Nothing
|
||||
|
|
|
|||
|
|
@ -5,16 +5,21 @@
|
|||
module GHCup.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Strict.Maybe
|
||||
import Data.Monoid ( (<>) )
|
||||
import Prelude ( Monad
|
||||
, Bool
|
||||
, return
|
||||
, (.)
|
||||
, (>>=)
|
||||
)
|
||||
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
|
||||
|
|
@ -23,9 +28,15 @@ fS = fromString
|
|||
fromStrictMaybe :: Maybe a -> P.Maybe a
|
||||
fromStrictMaybe = maybe P.Nothing P.Just
|
||||
|
||||
fSM :: Maybe a -> P.Maybe a
|
||||
fSM = fromStrictMaybe
|
||||
|
||||
toStrictMaybe :: P.Maybe a -> Maybe a
|
||||
toStrictMaybe = P.maybe Nothing Just
|
||||
|
||||
tSM :: P.Maybe a -> Maybe a
|
||||
tSM = toStrictMaybe
|
||||
|
||||
instance Applicative Maybe where
|
||||
pure = Just
|
||||
|
||||
|
|
@ -61,6 +72,17 @@ ifM ~b ~t ~f = do
|
|||
b' <- b
|
||||
if b' then t else f
|
||||
|
||||
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||
whileM_ action f = whenM (action >>= f) (whileM_ action f)
|
||||
whileM :: Monad m => m a -> (a -> m Bool) -> m a
|
||||
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
|
||||
|
|
|
|||
|
|
@ -2,50 +2,66 @@
|
|||
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Strict.Maybe
|
||||
import Data.Text
|
||||
import Data.Version
|
||||
import Network.URL
|
||||
import Prelude hiding (
|
||||
Maybe
|
||||
, Just
|
||||
, Nothing)
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
import Data.Map.Strict ( Map )
|
||||
import Network.URL
|
||||
import qualified GHC.Generics as GHC
|
||||
import Data.Versions
|
||||
|
||||
|
||||
-- | Requested tool to be installed. User input.
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| Stack
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Architecture we run on.
|
||||
data ToolRequest = ToolRequest {
|
||||
_tool :: Tool
|
||||
, _toolVersion :: Version
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data LinuxDistro = Debian (Maybe CustomVersion)
|
||||
| Ubuntu (Maybe CustomVersion)
|
||||
| Mint (Maybe CustomVersion)
|
||||
| Fedora (Maybe CustomVersion)
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
| Mint
|
||||
| Fedora
|
||||
| CentOS
|
||||
| RedHat
|
||||
| Alpine
|
||||
-- rolling
|
||||
| Gentoo
|
||||
| Exherbo
|
||||
-- not known
|
||||
| UnknownLinux
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD (Maybe CustomVersion)
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
type CustomVersion = Text
|
||||
type PlatformSpec = Map Platform URL
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type VersionSpec = Map Version ArchitectureSpec
|
||||
type AvailableDownloads = Map Tool VersionSpec
|
||||
data PlatformResult = PlatformResult {
|
||||
_platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
} deriving (Eq, Show)
|
||||
|
||||
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)
|
||||
|
|
@ -9,32 +9,21 @@
|
|||
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import Data.Strict.Maybe
|
||||
import GHCup.Types
|
||||
import Generics.SOP.TH
|
||||
import Prelude hiding (
|
||||
Maybe
|
||||
, Just
|
||||
, Nothing)
|
||||
import Waargonaut.Generic (
|
||||
JsonEncode
|
||||
, JsonDecode
|
||||
, GWaarg)
|
||||
import Data.Strict.Maybe
|
||||
import GHCup.Types
|
||||
import Prelude hiding ( Maybe )
|
||||
import Data.Versions
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
|
||||
|
||||
deriveGeneric ''Maybe
|
||||
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a)
|
||||
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a)
|
||||
|
||||
deriveGeneric ''Tool
|
||||
instance JsonEncode GWaarg Tool
|
||||
instance JsonDecode GWaarg Tool
|
||||
|
||||
deriveGeneric ''Architecture
|
||||
instance JsonEncode GWaarg Architecture
|
||||
instance JsonDecode GWaarg Architecture
|
||||
|
||||
deriveGeneric ''LinuxDistro
|
||||
instance JsonEncode GWaarg LinuxDistro
|
||||
instance JsonDecode GWaarg LinuxDistro
|
||||
|
||||
deriveJSON defaultOptions ''Architecture
|
||||
deriveJSON defaultOptions ''LinuxDistro
|
||||
deriveJSON defaultOptions ''Maybe
|
||||
deriveJSON defaultOptions ''Mess
|
||||
deriveJSON defaultOptions ''SemVer
|
||||
deriveJSON defaultOptions ''Tool
|
||||
deriveJSON defaultOptions ''VSep
|
||||
deriveJSON defaultOptions ''VUnit
|
||||
deriveJSON defaultOptions ''Version
|
||||
deriveJSON defaultOptions ''Versioning
|
||||
|
|
|
|||
|
|
@ -2,4 +2,15 @@
|
|||
|
||||
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