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

Get rid of language-bash 

And clean up detection logic a bit. We also don't
read /etc/lsb-release manually more, since it's format is
not specified.
This commit is contained in:
Julian Ospald 2020-06-25 19:01:38 +02:00
parent c502f70f68
commit 2de549862a
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 172 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
ghcup.cabal
View File

@ -98,9 +98,6 @@ common http-io-streams
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
@ -182,6 +179,9 @@ common unix
common unix-bytestring
build-depends: unix-bytestring >=0.3
common unordered-containers
build-depends: unordered-containers >= 0.2.10.0
common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2
@ -194,9 +194,6 @@ common vector
common versions
build-depends: versions >=3.5
common waargonaut
build-depends: waargonaut >=0.8
common word8
build-depends: word8 >=0.1.3
@ -242,7 +239,6 @@ library
, hpath-filepath
, hpath-io
, hpath-posix
, language-bash
, lzma
, megaparsec
, monad-logger
@ -267,6 +263,7 @@ library
, transformers
, unix
, unix-bytestring
, unordered-containers
, uri-bytestring
, utf8-string
, vector
@ -288,7 +285,7 @@ library
GHCup.Types.JSON
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.OsRelease
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.Logger

18
lib/GHCup/Platform.hs
View File

@ -12,7 +12,7 @@ module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.OsRelease
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
@ -111,7 +111,6 @@ 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
]
@ -136,10 +135,6 @@ getLinuxDistro = do
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
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
@ -149,9 +144,8 @@ getLinuxDistro = do
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)
OsRelease { name = Just n, version_id = v } <- parseOsRelease
pure (T.pack n, fmap T.pack v)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
@ -160,12 +154,6 @@ getLinuxDistro = do
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe name, Just $ decUTF8Safe 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 decUTF8Safe' $ readFile redhat_release

69
lib/GHCup/Utils/Bash.hs
View File

@ -1,69 +0,0 @@
module GHCup.Utils.Bash
( findAssignment
, equalsAssignmentWith
, getRValue
, getAssignmentValueFor
)
where
import Control.Monad
import Data.ByteString.UTF8 ( toString )
import Data.List
import Data.Maybe
import HPath
import HPath.IO
import Language.Bash.Parse
import Language.Bash.Syntax
import Language.Bash.Word
import Prelude hiding ( readFile )
import qualified Data.ByteString.Lazy.UTF8 as UTF8
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
getAssign :: Command -> [Assign]
getAssign (Command (SimpleCommand ass _) _) = ass
getAssign _ = []
-- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
findAssignment p predicate = do
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
-- right hand-side.
equalsAssignmentWith :: String -> Assign -> Bool
equalsAssignmentWith n ass = case ass of
(Assign (Parameter name' Nothing) Equals _) -> n == name'
_ -> False
-- | This pretty-prints the right hand of an Equals assignment, removing
-- quotations. No evaluation is performed.
getRValue :: Assign -> Maybe String
getRValue ass = case ass of
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
_ -> Nothing
-- | Given a bash assignment such as Foo="Bar" in the given file,
-- will return "Bar" (without quotations).
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
getAssignmentValueFor p n = do
mass <- findAssignment p (equalsAssignmentWith n)
pure (mass >>= getRValue)

164
lib/GHCup/Utils/OsRelease.hs Normal file
View File

@ -0,0 +1,164 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | A module to retrieve os-release information according to the
-- freedesktop standard:
-- https://www.freedesktop.org/software/systemd/man/os-release.html
--
-- Some of it is stolen from:
-- https://hackage.haskell.org/package/os-release-0.2.2/docs/src/System-OsRelease.html
module GHCup.Utils.OsRelease where
import GHCup.Utils.MegaParsec
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Aeson.TH
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Data.Void
import HPath
import HPath.IO
import Prelude hiding ( abs
, readFile
)
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MP
-- | All the explicitly documented fields of `os-release`.
data OsRelease = OsRelease {
name :: Maybe String
, version :: Maybe String
, id :: Maybe String
, id_like :: Maybe String
, version_codename :: Maybe String
, version_id :: Maybe String
, pretty_name :: Maybe String
, ansi_color :: Maybe String
, cpe_name :: Maybe String
, home_url :: Maybe String
, documentation_url :: Maybe String
, support_url :: Maybe String
, bug_report_url :: Maybe String
, privacy_policy_url :: Maybe String
, build_id :: Maybe String
, variant :: Maybe String
, variant_id :: Maybe String
, logo :: Maybe String
} deriving (Show)
emptyOsRelease :: OsRelease
emptyOsRelease = OsRelease { name = Nothing
, version = Nothing
, id = Nothing
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = Nothing
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Nothing
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Nothing
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
-- | Parse a single line assignment and extract the right hand side.
-- This is only a subset of a shell parser, see
-- https://www.freedesktop.org/software/systemd/man/os-release.html
parseAssignment :: MP.Parsec Void String (String, String)
parseAssignment =
(,)
<$> (MP.space *> key)
<*> (MP.char '=' *> (MP.try qval <|> mempty) <* MP.space <* MP.eof)
where
dropSpace :: String -> String
dropSpace = reverse . dropWhile (\x -> x == ' ' || x == '\t') . reverse
key :: MP.Parsec Void String String
key = some (MP.try MP.alphaNumChar <|> MP.char '_')
qval :: MP.Parsec Void String String
qval = do
c <- MP.lookAhead MP.printChar
case c of
' ' -> pure ""
'"' -> MP.char c *> val c <* MP.char c
'\'' -> MP.char c *> val c <* MP.char c
-- no quote, have to drop trailing spaces
_ -> fmap dropSpace (some MP.alphaNumChar)
val :: Char -> MP.Parsec Void String String
val q = many (qspecial q <|> MP.noneOf (specials q)) -- noneOf may be too lax
qspecial :: Char -> MP.Parsec Void String Char
qspecial q =
fmap (!! 1)
. choice'
. fmap (\s -> MP.try . MP.chunk $ ['\\', s])
$ (specials q)
specials :: Char -> [Char]
specials q = [q, '\\', '$', '`']
-- | Get all allAssignments as `(key, val)` from the `os-release`
-- file contents.
allAssignments :: String -- ^ file contents of os-release
-> [(String, String)]
allAssignments = rights . fmap (MP.parse parseAssignment "") . lines
-- | Parse the assignments into OsRelease.
--
-- This can't fail and will create an "empty" product type instead on
-- failure.
osRelease :: [(String, String)] -- ^ assignments
-> OsRelease
osRelease =
(\case
Error _ -> emptyOsRelease
Success v -> v
)
. fromJSON
. Object
. HM.fromList
. fmap (\(k, v) -> (T.toLower . T.pack $ k, String . T.pack $ v))
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order.
-- Throws an exception if both files do not exist.
readOsRelease :: IO String
readOsRelease = do
let os_release1 :: Path Abs
os_release1 = [abs|/etc/os-release|]
let os_release2 :: Path Abs
os_release2 = [abs|/usr/lib/os-release|]
bs <- readFile os_release1 <|> readFile os_release2
-- os-release is utf8
pure . UTF8.toString $ bs
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order
-- and parses into `OsRelease`. Throws an exception if both files do not
-- exist.
parseOsRelease :: IO OsRelease
parseOsRelease = fmap (osRelease . allAssignments) readOsRelease
deriveJSON defaultOptions ''OsRelease