diff --git a/IHP/IDE/StatusServer.hs b/IHP/IDE/StatusServer.hs index 8d2982080..8412b9be3 100644 --- a/IHP/IDE/StatusServer.hs +++ b/IHP/IDE/StatusServer.hs @@ -1,4 +1,4 @@ -module IHP.IDE.StatusServer (startStatusServer, stopStatusServer, clearStatusServer, notifyBrowserOnApplicationOutput, continueStatusServer) where +module IHP.IDE.StatusServer (startStatusServer, stopStatusServer, clearStatusServer, notifyBrowserOnApplicationOutput, continueStatusServer, consumeGhciOutput) where import IHP.ViewPrelude hiding (catch) import qualified Network.Wai as Wai @@ -17,6 +17,7 @@ import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Routes () import qualified Network.URI as URI import qualified Control.Exception as Exception +import qualified Control.Concurrent.Chan.Unagi as Queue -- async (notifyOutput (standardOutput, errorOutput) clients) @@ -41,10 +42,7 @@ continueStatusServer statusServerState@(StatusServerPaused { .. }) = do (app clients statusServerState) (statusServerApp (standardOutput, errorOutput)) - let port = ?context - |> get #portConfig - |> get #appPort - |> fromIntegral + let port = ?context.portConfig.appPort |> fromIntegral server <- async $ Warp.run port warpApp @@ -76,6 +74,14 @@ clearStatusServer StatusServerPaused { .. } = do writeIORef errorOutput [] clearStatusServer StatusServerNotStarted = pure () +consumeGhciOutput :: (?context :: Context) => IO () +consumeGhciOutput = forever do + outputLine <- Queue.readChan ?context.ghciOutChan + appState <- readIORef ?context.appStateRef + + notifyBrowserOnApplicationOutput appState.statusServerState outputLine + + notifyBrowserOnApplicationOutput :: (?context :: Context) => StatusServerState -> OutputLine -> IO () notifyBrowserOnApplicationOutput StatusServerStarted { serverRef, clients, standardOutput, errorOutput } line = do let shouldIgnoreLine = (line == ErrorOutput "Warning: -debug, -threaded and -ticky are ignored by GHCi") diff --git a/IHP/IDE/Types.hs b/IHP/IDE/Types.hs index a38c749f7..59ef17ba2 100644 --- a/IHP/IDE/Types.hs +++ b/IHP/IDE/Types.hs @@ -12,6 +12,7 @@ import Data.UUID import qualified IHP.Log.Types as Log import qualified IHP.Log as Log import qualified Data.ByteString.Builder as ByteString +import qualified Control.Concurrent.Chan.Unagi as Queue data ManagedProcess = ManagedProcess { inputHandle :: !Handle @@ -43,7 +44,6 @@ data Action = | UpdateAppGHCIState AppGHCIState | AppModulesLoaded { success :: !Bool } | AppStarted - | ReceiveAppOutput { line :: !OutputLine } | AssetChanged | HaskellFileChanged | SchemaChanged @@ -156,6 +156,8 @@ data Context = Context , appStateRef :: !(IORef AppState) , isDebugMode :: !Bool , logger :: !Log.Logger + , ghciInChan :: !(Queue.InChan OutputLine) -- ^ Output of the app ghci is written here + , ghciOutChan :: !(Queue.OutChan OutputLine) -- ^ Output of the app ghci is consumed here } dispatch :: (?context :: Context) => Action -> IO () diff --git a/exe/IHP/IDE/DevServer.hs b/exe/IHP/IDE/DevServer.hs index e380b56ee..834e62944 100644 --- a/exe/IHP/IDE/DevServer.hs +++ b/exe/IHP/IDE/DevServer.hs @@ -29,6 +29,7 @@ import Data.Default (def, Default (..)) import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator import Main.Utf8 (withUtf8) import qualified IHP.FrameworkConfig as FrameworkConfig +import qualified Control.Concurrent.Chan.Unagi as Queue main :: IO () main = withUtf8 do @@ -43,7 +44,8 @@ main = withUtf8 do isDebugMode <- maybe False (\value -> value == "1") <$> Env.lookupEnv "DEBUG" logger <- Log.newLogger def - let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger } + (ghciInChan, ghciOutChan) <- Queue.newChan + let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger, ghciInChan, ghciOutChan } -- Print IHP Version when in debug mode when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion)) @@ -56,14 +58,16 @@ main = withUtf8 do installHandler sigINT (Catch catchHandler) Nothing start - async Telemetry.reportTelemetry - forever do - appState <- readIORef appStateRef - when isDebugMode (Log.debug $ " ===> " <> (tshow appState)) - action <- takeMVar actionVar - when isDebugMode (Log.debug $ tshow action) - nextAppState <- handleAction appState action - writeIORef appStateRef nextAppState + + withAsync consumeGhciOutput \_ -> do + async Telemetry.reportTelemetry + forever do + appState <- readIORef appStateRef + when isDebugMode (Log.debug $ " ===> " <> (tshow appState)) + action <- takeMVar actionVar + when isDebugMode (Log.debug $ tshow action) + nextAppState <- handleAction appState action + writeIORef appStateRef nextAppState handleAction :: (?context :: Context) => AppState -> Action -> IO AppState @@ -87,9 +91,6 @@ handleAction state@(AppState { statusServerState = StatusServerNotStarted }) (Up handleAction state@(AppState { statusServerState = StatusServerStarted { } }) (UpdateStatusServerState StatusServerNotStarted) = pure state { statusServerState = StatusServerNotStarted } handleAction state@(AppState { statusServerState = StatusServerPaused { } }) (UpdateStatusServerState statusServerState) = pure state { statusServerState = StatusServerNotStarted } handleAction state (UpdateFileWatcherState fileWatcherState) = pure state { fileWatcherState } -handleAction state@(AppState { statusServerState }) ReceiveAppOutput { line } = do - notifyBrowserOnApplicationOutput statusServerState line - pure state handleAction state@(AppState { appGHCIState, statusServerState, postgresState }) (AppModulesLoaded { success = True }) = do case appGHCIState of AppGHCILoading { .. } -> do @@ -158,7 +159,7 @@ handleAction state@(AppState { liveReloadNotificationServerState, appGHCIState, lastSchemaCompilerError <- readIORef state.lastSchemaCompilerError case lastSchemaCompilerError of - Just exception -> dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) }) + Just exception -> receiveAppOutput (ErrorOutput (cs $ displayException exception)) Nothing -> pure () let appGHCIState' = @@ -304,15 +305,15 @@ startAppGHCI = do else if "modules loaded." `isInfixOf` line then do dispatch AppModulesLoaded { success = True } - else dispatch ReceiveAppOutput { line = StandardOutput line } + else receiveAppOutput (StandardOutput line) async $ forever $ ByteString.hGetLine errorHandle >>= \line -> do unless isDebugMode (Log.info line) if "cannot find object file for module" `isInfixOf` line then do forEach loadAppCommands (sendGhciCommand process) - dispatch ReceiveAppOutput { line = ErrorOutput "Linking Issue: Reloading Main" } - else dispatch ReceiveAppOutput { line = ErrorOutput line } + receiveAppOutput (ErrorOutput "Linking Issue: Reloading Main") + else receiveAppOutput (ErrorOutput line) -- Compile Schema before loading the app @@ -322,6 +323,8 @@ startAppGHCI = do dispatch (UpdateAppGHCIState (AppGHCILoading { .. })) +receiveAppOutput :: (?context :: Context) => OutputLine -> IO () +receiveAppOutput line = Queue.writeChan ?context.ghciInChan line startLoadedApp :: (?context :: Context) => AppGHCIState -> IO () startLoadedApp (AppGHCIModulesLoaded { .. }) = do @@ -356,7 +359,7 @@ updateDatabaseIsOutdated state = ((do writeIORef databaseNeedsMigrationRef databaseNeedsMigration ) `catch` (\(exception :: SomeException) -> do Log.error (tshow exception) - dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ tshow exception) }) + receiveAppOutput (ErrorOutput (cs $ tshow exception)) )) tryCompileSchema :: (?context :: Context) => IO () @@ -367,7 +370,7 @@ tryCompileSchema = writeIORef state.lastSchemaCompilerError Nothing ) `catch` (\(exception :: SomeException) -> do Log.error (tshow exception) - dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) }) + receiveAppOutput (ErrorOutput (cs $ displayException exception)) state <- readIORef ?context.appStateRef writeIORef state.lastSchemaCompilerError (Just exception)