diff --git a/ghcup.cabal b/ghcup.cabal index 85ec8c8..f1be5ef 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 3521717..a533b5c 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -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 diff --git a/lib/GHCup/Utils/Bash.hs b/lib/GHCup/Utils/Bash.hs deleted file mode 100644 index 32a622e..0000000 --- a/lib/GHCup/Utils/Bash.hs +++ /dev/null @@ -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) diff --git a/lib/GHCup/Utils/OsRelease.hs b/lib/GHCup/Utils/OsRelease.hs new file mode 100644 index 0000000..ff582df --- /dev/null +++ b/lib/GHCup/Utils/OsRelease.hs @@ -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