WS component (WIP).
parent
320ff4f2ec
commit
88aa805613
|
@ -0,0 +1,221 @@
|
|||
module App.WS where
|
||||
|
||||
{- This component handles all WS operations. -}
|
||||
|
||||
import Prelude (Unit, bind, discard, map, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=))
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import Data.Maybe (Maybe(..), isJust, isNothing)
|
||||
import Data.String as String
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Socket.WebSocket as WS
|
||||
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
||||
|
||||
import App.Utils
|
||||
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
|
||||
|
||||
-- Input = url
|
||||
type Input = String
|
||||
-- MessageReceived (Tuple URL message)
|
||||
data Output
|
||||
= 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.
|
||||
--| AppendSystemMessage String -- System message to print.
|
||||
--| AppendMessage String -- Basic message to print.
|
||||
--type Slot = H.Slot Query Output
|
||||
|
||||
--type Query :: forall k. k -> Type
|
||||
data Query a = ToSend ArrayBuffer a
|
||||
|
||||
data NewDomainFormAction
|
||||
= INP_newdomain String
|
||||
| UpdateSelectedDomain String
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
| WebSocketParseError String
|
||||
| ConnectWebSocket
|
||||
|
||||
| SendMessage ArrayBuffer
|
||||
|
||||
| Finalize
|
||||
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||
|
||||
type WSInfo
|
||||
= { url :: String
|
||||
, connection :: Maybe WS.WebSocket
|
||||
, reconnect :: Boolean
|
||||
}
|
||||
|
||||
type State =
|
||||
{ messages :: Array String
|
||||
, messageHistoryLength :: Int
|
||||
, 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
|
||||
, finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState url =
|
||||
{ messages: []
|
||||
, messageHistoryLength: 10
|
||||
, wsInfo: { url: url
|
||||
, connection: Nothing
|
||||
, reconnect: false
|
||||
}
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { messages, wsInfo }
|
||||
= HH.div_
|
||||
[ Bulma.h1 "WS BOX"
|
||||
, render_messages
|
||||
, renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
|
||||
]
|
||||
where
|
||||
|
||||
render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
|
||||
|
||||
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"
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction action = do
|
||||
{ wsInfo } <- H.get
|
||||
case action of
|
||||
Initialize ->
|
||||
handleAction ConnectWebSocket
|
||||
|
||||
Finalize -> do
|
||||
systemMessage "Finalize"
|
||||
case wsInfo.connection of
|
||||
Nothing -> systemMessage "No socket? How is that even possible?"
|
||||
Just socket -> H.liftEffect $ WS.close socket
|
||||
|
||||
WebSocketParseError error ->
|
||||
systemMessage $ renderError (UnknownError error)
|
||||
|
||||
ConnectWebSocket -> do
|
||||
systemMessage ("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 -> appendMessage $ "[🤖] Can't send a message, websocket is down!"
|
||||
Just webSocket -> H.liftEffect $ do
|
||||
sendArrayBuffer webSocket array_buffer_to_send
|
||||
|
||||
HandleWebSocket wsEvent -> do
|
||||
case wsEvent of
|
||||
WebSocketMessage received_message -> do
|
||||
appendMessage $ "[😈] Received a message, ignored for now"
|
||||
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
|
||||
|
||||
WebSocketOpen -> do
|
||||
systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
|
||||
H.raise $ WSJustConnected
|
||||
|
||||
WebSocketClose { code, reason, wasClean } -> do
|
||||
systemMessage $ 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 ->
|
||||
systemMessage $ renderError errorType
|
||||
-- TODO: MAYBE inform the parent the connection is closed (if it's the case).
|
||||
|
||||
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
|
||||
{ wsInfo } <- H.get
|
||||
case wsInfo.connection of
|
||||
Nothing -> do
|
||||
unableToSend "Not connected to server."
|
||||
pure Nothing
|
||||
|
||||
Just webSocket -> do
|
||||
H.liftEffect (WS.readyState webSocket) >>= case _ of
|
||||
Connecting -> do
|
||||
unableToSend "Still connecting to server."
|
||||
pure Nothing
|
||||
|
||||
Closing -> do
|
||||
unableToSend "Connection to server is closing."
|
||||
pure Nothing
|
||||
|
||||
Closed -> do
|
||||
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)
|
||||
|
||||
-- Request reply ->
|
||||
-- pure (Just (reply true))
|
Loading…
Reference in New Issue