335 lines
12 KiB
Plaintext
335 lines
12 KiB
Plaintext
-- | This component handles all WS operations.
|
|
-- | 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, (=<<), unit)
|
|
|
|
import Control.Monad.Rec.Class (forever)
|
|
import Control.Monad.Except (runExcept)
|
|
import Data.Array as A
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Bifunctor (lmap)
|
|
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
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Events as HE
|
|
import Halogen.HTML.Properties as HP
|
|
import Halogen.Query.Event as HQE
|
|
import Halogen.Subscription as HS
|
|
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
|
|
import Web.Socket.Event.CloseEvent as WSCE
|
|
import Web.Socket.Event.EventTypes as WSET
|
|
import Web.Socket.Event.MessageEvent as WSME
|
|
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
|
import Web.Socket.WebSocket as WS
|
|
|
|
import App.Type.LogMessage
|
|
|
|
keepalive = 30000.0 :: Number
|
|
|
|
-- Input is the WS url.
|
|
type Input = String
|
|
|
|
-- | The component can perform 4 actions: log messages, notify that a message has been received,
|
|
-- | notify when a connection has been established or when it has been closed.
|
|
data Output
|
|
-- | MessageReceived (Tuple URL message)
|
|
= MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent.
|
|
| WSJustConnected -- Inform the parent the connection is up.
|
|
| WSJustClosed -- Inform the parent the connection is down.
|
|
| Log LogMessage
|
|
| KeepAlive -- Ask the parent to handle a keep-alive message.
|
|
|
|
-- | The component can receive a single action from other components: sending a message throught the websocket.
|
|
data Query a = ToSend ArrayBuffer a
|
|
|
|
type Slot = H.Slot Query Output
|
|
|
|
-- | `timer` triggers a `Tick` action every `keepalive` ms.
|
|
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
|
|
|
|
-- | The component provides a log each time a message failed to be parsed.
|
|
| WebSocketParseError String
|
|
|
|
-- | The component shows buttons when the connection is dropped for some reason.
|
|
-- | To reconnect, the button is clicked, and the `ConnectWebSocket` action is performed.
|
|
| ConnectWebSocket
|
|
|
|
-- | `SendMessage` effectively sends a message through the ws connection.
|
|
| SendMessage ArrayBuffer
|
|
|
|
-- | `Finalize` is the action performed once the component is destroyed, ending the connection.
|
|
| Finalize
|
|
|
|
-- | Tick: keep alive WS connections.
|
|
| Tick
|
|
|
|
-- | Every received websocket message and notification is handled in `HandleWebSocket`.
|
|
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
|
|
|
-- | The type `WSInfo` helps handle a websocket.
|
|
-- | `WSInfo` is composed of an URL, an actual socket and a boolean
|
|
-- | to inform if the connection has to be re-established.
|
|
type WSInfo
|
|
= { url :: String
|
|
, connection :: Maybe WS.WebSocket
|
|
, reconnect :: Boolean
|
|
}
|
|
|
|
-- | The state of this component only is composed of the websocket.
|
|
type State = { wsInfo :: WSInfo }
|
|
|
|
component :: forall m. MonadAff m => H.Component Query Input Output m
|
|
component =
|
|
H.mkComponent
|
|
{ initialState
|
|
, render
|
|
, eval: H.mkEval $ H.defaultEval
|
|
{ initialize = Just Initialize
|
|
, handleAction = handleAction
|
|
, handleQuery = handleQuery
|
|
, finalize = Just Finalize
|
|
}
|
|
}
|
|
|
|
initialState :: Input -> State
|
|
initialState url =
|
|
{ wsInfo: { url: url
|
|
, connection: Nothing
|
|
, reconnect: false
|
|
}
|
|
}
|
|
|
|
-- | 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 }
|
|
= HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ]
|
|
where
|
|
renderFootnote :: String -> H.ComponentHTML Action () m
|
|
renderFootnote txt =
|
|
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
|
|
|
|
renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
|
|
renderReconnectButton cond =
|
|
if cond
|
|
then
|
|
HH.p_
|
|
[ HH.button
|
|
[ HP.type_ HP.ButtonButton
|
|
, HE.onClick \_ -> ConnectWebSocket
|
|
]
|
|
[ HH.text "Reconnect?" ]
|
|
]
|
|
else
|
|
HH.p_
|
|
[ renderFootnote $
|
|
"NOTE: A 'Reconnect?' button will appear if the connection drops (for URL: '"
|
|
<>
|
|
wsInfo.url
|
|
<>
|
|
"')"
|
|
]
|
|
|
|
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
|
handleAction action = do
|
|
{ wsInfo } <- H.get
|
|
case action of
|
|
Initialize -> do
|
|
_ <- H.subscribe =<< timer Tick
|
|
handleAction ConnectWebSocket
|
|
|
|
Tick -> H.raise KeepAlive
|
|
|
|
Finalize -> do
|
|
-- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
|
|
case wsInfo.connection of
|
|
Nothing -> H.raise $ Log $ SystemLog "No socket? How is that even possible?"
|
|
Just socket -> H.liftEffect $ WS.close socket
|
|
|
|
WebSocketParseError error ->
|
|
H.raise $ Log $ SystemLog $ renderError (UnknownError error)
|
|
|
|
ConnectWebSocket -> do
|
|
-- H.raise $ Log $ SystemLog $ "Connecting to \"" <> wsInfo.url <> "\"..."
|
|
webSocket <- H.liftEffect $ WS.create wsInfo.url []
|
|
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
|
|
H.modify_ _ { wsInfo { connection = Just webSocket } }
|
|
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
|
|
|
|
SendMessage array_buffer_to_send -> do
|
|
case wsInfo.connection of
|
|
Nothing -> H.raise $ Log $ UnableToSend $ "Websocket is down!"
|
|
Just webSocket -> H.liftEffect $ do
|
|
sendArrayBuffer webSocket array_buffer_to_send
|
|
|
|
HandleWebSocket wsEvent -> do
|
|
case wsEvent of
|
|
WebSocketMessage received_message -> do
|
|
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
|
|
|
|
WebSocketOpen -> do
|
|
H.raise $ WSJustConnected
|
|
|
|
WebSocketClose { code, reason, wasClean } -> do
|
|
H.raise $ Log $ SystemLog $ renderCloseMessage code wasClean reason
|
|
maybeCurrentConnection <- H.gets _.wsInfo.connection
|
|
when (isJust maybeCurrentConnection) do
|
|
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
|
|
H.raise $ WSJustClosed
|
|
|
|
WebSocketError errorType -> do
|
|
H.raise $ Log $ SystemLog $ renderError errorType
|
|
H.raise $ WSJustClosed
|
|
|
|
where
|
|
renderCloseMessage
|
|
:: Int
|
|
-> Boolean
|
|
-> String
|
|
-> String
|
|
renderCloseMessage code wasClean = case _ of
|
|
"" -> baseCloseMessage
|
|
reason -> baseCloseMessage <> "Reason: " <> reason
|
|
where
|
|
baseCloseMessage :: String
|
|
baseCloseMessage =
|
|
String.joinWith " "
|
|
[ "Connection to WebSocket closed"
|
|
, "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]"
|
|
]
|
|
|
|
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
|
handleQuery = case _ of
|
|
ToSend message a -> do
|
|
send_message message
|
|
pure (Just a)
|
|
|
|
send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
|
|
send_message message = do
|
|
{ wsInfo } <- H.get
|
|
case wsInfo.connection of
|
|
Nothing -> H.raise $ Log $ UnableToSend "Not connected to server."
|
|
Just webSocket -> do
|
|
H.liftEffect (WS.readyState webSocket) >>= case _ of
|
|
Connecting -> pure unit -- 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."
|
|
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
|
|
Open -> H.liftEffect $ sendArrayBuffer webSocket message
|
|
--------------------------------------------------------------------------------
|
|
-- WebSocket mess.
|
|
--------------------------------------------------------------------------------
|
|
|
|
data WebSocketEvent :: Type -> Type
|
|
data WebSocketEvent msg
|
|
= WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
|
|
| WebSocketOpen
|
|
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
|
|
| WebSocketError ErrorType
|
|
|
|
webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
|
|
webSocketEmitter socket = do
|
|
|
|
HS.makeEmitter \push -> do
|
|
|
|
openId <- HS.subscribe openEmitter push
|
|
errorId <- HS.subscribe errorEmitter push
|
|
closeId <- HS.subscribe closeEmitter push
|
|
messageId <- HS.subscribe messageEmitter push
|
|
|
|
pure do
|
|
HS.unsubscribe openId
|
|
HS.unsubscribe errorId
|
|
HS.unsubscribe closeId
|
|
HS.unsubscribe messageId
|
|
|
|
where
|
|
target = WS.toEventTarget socket
|
|
|
|
openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
|
openEmitter =
|
|
HQE.eventListener WSET.onOpen target \_ ->
|
|
Just WebSocketOpen
|
|
|
|
errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
|
errorEmitter =
|
|
HQE.eventListener WSET.onError target \_ ->
|
|
Just (WebSocketError UnknownWebSocketError)
|
|
|
|
closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
|
closeEmitter =
|
|
HQE.eventListener WSET.onClose target \event ->
|
|
WSCE.fromEvent event >>= \closeEvent ->
|
|
Just $ WebSocketClose { code: WSCE.code closeEvent
|
|
, reason: WSCE.reason closeEvent
|
|
, wasClean: WSCE.wasClean closeEvent
|
|
}
|
|
|
|
messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
|
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
|
|
|
|
decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
|
|
decodeMessageEvent = \msgEvent -> do
|
|
let
|
|
foreign' :: F.Foreign
|
|
foreign' = WSME.data_ msgEvent
|
|
case foreignToArrayBuffer foreign' of
|
|
Left errs -> pure $ WebSocketError $ UnknownError errs
|
|
Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer
|
|
, origin: WSME.origin msgEvent
|
|
, lastEventId: WSME.lastEventId msgEvent }
|
|
|
|
---------------------------
|
|
-- Errors
|
|
---------------------------
|
|
|
|
data ErrorType
|
|
= UnknownError String
|
|
| UnknownWebSocketError
|
|
|
|
renderError :: ErrorType -> String
|
|
renderError = case _ of
|
|
UnknownError str ->
|
|
"Unknown error: " <> str
|
|
UnknownWebSocketError ->
|
|
"Unknown 'error' event has been fired by WebSocket event listener"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- WebSocket message type
|
|
--------------------------------------------------------------------------------
|
|
|
|
type WebSocketMessageType = ArrayBuffer
|
|
|
|
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
|
|
sendArrayBuffer = WS.sendArrayBuffer
|
|
|
|
foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
|
|
foreignToArrayBuffer
|
|
= lmap renderForeignErrors
|
|
<<< runExcept
|
|
<<< F.unsafeReadTagged "ArrayBuffer"
|
|
where
|
|
renderForeignErrors :: F.MultipleErrors -> String
|
|
renderForeignErrors =
|
|
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
|