{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskellQuotes #-}


{-|
Module      : GHCup.Plaform
Description : Retrieving platform information
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable
-}
module GHCup.Platform where


import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.Optics
import           GHCup.Types.JSON               ( )
import           GHCup.Utils.Dirs
import           GHCup.Prelude
import           GHCup.Prelude.Logger
import           GHCup.Prelude.Process
import           GHCup.Prelude.String.QQ

#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             ( MonadFail )
#endif
import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.Reader
import           Data.ByteString                ( ByteString )
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
import           System.OsRelease
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
import           Text.Regex.Posix

import qualified Data.Text                     as T
import qualified Data.Text.IO                  as T



    --------------------------
    --[ Platform detection ]--
    --------------------------


-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
                => Excepts
                     '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
                     m
                     PlatformRequest
platformRequest :: forall env (m :: * -> *).
(MonadReader env m, Alternative m, MonadFail m, HasLog env,
 MonadCatch m, MonadIO m) =>
Excepts
  '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
  m
  PlatformRequest
platformRequest = do
  (PlatformResult Platform
rp Maybe Versioning
rv) <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall (m :: * -> *) env.
(Alternative m, MonadReader env m, HasLog env, MonadCatch m,
 MonadIO m, MonadFail m) =>
Excepts '[NoCompatiblePlatform, DistroNotFound] m PlatformResult
getPlatform
  Architecture
ar                     <- forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE Either NoCompatibleArch Architecture
getArchitecture
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Architecture -> Platform -> Maybe Versioning -> PlatformRequest
PlatformRequest Architecture
ar Platform
rp Maybe Versioning
rv


getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case String
arch of
  String
"x86_64"      -> forall a b. b -> Either a b
Right Architecture
A_64
  String
"i386"        -> forall a b. b -> Either a b
Right Architecture
A_32
  String
"powerpc"     -> forall a b. b -> Either a b
Right Architecture
A_PowerPC
  String
"powerpc64"   -> forall a b. b -> Either a b
Right Architecture
A_PowerPC64
  String
"powerpc64le" -> forall a b. b -> Either a b
Right Architecture
A_PowerPC64
  String
"sparc"       -> forall a b. b -> Either a b
Right Architecture
A_Sparc
  String
"sparc64"     -> forall a b. b -> Either a b
Right Architecture
A_Sparc64
  String
"arm"         -> forall a b. b -> Either a b
Right Architecture
A_ARM
  String
"aarch64"     -> forall a b. b -> Either a b
Right Architecture
A_ARM64
  String
what          -> forall a b. a -> Either a b
Left (String -> NoCompatibleArch
NoCompatibleArch String
what)


getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
            => Excepts
                 '[NoCompatiblePlatform, DistroNotFound]
                 m
                 PlatformResult
getPlatform :: forall (m :: * -> *) env.
(Alternative m, MonadReader env m, HasLog env, MonadCatch m,
 MonadIO m, MonadFail m) =>
Excepts '[NoCompatiblePlatform, DistroNotFound] m PlatformResult
getPlatform = do
  PlatformResult
pfr <- case String
os of
    String
"linux" -> do
      (LinuxDistro
distro, Maybe Versioning
ver) <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall (m :: * -> *).
(Alternative m, MonadCatch m, MonadIO m, MonadFail m) =>
Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PlatformResult { $sel:_platform:PlatformResult :: Platform
_platform = LinuxDistro -> Platform
Linux LinuxDistro
distro, $sel:_distroVersion:PlatformResult :: Maybe Versioning
_distroVersion = Maybe Versioning
ver }
    String
"darwin" -> do
      Maybe Versioning
ver <-
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Versioning
versioning
          -- TODO: maybe do this somewhere else
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe'
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Excepts '[NoCompatiblePlatform, DistroNotFound] m ByteString
getDarwinVersion
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PlatformResult { $sel:_platform:PlatformResult :: Platform
_platform = Platform
Darwin, $sel:_distroVersion:PlatformResult :: Maybe Versioning
_distroVersion = Maybe Versioning
ver }
    String
"freebsd" -> do
      Maybe Versioning
ver <-
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Versioning
versioning forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe'
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Excepts '[NoCompatiblePlatform, DistroNotFound] m ByteString
getFreeBSDVersion
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PlatformResult { $sel:_platform:PlatformResult :: Platform
_platform = Platform
FreeBSD, $sel:_distroVersion:PlatformResult :: Maybe Versioning
_distroVersion = Maybe Versioning
ver }
    String
"mingw32" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PlatformResult { $sel:_platform:PlatformResult :: Platform
_platform = Platform
Windows, $sel:_distroVersion:PlatformResult :: Maybe Versioning
_distroVersion = forall a. Maybe a
Nothing }
    String
what -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ String -> NoCompatiblePlatform
NoCompatiblePlatform String
what
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Identified Platform as: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Pretty a => a -> String
prettyShow PlatformResult
pfr)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure PlatformResult
pfr
 where
  getFreeBSDVersion :: Excepts '[NoCompatiblePlatform, DistroNotFound] m ByteString
getFreeBSDVersion = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CapturedProcess -> ByteString
_stdOut forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
"freebsd-version" [] forall a. Maybe a
Nothing
  getDarwinVersion :: Excepts '[NoCompatiblePlatform, DistroNotFound] m ByteString
getDarwinVersion = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CapturedProcess -> ByteString
_stdOut forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
"sw_vers"
                                                        [String
"-productVersion"]
                                                        forall a. Maybe a
Nothing


getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
               => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro :: forall (m :: * -> *).
(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
  (Text
name, Maybe Text
ver) <- forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE DistroNotFound
DistroNotFound) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Text, Maybe Text)
try_os_release
    , forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
m (Text, Maybe Text)
try_lsb_release_cmd
    , forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Text, Maybe Text)
try_redhat_release
    , forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Text, Maybe Text)
try_debian_version
    ]
  let parsedVer :: Maybe Versioning
parsedVer = Maybe Text
ver forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Versioning
versioning
      distro :: LinuxDistro
distro    = if
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"debian"]  -> LinuxDistro
Debian
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"ubuntu"]  -> LinuxDistro
Ubuntu
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"linuxmint", String
"Linux Mint"] -> LinuxDistro
Mint
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"fedora"]  -> LinuxDistro
Fedora
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"centos"]  -> LinuxDistro
CentOS
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"Red Hat"] -> LinuxDistro
RedHat
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"alpine"]  -> LinuxDistro
Alpine
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"exherbo"] -> LinuxDistro
Exherbo
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"gentoo"]  -> LinuxDistro
Gentoo
        | forall {t :: * -> *}. Foldable t => Text -> t String -> Bool
hasWord Text
name [String
"amazonlinux", String
"Amazon Linux"] -> LinuxDistro
AmazonLinux
        | Bool
otherwise                -> LinuxDistro
UnknownLinux
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (LinuxDistro
distro, Maybe Versioning
parsedVer)
 where
  hasWord :: Text -> t String -> Bool
hasWord Text
t = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match (String -> Regex
regex String
x) (Text -> String
T.unpack Text
t))
   where
    regex :: String -> Regex
regex String
x = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compIgnoreCase ExecOption
execBlank ([s|\<|] forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ [s|\>|])

  lsb_release_cmd :: FilePath
  lsb_release_cmd :: String
lsb_release_cmd = String
"lsb-release"
  redhat_release :: FilePath
  redhat_release :: String
redhat_release = String
"/etc/redhat-release"
  debian_version :: FilePath
  debian_version :: String
debian_version = String
"/etc/debian_version"

  try_os_release :: IO (Text, Maybe Text)
  try_os_release :: IO (Text, Maybe Text)
try_os_release = do
    Just OsRelease{ name :: OsRelease -> String
name = String
name, version_id :: OsRelease -> Maybe String
version_id = Maybe String
version_id } <-
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OsReleaseResult -> OsRelease
osRelease forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe OsReleaseResult)
parseOsRelease
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
T.pack String
name, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack Maybe String
version_id)

  try_lsb_release_cmd :: (MonadFail m, MonadIO m)
                      => m (Text, Maybe Text)
  try_lsb_release_cmd :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
m (Text, Maybe Text)
try_lsb_release_cmd = do
    (Just String
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
lsb_release_cmd
    ByteString
name     <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CapturedProcess -> ByteString
_stdOut forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
lsb_release_cmd [String
"-si"] forall a. Maybe a
Nothing
    ByteString
ver      <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CapturedProcess -> ByteString
_stdOut forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
lsb_release_cmd [String
"-sr"] forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Text
decUTF8Safe' ByteString
name, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
ver)

  try_redhat_release :: IO (Text, Maybe Text)
  try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
    Text
t <- String -> IO Text
T.readFile String
redhat_release
    let nameRegex :: String -> Regex
nameRegex String
n =
          forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compIgnoreCase
                        ExecOption
execBlank
                        ([s|\<|] forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fS String
n forall a. Semigroup a => a -> a -> a
<> [s|\>|] :: ByteString) :: Regex
    let verRegex :: Regex
verRegex =
          forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compIgnoreCase
                        ExecOption
execBlank
                        ([s|\<([0-9])+(.([0-9])+)*\>|] :: ByteString) :: Regex
    let nameRe :: String -> Maybe String
nameRe String
n =
          String -> Maybe String
fromEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match (String -> Regex
nameRegex String
n) forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t :: Maybe String
        verRe :: Maybe String
verRe = String -> Maybe String
fromEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
verRegex forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t :: Maybe String
    (Just String
name) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (String -> Maybe String
nameRe String
"CentOS" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe String
nameRe String
"Fedora" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe String
nameRe String
"Red Hat")
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
T.pack String
name, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack Maybe String
verRe)
   where
    fromEmpty :: String -> Maybe String
    fromEmpty :: String -> Maybe String
fromEmpty String
"" = forall a. Maybe a
Nothing
    fromEmpty String
s' = forall a. a -> Maybe a
Just String
s'

  try_debian_version :: IO (Text, Maybe Text)
  try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
    Text
ver <- String -> IO Text
T.readFile String
debian_version
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
T.pack String
"debian", forall a. a -> Maybe a
Just Text
ver)