ghcup-hs/lib/GHCup/Platform.hs

195 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 #-}
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
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
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
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
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
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform , DistroNotFound]
m
PlatformResult
getPlatform = do
pfr <- case os of
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do
ver <-
2020-04-11 20:15:09 +00:00
( either (const Nothing) Just
. versioning
. getMajorVersion
2020-04-17 07:30:45 +00:00
. decUTF8Safe
2020-04-11 20:15:09 +00:00
)
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
2020-01-11 20:15:05 +00:00
"freebsd" -> do
ver <-
2020-04-17 07:30:45 +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_lsb_release
, 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
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
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
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
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_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
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
(([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)