ghcup-hs/lib/GHCup/Platform.hs

200 lines
7.1 KiB
Haskell
Raw Permalink Normal View History

2021-11-02 18:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
2022-01-12 21:55:00 +00:00
{-# LANGUAGE TemplateHaskellQuotes #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Plaform
Description : Retrieving platform information
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
-}
2020-01-11 20:15:05 +00:00
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
2021-08-30 20:41:58 +00:00
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ
2020-01-11 20:15:05 +00:00
2021-11-02 18:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString )
2020-01-11 20:15:05 +00:00
import Data.Foldable
import Data.Maybe
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Info
2020-07-04 21:28:30 +00:00
import System.OsRelease
2021-06-07 18:09:18 +00:00
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import qualified Data.Text as T
2021-05-14 21:09:45 +00:00
import qualified Data.Text.IO as T
2020-01-11 20:15:05 +00:00
--------------------------
--[ Platform detection ]--
--------------------------
2020-04-10 17:27:17 +00:00
-- | Get the full platform request, consisting of architecture, distro, ...
2021-08-30 20:41:58 +00:00
platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
2020-04-10 17:27:17 +00:00
=> Excepts
2020-06-27 17:00:13 +00:00
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
2020-04-10 17:27:17 +00:00
m
PlatformRequest
platformRequest = do
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
2020-01-11 20:15:05 +00:00
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
2020-06-27 17:00:13 +00:00
"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)
2020-01-11 20:15:05 +00:00
2021-08-30 20:41:58 +00:00
getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
2020-01-11 20:15:05 +00:00
=> Excepts
2020-06-27 17:00:13 +00:00
'[NoCompatiblePlatform, DistroNotFound]
2020-01-11 20:15:05 +00:00
m
PlatformResult
getPlatform = do
pfr <- case os of
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do
ver <-
2021-03-11 16:03:51 +00:00
either (const Nothing) Just
2020-04-11 20:15:09 +00:00
. versioning
2020-06-27 17:00:13 +00:00
-- TODO: maybe do this somewhere else
2021-05-14 21:09:45 +00:00
. decUTF8Safe'
2021-03-11 16:03:51 +00:00
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
2020-01-11 20:15:05 +00:00
"freebsd" -> do
ver <-
2021-05-14 21:09:45 +00:00
either (const Nothing) Just . versioning . decUTF8Safe'
<$> getFreeBSDVersion
2020-01-11 20:15:05 +00:00
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
2021-05-14 21:09:45 +00:00
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
2020-01-11 20:15:05 +00:00
what -> throwE $ NoCompatiblePlatform what
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
2020-01-11 20:15:05 +00:00
pure pfr
where
2021-05-14 21:09:45 +00:00
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
2020-04-11 20:15:09 +00:00
["-productVersion"]
Nothing
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
2020-01-11 20:15:05 +00:00
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
2021-05-14 21:09:45 +00:00
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
[ liftIO try_os_release
2020-01-11 20:15:05 +00:00
, try_lsb_release_cmd
2021-05-14 21:09:45 +00:00
, liftIO try_redhat_release
, liftIO try_debian_version
2020-01-11 20:15:05 +00:00
]
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
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
2021-08-29 15:08:06 +00:00
hasWord t = any (\x -> match (regex x) (T.unpack t))
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
lsb_release_cmd :: FilePath
lsb_release_cmd = "lsb-release"
redhat_release :: FilePath
redhat_release = "/etc/redhat-release"
debian_version :: FilePath
debian_version = "/etc/debian_version"
2020-01-11 20:15:05 +00:00
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
2021-03-11 16:03:51 +00:00
Just OsRelease{ name = name, version_id = version_id } <-
2020-07-04 21:28:30 +00:00
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
try_lsb_release_cmd :: (MonadFail m, MonadIO m)
=> m (Text, Maybe Text)
2020-01-11 20:15:05 +00:00
try_lsb_release_cmd = do
2021-05-14 21:09:45 +00:00
(Just _) <- liftIO $ findExecutable lsb_release_cmd
2020-03-21 21:19:37 +00:00
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
2021-05-14 21:09:45 +00:00
pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
2020-01-11 20:15:05 +00:00
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
2021-05-14 21:09:45 +00:00
t <- T.readFile redhat_release
let nameRegex n =
2020-03-21 21:19:37 +00:00
makeRegexOpts compIgnoreCase
execBlank
2021-03-11 16:03:51 +00:00
([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
let verRegex =
2020-03-21 21:19:37 +00:00
makeRegexOpts compIgnoreCase
execBlank
([s|\<([0-9])+(.([0-9])+)*\>|] :: ByteString) :: Regex
let nameRe n =
fromEmpty . match (nameRegex n) $ T.unpack t :: Maybe String
verRe = fromEmpty . match verRegex $ T.unpack t :: Maybe String
2020-01-11 20:15:05 +00:00
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (T.pack name, fmap T.pack verRe)
where
fromEmpty :: String -> Maybe String
2020-03-21 21:19:37 +00:00
fromEmpty "" = Nothing
fromEmpty s' = Just s'
2020-01-11 20:15:05 +00:00
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
2021-05-14 21:09:45 +00:00
ver <- T.readFile debian_version
pure (T.pack "debian", Just ver)