module IHP.IDE.StatusServer (withStatusServer, consumeGhciOutput, clearStatusServer, Clients) where
import IHP.ViewPrelude hiding (catch)
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as Websocket
import qualified Network.Wai.Handler.WebSockets as Websocket
import qualified Control.Concurrent as Concurrent
import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
import qualified Network.HTTP.Types.Header as HTTP
import qualified Text.Blaze.Html5 as Html5
import qualified Network.HTTP.Types as HTTP
import qualified Data.ByteString.Char8 as ByteString
import IHP.IDE.Types
import IHP.IDE.PortConfig
import IHP.IDE.ToolServer.Types
import IHP.IDE.ToolServer.Routes ()
import qualified Network.URI as URI
import qualified Control.Exception.Safe as Exception
import qualified Control.Concurrent.Chan.Unagi as Queue
import Control.Concurrent.MVar
type Clients = IORef [(Websocket.Connection, Concurrent.MVar ())]
withStatusServer :: (?context :: Context) => IORef Bool -> (MVar () -> MVar (MVar ()) -> IORef [ByteString] -> IORef [ByteString] -> Clients -> IO a) -> IO a
withStatusServer ghciIsLoadingVar callback = do
standardOutput <- newIORef []
errorOutput <- newIORef []
clients <- newIORef []
startMVar :: MVar () <- newMVar ()
stopMVar :: MVar (MVar ()) <- newEmptyMVar
(a, _) <- concurrently (callback startMVar stopMVar standardOutput errorOutput clients) (runStatusServer ghciIsLoadingVar standardOutput errorOutput clients startMVar stopMVar)
pure a
runStatusServer ghciIsLoadingVar standardOutput errorOutput clients startMVar stopMVar = do
let port = ?context.portConfig.appPort |> fromIntegral
forever do
_ <- takeMVar startMVar
race_
(Warp.run port (waiApp ghciIsLoadingVar clients standardOutput errorOutput))
(readMVar stopMVar)
isStoppedVar <- takeMVar stopMVar
putMVar isStoppedVar ()
waiApp :: (?context :: Context) => IORef Bool -> IORef [(Websocket.Connection, Concurrent.MVar ())] -> IORef [ByteString] -> IORef [ByteString] -> Wai.Application
waiApp ghciIsLoadingVar clients standardOutput errorOutput = do
Websocket.websocketsOr
Websocket.defaultConnectionOptions
(wsApp ghciIsLoadingVar clients standardOutput errorOutput)
(httpApp ghciIsLoadingVar standardOutput errorOutput)
httpApp :: (?context :: Context) => IORef Bool -> IORef [ByteString] -> IORef [ByteString] -> Wai.Application
httpApp ghciIsLoadingVar standardOutput errorOutput req respond = do
isCompiling <- readIORef ghciIsLoadingVar
currentStandardOutput <- readIORef standardOutput
currentErrorOutput <- readIORef errorOutput
lastSchemaCompilerError <- readIORef ?context.lastSchemaCompilerError
let responseBody = Blaze.renderHtmlBuilder (renderErrorView currentStandardOutput currentErrorOutput isCompiling lastSchemaCompilerError)
let responseHeaders = [(HTTP.hContentType, "text/html")]
respond $ Wai.responseBuilder HTTP.status200 responseHeaders responseBody
clearStatusServer :: _ => IORef [ByteString] -> IORef [ByteString] -> Clients -> IO ()
clearStatusServer standardOutput errorOutput clients = do
writeIORef standardOutput []
writeIORef errorOutput []
async (notifyOutput clients)
pure ()
consumeGhciOutput :: (?context :: Context) => IORef [ByteString] -> IORef [ByteString] -> Clients -> IO ()
consumeGhciOutput statusServerStandardOutput statusServerErrorOutput statusServerClients = forever do
line <- Queue.readChan ?context.ghciOutChan
let shouldIgnoreLine = (line == ErrorOutput "Warning: -debug, -threaded and -ticky are ignored by GHCi")
unless shouldIgnoreLine do
let writeOutputLine standardOutput errorOutput = do
case line of
StandardOutput line -> modifyIORef' standardOutput (line:)
ErrorOutput line -> modifyIORef' errorOutput (line:)
writeOutputLine statusServerStandardOutput statusServerErrorOutput
notifyOutput statusServerClients
notifyOutput :: IORef [(Websocket.Connection, Concurrent.MVar ())] -> IO ()
notifyOutput stateRef = do
clients <- readIORef stateRef
forM_ clients \(connection, didChangeMVar) -> do
_ <- Concurrent.tryPutMVar didChangeMVar ()
pure ()
data CompilerError = CompilerError { errorMessage :: [ByteString], isWarning :: Bool } deriving (Show)
renderErrorView :: (?context :: Context) => [ByteString] -> [ByteString] -> Bool -> Maybe SomeException -> Html5.Html
renderErrorView standardOutput errorOutput' isCompiling lastSchemaCompilerError = [hsx|
{title}
{errorContainer}
|]
where
errorOutput =
case lastSchemaCompilerError of
Just lastSchemaCompilerError -> [cs (displayException lastSchemaCompilerError)]
Nothing -> errorOutput'
errorContainer = [hsx|
{inner}
{forEach errors renderError}
{ByteString.unlines (reverse standardOutput)}
|]
where
-- Errors are reordered here as we want to display the most important compile errors first
-- Warnings should come after the actual errors.
errors = errorOutput
|> parseErrorOutput
|> sortBy (comparing (.isWarning))
parseErrorOutput :: [ByteString] -> [CompilerError]
parseErrorOutput output =
splitToSections (reverse output) []
|> map identifySection
where
splitToSections :: [ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections [] result = result
splitToSections ("":lines) result = splitToSections lines result
splitToSections lines result =
let (error :: [ByteString], rest) = span (\line -> line /= "") lines
in splitToSections rest ((error |> filter (/= "")):result)
identifySection :: [ByteString] -> CompilerError
identifySection lines | "warning" `ByteString.isInfixOf` (fromMaybe "" (headMay lines)) = CompilerError { errorMessage = lines, isWarning = True }
identifySection lines = CompilerError { errorMessage = lines, isWarning = False }
title = if isCompiling
then [hsx|Compiling...|]
else [hsx|Compilation Error|]
inner = if isCompiling
then [hsx|Is compiling|]
else [hsx|Problems found while compiling|]
renderError CompilerError { errorMessage, isWarning } = [hsx|
{forEachWithIndex errorMessage renderLine}
{mconcat (renderTroubleshooting errorMessage)}
|]
renderLine (0, line) = [hsx|
{filePath}
|]
where
(filePath, rest) = ByteString.breakSubstring ": " line
openEditor = "http://localhost:" <> tshow toolServerPort <> (pathTo OpenEditorAction) <> "?path=" <> cs plainFilePath <> "&line=" <> cs fileLine <> "&col=" <> cs fileCol
(plainFilePath, fileLine, fileCol) = case ByteString.split ':' filePath of
[path, line, col, rest] -> (path, line, col) -- This happens for parser errors from the IHP.SchemaCompiler.compile function
[path, line, col] -> (path, line, col)
[path, line] -> (path, line, "0")
otherwise -> (filePath, "0", "0")
renderLine (i, line) = [hsx|{line}
|]
renderTroubleshooting :: [ByteString] -> [Html5.Html]
renderTroubleshooting lines = [ modelContextTroubleshooting ]
|> map (\f -> f lines)
|> catMaybes
toolServerPort = ?context.portConfig.toolServerPort
wsApp :: (?context :: Context) => IORef Bool -> Clients -> _ -> _ -> Websocket.ServerApp
wsApp ghciIsLoadingVar stateRef standardOutput errorOutput pendingConnection = do
connection <- Websocket.acceptRequest pendingConnection
didChangeMVar <- Concurrent.newEmptyMVar
modifyIORef stateRef $ \state -> ((connection, didChangeMVar) : state)
let notifyClient = do
-- Blocks until a change happens
Concurrent.takeMVar didChangeMVar
-- Debounce
Concurrent.threadDelay 100000 -- 100ms
isCompiling <- readIORef ghciIsLoadingVar
standardOutput' <- readIORef standardOutput
errorOutput' <- readIORef errorOutput
lastSchemaCompilerError <- readIORef ?context.lastSchemaCompilerError
let errorContainer = renderErrorView standardOutput' errorOutput' isCompiling lastSchemaCompilerError
let html = Blaze.renderHtml errorContainer
result <- Exception.try (Websocket.sendTextData connection html)
case result of
Left (Exception.SomeException e) -> pure () -- Client was probably disconnected
Right _ -> notifyClient
notifyClient
pure ()
modelContextTroubleshooting :: [ByteString] -> Maybe Html5.Html
modelContextTroubleshooting lines =
lines
|> map (\line -> "Unbound implicit parameter (?modelContext::" `ByteString.isInfixOf` line)
|> or
|> \case
True -> Just [hsx|
|]
False -> Nothing