halogen-websocket-ipc-playzone/src/App/WS.purs

209 lines
6.6 KiB
Plaintext
Raw Normal View History

2023-07-03 18:03:47 +02:00
module App.WS where
{- This component handles all WS operations. -}
2023-07-04 02:58:17 +02:00
import Prelude (Unit, bind, discard, map, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=), unit)
2023-07-03 18:03:47 +02:00
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 is the WS url.
2023-07-03 18:03:47 +02:00
type Input = String
2023-07-03 18:03:47 +02:00
-- 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.
2023-07-04 02:58:17 +02:00
| AppendSystemMessage String -- System message to print.
| AppendMessage String -- Basic message to print.
| UnableToSend String -- Message to print: cannot send a packet.
2023-07-03 18:03:47 +02:00
type Slot = H.Slot Query Output
2023-07-03 18:03:47 +02:00
data Query a
= ToSend ArrayBuffer a
2023-07-03 18:03:47 +02:00
data Action
= Initialize
| WebSocketParseError String
| ConnectWebSocket
| SendMessage ArrayBuffer
| Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
type WSInfo
= { url :: String
, connection :: Maybe WS.WebSocket
, reconnect :: Boolean
}
2023-07-04 02:58:17 +02:00
type State = { wsInfo :: WSInfo }
2023-07-03 18:03:47 +02:00
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
2023-07-03 18:03:47 +02:00
, finalize = Just Finalize
}
}
initialState :: Input -> State
initialState url =
2023-07-04 02:58:17 +02:00
{ wsInfo: { url: url
2023-07-03 18:03:47 +02:00
, connection: Nothing
, reconnect: false
}
}
render :: forall m. State -> H.ComponentHTML Action () m
2023-07-04 02:58:17 +02:00
render { wsInfo }
2023-07-03 18:03:47 +02:00
= HH.div_
2023-07-04 02:58:17 +02:00
[ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
2023-07-03 18:03:47 +02:00
]
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"
]
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
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage "Finalize"
2023-07-03 18:03:47 +02:00
case wsInfo.connection of
2023-07-04 02:58:17 +02:00
Nothing -> H.raise $ AppendSystemMessage "No socket? How is that even possible?"
2023-07-03 18:03:47 +02:00
Just socket -> H.liftEffect $ WS.close socket
WebSocketParseError error ->
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage $ renderError (UnknownError error)
2023-07-03 18:03:47 +02:00
ConnectWebSocket -> do
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
2023-07-03 18:03:47 +02:00
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
2023-07-04 02:58:17 +02:00
Nothing -> H.raise $ AppendMessage $ "[🤖] Can't send a message, websocket is down!"
2023-07-03 18:03:47 +02:00
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
2023-07-04 02:58:17 +02:00
H.raise $ AppendMessage $ "[😈] Received a message"
2023-07-03 18:03:47 +02:00
WebSocketOpen -> do
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
2023-07-03 18:03:47 +02:00
H.raise $ WSJustConnected
WebSocketClose { code, reason, wasClean } -> do
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage $ renderCloseMessage code wasClean reason
2023-07-03 18:03:47 +02:00
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
H.raise $ WSJustClosed
WebSocketError errorType ->
2023-07-04 02:58:17 +02:00
H.raise $ AppendSystemMessage $ renderError errorType
2023-07-03 18:03:47 +02:00
-- 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
2023-07-04 02:58:17 +02:00
H.raise $ UnableToSend "Not connected to server."
2023-07-03 18:03:47 +02:00
pure Nothing
Just webSocket -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting -> do
2023-07-04 02:58:17 +02:00
H.raise $ UnableToSend "Still connecting to server."
2023-07-03 18:03:47 +02:00
pure Nothing
Closing -> do
2023-07-04 02:58:17 +02:00
H.raise $ UnableToSend "Connection to server is closing."
2023-07-03 18:03:47 +02:00
pure Nothing
Closed -> do
2023-07-04 02:58:17 +02:00
H.raise $ UnableToSend "Connection to server has been closed."
2023-07-03 18:03:47 +02:00
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)