Merge branch 'less-bash'

.gitlab-ci.yml

@@ -2,7 +2,7 @@ variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
+  DOCKER_REV: 1ac7f435c9312f10422a82d304194778378e2a1a
 
 ############################################################
 # CI Step

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

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
@@ -115,7 +115,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
     ]
@@ -140,10 +139,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
@@ -153,9 +148,8 @@ getLinuxDistro = do
 
   try_os_release :: IO (Text, Maybe Text)
   try_os_release = do
-    (Just name) <- getAssignmentValueFor os_release "NAME"
+    OsRelease { name = Just n, version_id = v } <- parseOsRelease
-    ver         <- getAssignmentValueFor os_release "VERSION_ID"
+    pure (T.pack n, fmap T.pack v)
-    pure (T.pack name, fmap T.pack ver)
 
   try_lsb_release_cmd :: IO (Text, Maybe Text)
   try_lsb_release_cmd = do
@@ -164,12 +158,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

lib/GHCup/Utils/Bash.hs

@@ -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)

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