1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-14 17:32:00 +03:00
juvix/app/Commands/Doctor.hs
Paul Cadman 382a4d3cef
Global offline flag (#2335)
This PR introduces a global `--offline` flag.

## Doctor

This replaces the `--offline` flag on the doctor command.

## Juvix package builds

The flag applies to juvix build commands like `juvix compile`, `juvix
repl`. This is so that users can continue to build packages offline that
have external dependencies when there's no network connection (as long
as they built the same package online previously).

Specifically, when the `--offline` flag is used in a package that has
external git dependencies.
* No `git clone` or `git fetch` commands are used
* `git checkout` will continue to be used
* Clones from previous builds are reused

This means that you can update the `ref` field in a git dependency, as
long as the ref existed the last time that the project was built without
the `--offline` flag.

* Closes https://github.com/anoma/juvix/issues/2333
2023-09-05 17:11:17 +02:00

178 lines
6.9 KiB
Haskell

module Commands.Doctor where
import Commands.Base hiding (info)
import Commands.Doctor.Options
import Commands.Extra.Compile
import Data.Aeson
import Data.Aeson.TH
import Juvix.Extra.Version qualified as V
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/dev/reference/tooling/doctor/#"
heading :: (Member Log r) => Text -> Sem r ()
heading = log . ("> " <>)
warning :: (Member Log r) => Text -> Sem r ()
warning = log . (" ! " <>)
info :: (Member Log r) => Text -> Sem r ()
info = log . (" | " <>)
type DoctorEff = '[Log, Embed IO, App]
checkCmdOnPath :: (Members DoctorEff r) => String -> [Text] -> Sem r ()
checkCmdOnPath cmd errMsg =
whenM (isNothing <$> findExecutable (relFile cmd)) (mapM_ warning errMsg)
-- | Check that wasm-ld exists in the same LLVM distribution as the clang command
checkWasmLd :: (Members DoctorEff r) => Path Abs File -> [Text] -> Sem r ()
checkWasmLd clangPath errMsg =
unlessM (isExecutable (parent clangPath <//> $(mkRelFile "wasm-ld"))) (mapM_ warning errMsg)
checkClangTargetSupported :: (Members DoctorEff r) => Path Abs File -> String -> [Text] -> Sem r ()
checkClangTargetSupported clangPath target errMsg = do
(code, _, _) <-
embed
( P.readProcessWithExitCode
(toFilePath clangPath)
["-target", target, "--print-supported-cpus"]
""
)
unless (code == ExitSuccess) (mapM_ warning errMsg)
checkClangVersion :: (Members DoctorEff r) => Path Abs File -> Integer -> [Text] -> Sem r ()
checkClangVersion clangPath expectedVersion errMsg = do
versionString <- embed (P.readProcess (toFilePath clangPath) ["-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"
renderDocumentedWarning :: DocumentedWarning -> [Text]
renderDocumentedWarning w = [dmsg ^. documentedMessageMessage, dmsg ^. documentedMessageUrl]
where
dmsg :: DocumentedMessage
dmsg = documentedMessage w
documentedCheck ::
([Text] -> Sem r ()) -> DocumentedWarning -> Sem r ()
documentedCheck check w = check (renderDocumentedWarning w)
findClangPath :: (Members DoctorEff r) => Sem r (Maybe ClangPath)
findClangPath = findClang
checkClang :: forall r. (Members DoctorEff r) => Bool -> Sem r ()
checkClang printVerbose = do
heading "Checking for clang..."
clangPath <- findClangPath
case clangPath of
Just cp -> when printVerbose (printVerbosePath cp)
Nothing -> mapM_ warning (renderDocumentedWarning NoClang)
mapM_ checkClangProperties (extractClangPath <$> clangPath)
heading "Checking that WASI_SYSROOT_PATH is set..."
documentedCheck (checkEnvVarSet "WASI_SYSROOT_PATH") NoSysroot
where
checkClangProperties :: Path Abs File -> Sem r ()
checkClangProperties p = do
heading "Checking clang version..."
documentedCheck (checkClangVersion p minimumClangVersion) OldClang
heading "Checking for wasm-ld..."
documentedCheck (checkWasmLd p) NoWasmLd
heading "Checking that clang supports wasm32..."
documentedCheck (checkClangTargetSupported p "wasm32") NoWasm32Target
heading "Checking that clang supports wasm32-wasi..."
documentedCheck (checkClangTargetSupported p "wasm32-wasi") NoWasm32WasiTarget
baseClangMsg :: Path Abs File -> Text
baseClangMsg p = "Found clang at " <> show p
printVerbosePath :: ClangPath -> Sem r ()
printVerbosePath = \case
ClangEnvVarPath p -> info (baseClangMsg p <> (" using " <> pack llvmDistEnvironmentVar <> " environment variable"))
ClangSystemPath p -> info (baseClangMsg p <> (" using system PATH"))
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 (opts ^. doctorVerbose)
checkWasmer
offlineMode <- (^. globalOffline) <$> askGlobalOptions
unless offlineMode checkVersion