WS component (WIP).

beta
Philippe Pittoli 2023-07-03 18:03:47 +02:00
parent 320ff4f2ec
commit 88aa805613
1 changed files with 221 additions and 0 deletions

221
src/App/WS.purs Normal file
View File

@ -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))