module IHP.IDE.LiveReloadNotificationServer (app, notifyHaskellChange, notifyAssetChange) where import IHP.Prelude import qualified Network.WebSockets as Websocket import qualified Control.Concurrent as Concurrent import IHP.IDE.Types import qualified Control.Exception as Exception import qualified Data.UUID.V4 as UUID import qualified Data.Map as Map notifyHaskellChange :: (?context :: Context) => IO () notifyHaskellChange :: (?context::Context) => IO () notifyHaskellChange = (?context::Context) => ByteString -> IO () ByteString -> IO () broadcast ByteString "reload" notifyAssetChange :: (?context :: Context) => IO () notifyAssetChange :: (?context::Context) => IO () notifyAssetChange = (?context::Context) => ByteString -> IO () ByteString -> IO () broadcast ByteString "reload_assets" broadcast :: (?context :: Context) => ByteString -> IO () broadcast :: (?context::Context) => ByteString -> IO () broadcast ByteString message = do let clients :: IORef (Map UUID Connection) clients = ?context::Context Context ?context.liveReloadClients Map UUID Connection clients' <- IORef (Map UUID Connection) -> IO (Map UUID Connection) forall a. IORef a -> IO a readIORef IORef (Map UUID Connection) clients let removeClient :: UUID -> IO () removeClient UUID connectionId = IORef (Map UUID Connection) -> (Map UUID Connection -> Map UUID Connection) -> IO () forall a. IORef a -> (a -> a) -> IO () modifyIORef IORef (Map UUID Connection) clients (UUID -> Map UUID Connection -> Map UUID Connection forall k a. Ord k => k -> Map k a -> Map k a Map.delete UUID connectionId) let sendMessage :: (UUID, Connection) -> IO () sendMessage (UUID id, Connection connection) = ((Connection -> ByteString -> IO () forall a. WebSocketsData a => Connection -> a -> IO () Websocket.sendTextData Connection connection ByteString message) IO () -> (SomeException -> IO ()) -> IO () forall e a. Exception e => IO a -> (e -> IO a) -> IO a `catch` (\(SomeException e :: SomeException) -> UUID -> IO () removeClient UUID id)) let connections :: [(UUID, Connection)] connections = Map UUID Connection clients' Map UUID Connection -> (Map UUID Connection -> [(UUID, Connection)]) -> [(UUID, Connection)] forall {t1} {t2}. t1 -> (t1 -> t2) -> t2 |> Map UUID Connection -> [(UUID, Connection)] forall k a. Map k a -> [(k, a)] Map.toList [(UUID, Connection)] -> ((UUID, Connection) -> IO ()) -> IO [()] forall (t :: * -> *) a b. Traversable t => t a -> (a -> IO b) -> IO (t b) forConcurrently [(UUID, Connection)] connections (UUID, Connection) -> IO () sendMessage () -> IO () forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure () app :: (?context :: Context) => Websocket.ServerApp app :: (?context::Context) => ServerApp app PendingConnection pendingConnection = do let clients :: IORef (Map UUID Connection) clients = ?context::Context Context ?context.liveReloadClients Connection connection <- PendingConnection -> IO Connection Websocket.acceptRequest PendingConnection pendingConnection UUID connectionId <- IO UUID UUID.nextRandom IORef (Map UUID Connection) -> (Map UUID Connection -> Map UUID Connection) -> IO () forall a. IORef a -> (a -> a) -> IO () modifyIORef IORef (Map UUID Connection) clients (UUID -> Connection -> Map UUID Connection -> Map UUID Connection forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert UUID connectionId Connection connection) let removeClient :: IO () removeClient = IORef (Map UUID Connection) -> (Map UUID Connection -> Map UUID Connection) -> IO () forall a. IORef a -> (a -> a) -> IO () modifyIORef IORef (Map UUID Connection) clients (UUID -> Map UUID Connection -> Map UUID Connection forall k a. Ord k => k -> Map k a -> Map k a Map.delete UUID connectionId) let withPingThread :: IO () -> IO () withPingThread = Connection -> Int -> IO () -> IO () -> IO () forall a. Connection -> Int -> IO () -> IO a -> IO a Websocket.withPingThread Connection connection Int 30 (() -> IO () forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure ()) let keepalive :: IO b keepalive = IO () -> IO b forall (f :: * -> *) a b. Applicative f => f a -> f b forever (Int -> IO () Concurrent.threadDelay Int forall a. Bounded a => a maxBound) IO () -> IO () withPingThread IO () forall {b}. IO b keepalive IO () -> IO () -> IO () forall a b. IO a -> IO b -> IO a `Exception.finally` IO () removeClient