ghcup-hs/lib/GHCup/Platform.hs

196 lines
6.8 KiB
Haskell
Raw Normal View History

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 #-}
{-# LANGUAGE TemplateHaskell #-}
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
Portability : POSIX
-}
2020-01-11 20:15:05 +00:00
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
2020-01-11 20:15:05 +00:00
import Data.Foldable
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import HPath.IO
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
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import qualified Data.Text as T
--------------------------
--[ Platform detection ]--
--------------------------
2020-04-10 17:27:17 +00:00
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
=> 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
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> 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
2020-04-11 20:15:09 +00:00
. getMajorVersion
2020-04-17 07:30: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-03-11 16:03:51 +00:00
either (const Nothing) Just . versioning . decUTF8Safe
<$> getFreeBSDVersion
2020-01-11 20:15:05 +00:00
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where
2020-04-11 20:15:09 +00:00
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
getFreeBSDVersion =
liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
2020-04-11 20:15:09 +00:00
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
["-productVersion"]
Nothing
2020-01-11 20:15:05 +00:00
getLinuxDistro :: (MonadCatch m, MonadIO 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) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, try_redhat_release
, try_debian_version
]
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
hasWord t matches = foldr (\x y -> match (regex x) (T.unpack t) || y)
False
matches
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
2020-01-11 20:15:05 +00:00
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
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
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- 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
2020-04-17 07:30: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
2020-04-17 07:30:45 +00:00
t <- fmap decUTF8Safe' $ 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
ver <- readFile debian_version
2020-04-17 07:30:45 +00:00
pure (T.pack "debian", Just . decUTF8Safe' $ ver)