From b6b6a6be772a90f5b13f5bfa2e2de6ea2a43dbc1 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Tue, 20 Feb 2024 04:57:41 +0100 Subject: [PATCH] WS: `send_message` function. Will soon serve for sending keepalive messages. --- src/App/Container.purs | 6 +--- src/App/WS.purs | 69 ++++++++++++++++++++++++------------------ 2 files changed, 41 insertions(+), 34 deletions(-) diff --git a/src/App/Container.purs b/src/App/Container.purs index 034f971..9f1a0b0 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -7,8 +7,6 @@ -- | `App.Container` stores the state of different components (domain list and zone interface) -- | to avoid useless requests to `dnsmanagerd`. -- | --- | TODO: store forms in session storage? --- | -- | `App.Container` detects when a page has been reloaded and: -- | 1. authenticate the user to `dnsmanagerd` via a stored token in session storage. -- | The authentication to `dnsmanagerd` automatically provides own domains and accepted domains (such as `netlib.re`). @@ -37,12 +35,10 @@ -- | - mail verification: TODO -- | - domain list: domain (`label`) is insufficient. -- | --- | TODO: when reading a RR `name`, always make it an FQDN by adding `.netlib.re.". +-- | TODO: when reading a RR `name`, always make it an FQDN by adding `.netlib.re.`. -- | -- | TODO: remove the FQDN when showing RR names. -- | --- | TODO: authd administrative page --- | -- | TODO: application-level heartbeat to avoid disconnections. -- | -- | Untested features: diff --git a/src/App/WS.purs b/src/App/WS.purs index 0ca53b8..fbee3b4 100644 --- a/src/App/WS.purs +++ b/src/App/WS.purs @@ -2,8 +2,10 @@ -- | This includes telling when a connection is established or closed, and notify a message has been received. module App.WS where -import Prelude (Unit, bind, discard, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map) +import Prelude (Unit, bind, discard, pure, show, void, when + , ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<), (+)) +import Control.Monad.Rec.Class (forever) import Control.Monad.Except (runExcept) import Data.Array as A import Data.ArrayBuffer.Types (ArrayBuffer) @@ -12,6 +14,8 @@ import Data.Either (Either(..)) import Data.Maybe (Maybe(..), isJust, isNothing) import Data.String as String import Data.Tuple (Tuple(..)) +import Effect.Aff as Aff +import Effect.Aff (Milliseconds(..)) import Effect.Aff.Class (class MonadAff) import Effect (Effect) import Foreign as F @@ -30,6 +34,8 @@ import Web.Socket.WebSocket as WS import App.LogMessage +keepalive = 30000.0 :: Number + -- Input is the WS url. type Input = String @@ -47,6 +53,15 @@ data Query a = ToSend ArrayBuffer a type Slot = H.Slot Query Output +-- | `timer` triggers a `Tick` action every `keepalive` seconds. +timer :: forall m a. MonadAff m => a -> m (HS.Emitter a) +timer val = do + { emitter, listener } <- H.liftEffect HS.create + _ <- H.liftAff $ Aff.forkAff $ forever do + Aff.delay $ Milliseconds keepalive + H.liftEffect $ HS.notify listener val + pure emitter + data Action -- | `Initialize` opens the connection (URL is received as an `input` of this component). = Initialize @@ -64,6 +79,8 @@ data Action -- | `Finalize` is the action performed once the component is destroyed, ending the connection. | Finalize + | Tick + -- | Every received websocket message and notification is handled in `HandleWebSocket`. | HandleWebSocket (WebSocketEvent WebSocketMessageType) @@ -77,7 +94,7 @@ type WSInfo } -- | The state of this component only is composed of the websocket. -type State = { wsInfo :: WSInfo } +type State = { wsInfo :: WSInfo, seconds :: Number } component :: forall m. MonadAff m => H.Component Query Input Output m component = @@ -98,13 +115,15 @@ initialState url = , connection: Nothing , reconnect: false } + , seconds: 0.0 } -- | The component shows a string when the connection is established, or a button when the connection has closed. render :: forall m. State -> H.ComponentHTML Action () m -render { wsInfo } +render { wsInfo, seconds } = HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) + , HH.text ("You have been here for " <> show seconds <> " seconds") ] where @@ -137,9 +156,16 @@ handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Out handleAction action = do { wsInfo } <- H.get case action of - Initialize -> + Initialize -> do + _ <- H.subscribe =<< timer Tick handleAction ConnectWebSocket + Tick -> do + H.modify_ \state -> state { seconds = state.seconds + keepalive } + -- TODO: create a message only for applicative keepalive. + -- message + -- send_message message + Finalize -> do -- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'" case wsInfo.connection of @@ -200,36 +226,21 @@ handleAction action = do handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery = case _ of - ToSend message a -> do + ToSend message a -> send_message message + +send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit +send_message message = { wsInfo } <- H.get case wsInfo.connection of - Nothing -> do - H.raise $ Log $ UnableToSend "Not connected to server." - pure Nothing - + Nothing -> H.raise $ Log $ UnableToSend "Not connected to server." Just webSocket -> do H.liftEffect (WS.readyState webSocket) >>= case _ of - Connecting -> do - H.raise $ Log $ UnableToSend "Still connecting to server." - pure Nothing - - Closing -> do - H.raise $ Log $ UnableToSend "Connection to server is closing." - pure Nothing - - Closed -> do + Connecting -> H.raise $ Log $ UnableToSend "Still connecting to server." + Closing -> H.raise $ Log $ UnableToSend "Connection to server is closing." + Closed -> do H.raise $ Log $ UnableToSend "Connection to server has been closed." - maybeCurrentConnection <- H.gets _.wsInfo.connection - when (isJust maybeCurrentConnection) do - H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } } - pure Nothing - - Open -> do - H.liftEffect $ do - sendArrayBuffer webSocket message - pure (Just a) - - + H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } } + Open -> H.liftEffect $ sendArrayBuffer webSocket message -------------------------------------------------------------------------------- -- WebSocket mess. --------------------------------------------------------------------------------