Refactored state handling of live reload notification server

IHP/IDE/LiveReloadNotificationServer.hs

@@ -8,14 +8,15 @@ import qualified Control.Exception as Exception
 import qualified Data.UUID.V4 as UUID
 import qualified Data.Map as Map
 
-notifyHaskellChange :: LiveReloadNotificationServerState -> IO ()
+notifyHaskellChange :: (?context :: Context) => IO ()
 notifyHaskellChange = broadcast "reload"
 
-notifyAssetChange :: LiveReloadNotificationServerState -> IO ()
+notifyAssetChange :: (?context :: Context) => IO ()
 notifyAssetChange = broadcast "reload_assets"
 
-broadcast :: ByteString -> LiveReloadNotificationServerState -> IO ()
-broadcast message LiveReloadNotificationServerState { clients } = do
+broadcast :: (?context :: Context) => ByteString -> IO ()
+broadcast message = do
+    let clients = ?context.liveReloadClients
     clients' <- readIORef clients
 
     let removeClient connectionId = modifyIORef clients (Map.delete connectionId)
@@ -25,8 +26,10 @@ broadcast message LiveReloadNotificationServerState { clients } = do
     forConcurrently connections sendMessage
     pure ()
 
-app :: LiveReloadNotificationServerState -> Websocket.ServerApp
-app LiveReloadNotificationServerState { clients } pendingConnection = do
+app :: (?context :: Context) => Websocket.ServerApp
+app pendingConnection = do
+    let clients = ?context.liveReloadClients
+
     connection <- Websocket.acceptRequest pendingConnection
     connectionId <- UUID.nextRandom
 

IHP/IDE/ToolServer.hs

@@ -92,16 +92,11 @@ startToolServer' port isDebugMode = do
 
     let logMiddleware = if isDebugMode then get #requestLoggerMiddleware frameworkConfig else IHP.Prelude.id
 
-    liveReloadNotificationServerState <- ?context
-            |> get #appStateRef
-            |> readIORef
-            >>= pure . get #liveReloadNotificationServerState
-
     Warp.runSettings warpSettings $
             staticMiddleware $ logMiddleware $ methodOverridePost $ sessionMiddleware
                 $ Websocket.websocketsOr
                     Websocket.defaultConnectionOptions
-                    (LiveReloadNotificationServer.app liveReloadNotificationServerState)
+                    LiveReloadNotificationServer.app
                     application
 
 openUrl :: Text -> IO ()

IHP/IDE/Types.hs

@@ -48,7 +48,6 @@ data Action =
     | HaskellFileChanged
     | SchemaChanged
     | UpdateStatusServerState !StatusServerState
-    | UpdateLiveReloadNotificationServerState !LiveReloadNotificationServerState
     | PauseApp
     deriving (Show)
 
@@ -74,12 +73,6 @@ instance Show AppGHCIState where
     show AppGHCIModulesLoaded { } = "Loaded"
     show RunningAppGHCI { } = "Running"
 
-data LiveReloadNotificationServerState
-    = LiveReloadNotificationServerState { clients :: !(IORef (Map UUID Websocket.Connection)) }
-
-instance Show LiveReloadNotificationServerState where
-    show LiveReloadNotificationServerState { } = "LiveReloadNotificationServerState"
-
 data StatusServerState
     = StatusServerNotStarted
     | StatusServerStarted
@@ -109,21 +102,18 @@ data AppState = AppState
     { postgresState :: !PostgresState
     , appGHCIState :: !AppGHCIState
     , statusServerState :: !StatusServerState
-    , liveReloadNotificationServerState :: !LiveReloadNotificationServerState
     , databaseNeedsMigration :: !(IORef Bool)
     , lastSchemaCompilerError :: !(IORef (Maybe SomeException))
     } deriving (Show)
 
 emptyAppState :: IO AppState
 emptyAppState = do
-    clients <- newIORef mempty
     databaseNeedsMigration <- newIORef False
     lastSchemaCompilerError <- newIORef Nothing
     pure AppState
         { postgresState = PostgresNotStarted
         , appGHCIState = AppGHCINotStarted
         , statusServerState = StatusServerNotStarted
-        , liveReloadNotificationServerState = LiveReloadNotificationServerState { clients }
         , databaseNeedsMigration
         , lastSchemaCompilerError
         }
@@ -136,6 +126,7 @@ data Context = Context
     , 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
+    , liveReloadClients :: !(IORef (Map UUID Websocket.Connection))
     }
 
 dispatch :: (?context :: Context) => Action -> IO ()

exe/IHP/IDE/DevServer.hs

@@ -46,7 +46,8 @@ main = withUtf8 do
 
     logger <- Log.newLogger def
     (ghciInChan, ghciOutChan) <- Queue.newChan
-    let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger, ghciInChan, ghciOutChan }
+    liveReloadClients <- newIORef mempty
+    let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger, ghciInChan, ghciOutChan, liveReloadClients }
 
     -- Print IHP Version when in debug mode
     when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion))
@@ -119,7 +120,7 @@ handleAction state@(AppState { appGHCIState, statusServerState, postgresState })
             -- You can trigger this case by running: $ while true; do touch test.hs; done;
             when (get #isDebugMode ?context) (Log.debug ("AppGHCIModulesLoaded triggered multiple times. This happens when multiple file change events are detected. Skipping app start as the app is already starting from a previous file change event" :: Text))
             pure state
-handleAction state@(AppState { appGHCIState, statusServerState, postgresState, liveReloadNotificationServerState }) (AppModulesLoaded { success = False }) = do
+handleAction state@(AppState { appGHCIState, statusServerState, postgresState }) (AppModulesLoaded { success = False }) = do
     statusServerState' <- case statusServerState of
         s@(StatusServerPaused { .. }) -> do
             async $ continueStatusServer s
@@ -133,22 +134,22 @@ handleAction state@(AppState { appGHCIState, statusServerState, postgresState, l
                 RunningAppGHCI { .. } -> AppGHCIModulesLoaded { .. }
                 AppGHCINotStarted {} -> error "Modules cannot be loaded when ghci not in started state"
 
-    notifyHaskellChange liveReloadNotificationServerState
+    notifyHaskellChange
 
     pure state { statusServerState = statusServerState', appGHCIState = newAppGHCIState }
 
-handleAction state@(AppState { statusServerState, appGHCIState, liveReloadNotificationServerState }) AppStarted = do
-    notifyHaskellChange liveReloadNotificationServerState
+handleAction state@(AppState { statusServerState, appGHCIState }) AppStarted = do
+    notifyHaskellChange
     case appGHCIState of
         AppGHCIModulesLoaded { .. } -> pure state { appGHCIState = RunningAppGHCI { .. } }
         RunningAppGHCI { } -> pure state
         otherwise -> pure state
 
-handleAction state@(AppState { liveReloadNotificationServerState }) AssetChanged = do
-    notifyAssetChange liveReloadNotificationServerState
+handleAction state AssetChanged = do
+    notifyAssetChange
     pure state
 
-handleAction state@(AppState { liveReloadNotificationServerState, appGHCIState, statusServerState }) HaskellFileChanged = do
+handleAction state@(AppState { appGHCIState, statusServerState }) HaskellFileChanged = do
     case appGHCIState of
         AppGHCIModulesLoaded { .. } -> sendGhciCommand process ":r"
         RunningAppGHCI { .. } -> do