WS: send_message
function. Will soon serve for sending keepalive messages.
This commit is contained in:
parent
bcc76c8378
commit
b6b6a6be77
@ -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 `<user-domain>.netlib.re.".
|
||||
-- | TODO: when reading a RR `name`, always make it an FQDN by adding `<user-domain>.netlib.re.`.
|
||||
-- |
|
||||
-- | TODO: remove the FQDN when showing RR names.
|
||||
-- |
|
||||
-- | TODO: authd administrative page
|
||||
-- |
|
||||
-- | TODO: application-level heartbeat to avoid disconnections.
|
||||
-- |
|
||||
-- | Untested features:
|
||||
|
@ -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.
|
||||
--------------------------------------------------------------------------------
|
||||
|
Loading…
Reference in New Issue
Block a user