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.

.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

app/ghcup/Main.hs

@@ -1425,13 +1425,6 @@ Version: #{describe_result}|]
   prettyArch :: Architecture -> String
   prettyArch A_64 = "amd64"
   prettyArch A_32 = "i386"
-  prettyArch A_PowerPC = "PowerPC"
-  prettyArch A_PowerPC64 = "PowerPC64"
-  prettyArch A_Sparc = "Sparc"
-  prettyArch A_Sparc64 = "Sparc64"
-  prettyArch A_ARM = "ARM"
-  prettyArch A_ARM64 = "ARM64"
-
   prettyPlatform :: PlatformResult -> String
   prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
     = show plat <> ", " <> show v'

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
@@ -48,7 +48,10 @@ import qualified Data.Text                     as T
 -- | Get the full platform request, consisting of architecture, distro, ...
 platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
                 => Excepts
-                     '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
+                     '[ NoCompatiblePlatform
+                      , NoCompatibleArch
+                      , DistroNotFound
+                      ]
                      m
                      PlatformRequest
 platformRequest = do
@@ -59,21 +62,15 @@ platformRequest = do
 
 getArchitecture :: Either NoCompatibleArch Architecture
 getArchitecture = case arch of
-  "x86_64"      -> Right A_64
-  "i386"        -> Right A_32
-  "powerpc"     -> Right A_PowerPC
-  "powerpc64"   -> Right A_PowerPC64
-  "powerpc64le" -> Right A_PowerPC64
-  "sparc"       -> Right A_Sparc
-  "sparc64"     -> Right A_Sparc64
-  "arm"         -> Right A_ARM
-  "aarch64"     -> Right A_ARM64
-  what          -> Left (NoCompatibleArch what)
+  "x86_64" -> Right A_64
+  "i386"   -> Right A_32
+  what     -> Left (NoCompatibleArch what)
+
 
 
 getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Excepts
-                 '[NoCompatiblePlatform, DistroNotFound]
+                 '[NoCompatiblePlatform , DistroNotFound]
                  m
                  PlatformResult
 getPlatform = do
@@ -85,7 +82,6 @@ getPlatform = do
       ver <-
         ( either (const Nothing) Just
           . versioning
-          -- TODO: maybe do this somewhere else
           . getMajorVersion
           . decUTF8Safe
           )
@@ -115,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
     ]
@@ -140,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
@@ -153,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
@@ -164,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

lib/GHCup/Types.hs

@@ -90,12 +90,6 @@ data Tag = Latest
 
 data Architecture = A_64
                   | A_32
-                  | A_PowerPC
-                  | A_PowerPC64
-                  | A_Sparc
-                  | A_Sparc64
-                  | A_ARM
-                  | A_ARM64
   deriving (Eq, GHC.Generic, Ord, Show)
 
 

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