Merge branch 'opensuse'

lib/GHCup/Platform.hs

@@ -49,7 +49,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.Info
-import           System.OsRelease
+import           System.OsRelease as OSR
 import           System.Exit
 import           System.FilePath
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -134,33 +134,34 @@ getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
                => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
 getLinuxDistro = do
   -- TODO: don't do alternative on IO, because it hides bugs
-  (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
+  (name, mid, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
     [ liftIO try_os_release
     , try_lsb_release_cmd
     , liftIO try_redhat_release
     , liftIO try_debian_version
     ]
+  let hasWord xs = let f t = any (\x -> match (regex x) (T.unpack t)) xs
+                   in f name || maybe False f mid
   let parsedVer = ver >>= either (const Nothing) Just . versioning
       distro    = if
-        | hasWord name ["debian"]  -> Debian
-        | hasWord name ["ubuntu"]  -> Ubuntu
-        | hasWord name ["linuxmint", "Linux Mint"] -> Mint
-        | hasWord name ["fedora"]  -> Fedora
-        | hasWord name ["centos"]  -> CentOS
-        | hasWord name ["Red Hat"] -> RedHat
-        | hasWord name ["alpine"]  -> Alpine
-        | hasWord name ["exherbo"] -> Exherbo
-        | hasWord name ["gentoo"]  -> Gentoo
-        | hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
-        | hasWord name ["rocky", "Rocky Linux"] -> Rocky
+        | hasWord ["debian"]  -> Debian
+        | hasWord ["ubuntu"]  -> Ubuntu
+        | hasWord ["linuxmint", "Linux Mint"] -> Mint
+        | hasWord ["fedora"]  -> Fedora
+        | hasWord ["centos"]  -> CentOS
+        | hasWord ["Red Hat"] -> RedHat
+        | hasWord ["alpine"]  -> Alpine
+        | hasWord ["exherbo"] -> Exherbo
+        | hasWord ["gentoo"]  -> Gentoo
+        | hasWord ["opensuse", "suse"]  -> OpenSUSE
+        | hasWord ["amazonlinux", "Amazon Linux"] -> AmazonLinux
+        | hasWord ["rocky", "Rocky Linux"] -> Rocky
         -- https://github.com/void-linux/void-packages/blob/master/srcpkgs/base-files/files/os-release
-        | hasWord name ["void", "Void Linux"] -> Void
-        | otherwise                -> UnknownLinux
+        | hasWord ["void", "Void Linux"] -> Void
+        | otherwise -> OtherLinux (T.unpack $ fromMaybe name mid)
   pure (distro, parsedVer)
  where
-  hasWord t = any (\x -> match (regex x) (T.unpack t))
-   where
-    regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
+  regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
 
   lsb_release_cmd :: FilePath
   lsb_release_cmd = "lsb-release"
@@ -169,21 +170,21 @@ getLinuxDistro = do
   debian_version :: FilePath
   debian_version = "/etc/debian_version"
 
-  try_os_release :: IO (Text, Maybe Text)
+  try_os_release :: IO (Text, Maybe Text, Maybe Text)
   try_os_release = do
-    Just OsRelease{ name = name, version_id = version_id } <-
+    Just OsRelease{ name = name, version_id = version_id, OSR.id = id' } <-
       fmap osRelease <$> parseOsRelease
-    pure (T.pack name, fmap T.pack version_id)
+    pure (T.pack name, Just (T.pack id'), fmap T.pack version_id)
 
   try_lsb_release_cmd :: (MonadFail m, MonadIO m)
-                      => m (Text, Maybe Text)
+                      => m (Text, Maybe Text, Maybe Text)
   try_lsb_release_cmd = do
     (Just _) <- liftIO $ findExecutable lsb_release_cmd
     name     <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
     ver      <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
-    pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
+    pure (decUTF8Safe' name, Nothing, Just $ decUTF8Safe' ver)
 
-  try_redhat_release :: IO (Text, Maybe Text)
+  try_redhat_release :: IO (Text, Maybe Text, Maybe Text)
   try_redhat_release = do
     t <- T.readFile redhat_release
     let nameRegex n =
@@ -199,16 +200,16 @@ getLinuxDistro = do
         verRe = fromEmpty . match verRegex $ T.unpack t :: Maybe String
     (Just name) <- pure
       (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
-    pure (T.pack name, fmap T.pack verRe)
+    pure (T.pack name, Nothing, fmap T.pack verRe)
    where
     fromEmpty :: String -> Maybe String
     fromEmpty "" = Nothing
     fromEmpty s' = Just s'
 
-  try_debian_version :: IO (Text, Maybe Text)
+  try_debian_version :: IO (Text, Maybe Text, Maybe Text)
   try_debian_version = do
     ver <- T.readFile debian_version
-    pure (T.pack "debian", Just ver)
+    pure (T.pack "debian", Just (T.pack "debian"), Just ver)
 
 
 getStackGhcBuilds :: (MonadReader env m, HasLog env, MonadIO m)

lib/GHCup/Types.hs

@@ -257,10 +257,49 @@ data LinuxDistro = Debian
                  -- rolling
                  | Gentoo
                  | Exherbo
+                 | OpenSUSE
                  -- not known
                  | UnknownLinux
                  -- ^ must exit
-  deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
+                 | OtherLinux String
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+instance Enum LinuxDistro where
+  toEnum 0 = Debian
+  toEnum 1 = Ubuntu
+  toEnum 2 = Mint
+  toEnum 3 = Fedora
+  toEnum 4 = CentOS
+  toEnum 5 = RedHat
+  toEnum 6 = Alpine
+  toEnum 7 = AmazonLinux
+  toEnum 8 = Rocky
+  toEnum 9 = Void
+  toEnum 10 = Gentoo
+  toEnum 11 = Exherbo
+  toEnum 12 = OpenSUSE
+  toEnum 13 = UnknownLinux
+  toEnum _ = error "toEnum: out of bounds"
+
+  fromEnum Debian = 0
+  fromEnum Ubuntu = 1
+  fromEnum Mint = 2
+  fromEnum Fedora = 3
+  fromEnum CentOS = 4
+  fromEnum RedHat = 5
+  fromEnum Alpine = 6
+  fromEnum AmazonLinux = 7
+  fromEnum Rocky = 8
+  fromEnum Void = 9
+  fromEnum Gentoo = 10
+  fromEnum Exherbo = 11
+  fromEnum OpenSUSE = 12
+  fromEnum UnknownLinux = 13
+  fromEnum (OtherLinux _) = error "fromEnum: OtherLinux"
+
+instance Bounded LinuxDistro where
+  minBound = Debian
+  maxBound = UnknownLinux
 
 allDistros :: [LinuxDistro]
 allDistros = enumFromTo minBound maxBound
@@ -280,7 +319,9 @@ distroToString Rocky = "rocky"
 distroToString Void = "void"
 distroToString Gentoo = "gentoo"
 distroToString Exherbo = "exherbo"
+distroToString OpenSUSE = "opensuse"
 distroToString UnknownLinux = "unknown"
+distroToString (OtherLinux str) = str
 
 instance Pretty LinuxDistro where
   pPrint = text . distroToString

lib/GHCup/Types/JSON.hs

@@ -48,10 +48,30 @@ import qualified Data.Text.Encoding.Error      as E
 import qualified Text.Megaparsec               as MP
 import qualified Text.Megaparsec.Char          as MPC
 
+instance ToJSON LinuxDistro where
+  toJSON (OtherLinux x) = String (T.pack x)
+  toJSON x = String . T.pack . show $ x
+
+instance FromJSON LinuxDistro where
+  parseJSON = withText "LinuxDistro" $ \t -> case T.unpack (T.toLower t) of
+    "debian"   -> pure Debian
+    "ubuntu"   -> pure Ubuntu
+    "mint"     -> pure Mint
+    "fedora"   -> pure Fedora
+    "centos"   -> pure CentOS
+    "redhat"   -> pure RedHat
+    "alpine"   -> pure Alpine
+    "amazonlinux" -> pure AmazonLinux
+    "rocky"    -> pure Rocky
+    "void"     -> pure Void
+    "gentoo"   -> pure Gentoo
+    "exherbo"  -> pure Exherbo
+    "opensuse" -> pure OpenSUSE
+    "unknownlinux" -> pure UnknownLinux
+    _          -> pure (OtherLinux $ T.unpack t)
 
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MetaMode
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
@@ -121,6 +141,7 @@ instance ToJSONKey Platform where
   toJSONKey = toJSONKeyText $ \case
     Darwin  -> T.pack "Darwin"
     FreeBSD -> T.pack "FreeBSD"
+    Linux (OtherLinux s) -> T.pack ("Linux_" <> s)
     Linux d -> T.pack ("Linux_" <> show d)
     Windows -> T.pack "Windows"
 

test/ghcup-test/GHCup/ArbitraryTypes.hs

@@ -136,8 +136,9 @@ instance Arbitrary DownloadInfo where
   shrink    = genericShrink
 
 instance Arbitrary LinuxDistro where
-  arbitrary = genericArbitrary
-  shrink    = genericShrink
+  arbitrary = do
+    let other = OtherLinux <$> listOf (elements ['a' .. 'z'])
+    oneof (other:(pure <$> allDistros))
 
 instance Arbitrary Platform where
   arbitrary = genericArbitrary

test/ghcup-test/GHCup/Types/JSONSpec.hs

@@ -14,7 +14,8 @@ import           Test.Hspec
 
 spec :: Spec
 spec = do
-  roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName goldenDir }) (Proxy @GHCupInfo)
+  roundtripSpecs (Proxy @LinuxDistro)
+  roundtripAndGoldenSpecsWithSettings (defaultSettings { goldenDirectoryOption = CustomDirectoryName goldenDir, sampleSize = 2 }) (Proxy @GHCupInfo)
  where
   goldenDir
     | isWindows = "test/ghcup-test/golden/windows"