ghcup-hs/lib/GHCup/Platform.hs

{-# 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
import           GHCup.Prelude.Version.QQ
import           GHCup.Prelude.MegaParsec

#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           System.Exit
import           System.FilePath
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
import           Text.Regex.Posix

import qualified Text.Megaparsec               as MP

import qualified Data.Text                     as T
import qualified Data.Text.IO                  as T
import           Data.Void
import qualified Data.List                     as L




    --------------------------
    --[ 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 = do
  (PlatformResult rp rv) <- liftE getPlatform
  ar                     <- lE getArchitecture
  pure $ PlatformRequest ar rp rv


getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
  "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)


getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail 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 <-
        either (const Nothing) Just
          . versioning
          -- TODO: maybe do this somewhere else
          . decUTF8Safe'
        <$> getDarwinVersion
      pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
    "freebsd" -> do
      ver <-
        either (const Nothing) Just . versioning . decUTF8Safe'
          <$> getFreeBSDVersion
      pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
    "mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
    what -> throwE $ NoCompatiblePlatform what
  lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
  pure pfr
 where
  getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
  getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
                                                        ["-productVersion"]
                                                        Nothing


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
    [ liftIO try_os_release
    , try_lsb_release_cmd
    , liftIO try_redhat_release
    , liftIO 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 = any (\x -> match (regex x) (T.unpack t))
   where
    regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])

  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"

  try_os_release :: IO (Text, Maybe Text)
  try_os_release = do
    Just OsRelease{ name = name, version_id = version_id } <-
      fmap osRelease <$> parseOsRelease
    pure (T.pack name, fmap T.pack version_id)

  try_lsb_release_cmd :: (MonadFail m, MonadIO m)
                      => m (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)

  try_redhat_release :: IO (Text, Maybe Text)
  try_redhat_release = do
    t <- T.readFile redhat_release
    let nameRegex n =
          makeRegexOpts compIgnoreCase
                        execBlank
                        ([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
    let verRegex =
          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
    (Just name) <- pure
      (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
    pure (T.pack name, 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 = do
    ver <- T.readFile debian_version
    pure (T.pack "debian", Just ver)


getStackGhcBuilds :: (MonadReader env m, HasLog env, MonadIO m)
                  => PlatformResult
                  -> Excepts '[ParseError, NoCompatiblePlatform, DistroNotFound, ProcessError] m [String]
getStackGhcBuilds PlatformResult{..} = do
    case _platform of
      Linux _ -> do
        -- Some systems don't have ldconfig in the PATH, so make sure to look in
        -- /sbin and /usr/sbin as well
        sbinEnv <- liftIO $ addToPath sbinDirs False
        ldConfig <- lift $ executeOut' "ldconfig" ["-p"] Nothing (Just sbinEnv)
        firstWords <- case ldConfig of
                        CapturedProcess ExitSuccess so _ ->
                          pure . mapMaybe (listToMaybe . T.words) . T.lines . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ so
                        CapturedProcess (ExitFailure _) _ _ ->
                          -- throwE $ NonZeroExit c "ldconfig" ["-p" ]
                          pure []
        let checkLib :: (MonadReader env m, HasLog env, MonadIO m) => String -> m Bool
            checkLib lib
              | libT `elem` firstWords = do
                  logDebug $ "Found shared library " <> libT <> " in 'ldconfig -p' output"
                  pure True
              | isWindows =
                  -- Cannot parse /usr/lib on Windows
                  pure False
              | otherwise = hasMatches lib usrLibDirs
              -- This is a workaround for the fact that libtinfo.so.x doesn't
              -- appear in the 'ldconfig -p' output on Arch or Slackware even
              -- when it exists. There doesn't seem to be an easy way to get the
              -- true list of directories to scan for shared libs, but this
              -- works for our particular cases.
             where
              libT = T.pack lib

            hasMatches :: (MonadReader env m, HasLog env, MonadIO m) => String -> [FilePath] -> m Bool
            hasMatches lib dirs = do
              matches <- filterM (liftIO . doesFileExist . (</> lib)) dirs
              case matches of
                [] -> logDebug ("Did not find shared library " <> libT) >> pure False
                (path:_) -> logDebug ("Found shared library " <> libT <> " in " <> T.pack path) >> pure True
             where
              libT = T.pack lib

            getLibc6Version :: MonadIO m
                            => Excepts '[ParseError, ProcessError] m Version
            getLibc6Version = do
              CapturedProcess{..} <- lift $ executeOut "ldd" ["--version"] Nothing
              case _exitCode of
                ExitSuccess -> either (throwE . ParseError . show) pure
                                 . MP.parse lddVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
                ExitFailure c -> throwE $ NonZeroExit c "ldd" ["--version" ]

            -- Assumes the first line of ldd has the format:
            --
            -- ldd (...) nn.nn
            --
            -- where nn.nn corresponds to the version of libc6.
            lddVersion :: MP.Parsec Void Text Version
            lddVersion = do
              skipWhile (/= ')')
              skip (== ')')
              skipSpace
              version'

        hasMusl <- hasMatches relFileLibcMuslx86_64So1 libDirs
        mLibc6Version <- veitherToEither <$> runE getLibc6Version
        case mLibc6Version of
          Right libc6Version -> logDebug $ "Found shared library libc6 in version: " <> prettyVer libc6Version
          Left _ -> logDebug "Did not find a version of shared library libc6."
        let hasLibc6_2_32 = either (const False) (>= [vver|2.32|]) mLibc6Version
        hastinfo5 <- checkLib relFileLibtinfoSo5
        hastinfo6 <- checkLib relFileLibtinfoSo6
        hasncurses6 <- checkLib relFileLibncurseswSo6
        hasgmp5 <- checkLib relFileLibgmpSo10
        hasgmp4 <- checkLib relFileLibgmpSo3
        let libComponents = if hasMusl
              then
                [ ["musl"] ]
              else
                concat
                  [ if hastinfo6 && hasgmp5
                    then
                      if hasLibc6_2_32
                      then [["tinfo6"]]
                      else [["tinfo6-libc6-pre232"]]
                    else [[]]
                  , [ [] | hastinfo5 && hasgmp5 ]
                  , [ ["ncurses6"] | hasncurses6 && hasgmp5 ]
                  , [ ["gmp4"] | hasgmp4 ]
                  ]
        pure $ map
          (\c -> case c of
            [] -> []
            _ -> L.intercalate "-" c)
          libComponents
      FreeBSD ->
        case _distroVersion of
          Just fVer
            | fVer >= [vers|12|] -> pure []
          _ -> pure ["ino64"]
      Darwin  -> pure []
      Windows -> pure []
 where

  relFileLibcMuslx86_64So1 :: FilePath
  relFileLibcMuslx86_64So1 = "libc.musl-x86_64.so.1"
  libDirs :: [FilePath]
  libDirs = ["/lib", "/lib64"]
  usrLibDirs :: [FilePath]
  usrLibDirs = ["/usr/lib", "/usr/lib64"]
  sbinDirs :: [FilePath]
  sbinDirs = ["/sbin", "/usr/sbin"]
  relFileLibtinfoSo5 :: FilePath
  relFileLibtinfoSo5 = "libtinfo.so.5"
  relFileLibtinfoSo6 :: FilePath
  relFileLibtinfoSo6 = "libtinfo.so.6"
  relFileLibncurseswSo6 :: FilePath
  relFileLibncurseswSo6 = "libncursesw.so.6"
  relFileLibgmpSo10 :: FilePath
  relFileLibgmpSo10 = "libgmp.so.10"
  relFileLibgmpSo3 :: FilePath
  relFileLibgmpSo3 = "libgmp.so.3"

getStackOSKey :: Monad m => PlatformRequest -> Excepts '[UnsupportedSetupCombo] m String
getStackOSKey PlatformRequest { .. } =
  case (_rArch, _rPlatform) of
    (A_32   , Linux _) -> pure "linux32"
    (A_64   , Linux _) -> pure "linux64"
    (A_32   , Darwin ) -> pure "macosx"
    (A_64   , Darwin ) -> pure "macosx"
    (A_32   , FreeBSD) -> pure "freebsd32"
    (A_64   , FreeBSD) -> pure "freebsd64"
    (A_32   , Windows) -> pure "windows32"
    (A_64   , Windows) -> pure "windows64"
    (A_ARM  , Linux _) -> pure "linux-armv7"
    (A_ARM64, Linux _) -> pure "linux-aarch64"
    (A_Sparc, Linux _) -> pure "linux-sparc"
    (A_ARM64, Darwin ) -> pure "macosx-aarch64"
    (A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
    (arch', os') -> throwE $ UnsupportedSetupCombo arch' os'

getStackPlatformKey :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
                    => PlatformRequest
                    -> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
getStackPlatformKey pfreq@PlatformRequest{..} = do
  osKey <- liftE  $ getStackOSKey pfreq
  builds <- liftE $ getStackGhcBuilds (PlatformResult _rPlatform _rVersion)
  let builds' = (\build -> if null build then osKey else osKey <> "-" <> build) <$> builds
  logDebug $ "Potential GHC builds: " <> mconcat (L.intersperse ", " $ fmap T.pack builds')
  pure builds'