1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-15 18:13:56 +03:00
juvix/app/Commands/Doctor.hs
2022-09-14 16:16:15 +02:00

147 lines
5.5 KiB
Haskell

module Commands.Doctor where
import Commands.Doctor.Options
import Data.Aeson
import Data.Aeson.TH
import Juvix.Extra.Version qualified as V
import Juvix.Prelude
import Network.HTTP.Simple
import Safe (headMay)
import System.Environment qualified as E
import System.Process qualified as P
import Text.Read (readMaybe)
newtype GithubRelease = GithubRelease {_githubReleaseTagName :: Maybe Text}
deriving stock (Eq, Show, Generic)
$( deriveFromJSON
defaultOptions
{ fieldLabelModifier = camelTo2 '_' . dropPrefix "_githubRelease"
}
''GithubRelease
)
data DocumentedWarning
= NoClang
| OldClang
| NoWasmLd
| NoWasm32Target
| NoWasm32WasiTarget
| NoSysroot
| NoWasmer
data DocumentedMessage = DocumentedMessage
{ _documentedMessageUrl :: Text,
_documentedMessageMessage :: Text
}
makeLenses ''GithubRelease
makeLenses ''DoctorOptions
makeLenses ''DocumentedMessage
minimumClangVersion :: Integer
minimumClangVersion = 13
documentedMessage :: DocumentedWarning -> DocumentedMessage
documentedMessage w = uncurry DocumentedMessage (first (baseUrl <>) warningInfo)
where
warningInfo :: (Text, Text)
warningInfo = case w of
NoClang -> ("could-not-find-the-clang-command", "Could not find the clang command")
OldClang -> ("newer-clang-version-required", "Clang version " <> show minimumClangVersion <> " or newer required")
NoWasmLd -> ("could-not-find-the-wasm-ld-command", "Could not find the wasm-ld command")
NoWasm32Target -> ("clang-does-not-support-the-wasm32-target", "Clang does not support the wasm32 target")
NoWasm32WasiTarget -> ("clang-does-not-support-the-wasm32-wasi-target", "Clang does not support the wasm32-wasi target")
NoSysroot -> ("environment-variable-wasi_sysroot_path-is-not-set", "Environment variable WASI_SYSROOT_PATH is missing")
NoWasmer -> ("could-not-find-the-wasmer-command", "Could not find the wasmer command")
baseUrl :: Text
baseUrl = "https://docs.juvix.org/tooling/doctor.html#"
heading :: Member Log r => Text -> Sem r ()
heading = log . ("> " <>)
warning :: Member Log r => Text -> Sem r ()
warning = log . (" ! " <>)
type DoctorEff = '[Log, Embed IO]
checkCmdOnPath :: Members DoctorEff r => String -> [Text] -> Sem r ()
checkCmdOnPath cmd errMsg =
whenM (isNothing <$> embed (findExecutable cmd)) (mapM_ warning errMsg)
checkClangTargetSupported :: Members DoctorEff r => String -> [Text] -> Sem r ()
checkClangTargetSupported target errMsg = do
(code, _, _) <-
embed
( P.readProcessWithExitCode
"clang"
["-target", target, "--print-supported-cpus"]
""
)
unless (code == ExitSuccess) (mapM_ warning errMsg)
checkClangVersion :: Members DoctorEff r => Integer -> [Text] -> Sem r ()
checkClangVersion expectedVersion errMsg = do
versionString <- embed (P.readProcess "clang" ["-dumpversion"] "")
case headMay (splitOn "." versionString) >>= readMaybe of
Just majorVersion -> unless (majorVersion >= expectedVersion) (mapM_ warning errMsg)
Nothing -> warning "Could not determine clang version"
checkEnvVarSet :: Members DoctorEff r => String -> [Text] -> Sem r ()
checkEnvVarSet var errMsg = do
whenM (isNothing <$> embed (E.lookupEnv var)) (mapM_ warning errMsg)
getLatestRelease :: Members '[Embed IO, Fail] r => Sem r GithubRelease
getLatestRelease = do
request' <- failFromException (parseRequest "https://api.github.com/repos/anoma/juvix/releases/latest")
let request = setRequestHeaders [("user-agent", "curl/7.79.1"), ("Accept", "application/vnd.github+json")] request'
response <- failFromException (httpJSON request)
return (getResponseBody response)
checkVersion :: Members DoctorEff r => Sem r ()
checkVersion = do
heading "Checking latest Juvix release on Github..."
let tagName = "v" <> V.versionDoc
response <- runFail getLatestRelease
case response of
Just release -> case release ^. githubReleaseTagName of
Just latestTagName -> unless (tagName == latestTagName) (warning ("Newer Juvix version is available from https://github.com/anoma/juvix/releases/tag/" <> latestTagName))
Nothing -> warning "Tag name is not present in release JSON from Github API"
Nothing -> warning "Network error when fetching data from Github API"
documentedCheck ::
([Text] -> Sem r ()) -> DocumentedWarning -> Sem r ()
documentedCheck check w = check msg
where
dmsg :: DocumentedMessage
dmsg = documentedMessage w
msg :: [Text]
msg = [dmsg ^. documentedMessageMessage, dmsg ^. documentedMessageUrl]
checkClang :: Members DoctorEff r => Sem r ()
checkClang = do
heading "Checking for clang..."
documentedCheck (checkCmdOnPath "clang") NoClang
heading "Checking clang version..."
documentedCheck (checkClangVersion minimumClangVersion) OldClang
heading "Checking for wasm-ld..."
documentedCheck (checkCmdOnPath "wasm-ld") NoWasmLd
heading "Checking that clang supports wasm32..."
documentedCheck (checkClangTargetSupported "wasm32") NoWasm32Target
heading "Checking that clang supports wasm32-wasi..."
documentedCheck (checkClangTargetSupported "wasm32-wasi") NoWasm32WasiTarget
heading "Checking that WASI_SYSROOT_PATH is set..."
documentedCheck (checkEnvVarSet "WASI_SYSROOT_PATH") NoSysroot
checkWasmer :: Members DoctorEff r => Sem r ()
checkWasmer = do
heading "Checking for wasmer..."
documentedCheck (checkCmdOnPath "wasmer") NoWasmer
runCommand :: Members DoctorEff r => DoctorOptions -> Sem r ()
runCommand opts = do
checkClang
checkWasmer
unless (opts ^. doctorOffline) checkVersion