re: better with the attached files.
parent
48006c37e8
commit
b4f5a4aefa
|
|
@ -0,0 +1,51 @@
|
||||||
|
module App.ComponentA where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.HTML as HH
|
||||||
|
import Halogen.HTML.Events as HE
|
||||||
|
|
||||||
|
type Slot = H.Slot Query Void
|
||||||
|
|
||||||
|
data Query a = IsOn (Boolean -> a)
|
||||||
|
|
||||||
|
data Action = Toggle
|
||||||
|
|
||||||
|
type State = Boolean
|
||||||
|
|
||||||
|
component :: forall i o m. H.Component Query i o m
|
||||||
|
component =
|
||||||
|
H.mkComponent
|
||||||
|
{ initialState
|
||||||
|
, render
|
||||||
|
, eval: H.mkEval $ H.defaultEval
|
||||||
|
{ handleAction = handleAction
|
||||||
|
, handleQuery = handleQuery
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
initialState :: forall i. i -> State
|
||||||
|
initialState _ = false
|
||||||
|
|
||||||
|
render :: forall m. State -> H.ComponentHTML Action () m
|
||||||
|
render state =
|
||||||
|
HH.div_
|
||||||
|
[ HH.p_ [ HH.text "Toggle me!" ]
|
||||||
|
, HH.button
|
||||||
|
[ HE.onClick \_ -> Toggle ]
|
||||||
|
[ HH.text (if state then "On" else "Off") ]
|
||||||
|
]
|
||||||
|
|
||||||
|
handleAction :: forall o m. Action -> H.HalogenM State Action () o m Unit
|
||||||
|
handleAction = case _ of
|
||||||
|
Toggle ->
|
||||||
|
H.modify_ not
|
||||||
|
|
||||||
|
handleQuery :: forall o m a. Query a -> H.HalogenM State Action () o m (Maybe a)
|
||||||
|
handleQuery = case _ of
|
||||||
|
IsOn k -> do
|
||||||
|
enabled <- H.get
|
||||||
|
pure (Just (k enabled))
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
module App.ComponentB where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.HTML as HH
|
||||||
|
import Halogen.HTML.Events as HE
|
||||||
|
|
||||||
|
type Slot = H.Slot Query Void
|
||||||
|
|
||||||
|
data Query a = GetCount (Int -> a)
|
||||||
|
|
||||||
|
data Action = Increment
|
||||||
|
|
||||||
|
type State = Int
|
||||||
|
|
||||||
|
component :: forall i o m. H.Component Query i o m
|
||||||
|
component =
|
||||||
|
H.mkComponent
|
||||||
|
{ initialState
|
||||||
|
, render
|
||||||
|
, eval: H.mkEval $ H.defaultEval
|
||||||
|
{ handleAction = handleAction
|
||||||
|
, handleQuery = handleQuery
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
initialState :: forall i. i -> State
|
||||||
|
initialState _ = 0
|
||||||
|
|
||||||
|
render :: forall m. State -> H.ComponentHTML Action () m
|
||||||
|
render state =
|
||||||
|
HH.div_
|
||||||
|
[ HH.p_
|
||||||
|
[ HH.text "Current value:"
|
||||||
|
, HH.strong_ [ HH.text (show state) ]
|
||||||
|
]
|
||||||
|
, HH.button
|
||||||
|
[ HE.onClick \_ -> Increment ]
|
||||||
|
[ HH.text ("Increment") ]
|
||||||
|
]
|
||||||
|
|
||||||
|
handleAction :: forall o m. Action -> H.HalogenM State Action () o m Unit
|
||||||
|
handleAction = case _ of
|
||||||
|
Increment ->
|
||||||
|
H.modify_ (_ + 1)
|
||||||
|
|
||||||
|
handleQuery :: forall o m a. Query a -> H.HalogenM State Action () o m (Maybe a)
|
||||||
|
handleQuery = case _ of
|
||||||
|
GetCount k ->
|
||||||
|
Just <<< k <$> H.get
|
||||||
|
|
@ -0,0 +1,52 @@
|
||||||
|
module App.ComponentC where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.HTML as HH
|
||||||
|
import Halogen.HTML.Events as HE
|
||||||
|
import Halogen.HTML.Properties as HP
|
||||||
|
|
||||||
|
type Slot = H.Slot Query Void
|
||||||
|
|
||||||
|
data Query a = GetValue (String -> a)
|
||||||
|
|
||||||
|
data Action = HandleInput String
|
||||||
|
|
||||||
|
type State = String
|
||||||
|
|
||||||
|
component :: forall i o m. H.Component Query i o m
|
||||||
|
component =
|
||||||
|
H.mkComponent
|
||||||
|
{ initialState
|
||||||
|
, render
|
||||||
|
, eval: H.mkEval $ H.defaultEval
|
||||||
|
{ handleAction = handleAction
|
||||||
|
, handleQuery = handleQuery
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
initialState :: forall i. i -> State
|
||||||
|
initialState _ = "Hello"
|
||||||
|
|
||||||
|
render :: forall m. State -> H.ComponentHTML Action () m
|
||||||
|
render state =
|
||||||
|
HH.label_
|
||||||
|
[ HH.p_ [ HH.text "What do you have to say?" ]
|
||||||
|
, HH.input
|
||||||
|
[ HP.value state
|
||||||
|
, HE.onValueInput HandleInput
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
handleAction :: forall o m. Action -> H.HalogenM State Action () o m Unit
|
||||||
|
handleAction = case _ of
|
||||||
|
HandleInput value ->
|
||||||
|
H.put value
|
||||||
|
|
||||||
|
handleQuery :: forall o m a. Query a -> H.HalogenM State Action () o m (Maybe a)
|
||||||
|
handleQuery = case _ of
|
||||||
|
GetValue k ->
|
||||||
|
Just <<< k <$> H.get
|
||||||
|
|
@ -0,0 +1,96 @@
|
||||||
|
module App.Container where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
import App.ComponentA as CA
|
||||||
|
import App.ComponentB as CB
|
||||||
|
import App.ComponentC as CC
|
||||||
|
import App.AuthenticationForm as AF
|
||||||
|
import App.OriginalInterface as OI
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.HTML as HH
|
||||||
|
import Halogen.HTML.Events as HE
|
||||||
|
import Halogen.HTML.Properties as HP
|
||||||
|
import Type.Proxy (Proxy(..))
|
||||||
|
import Effect.Aff.Class (class MonadAff)
|
||||||
|
|
||||||
|
data Action = ReadStates
|
||||||
|
|
||||||
|
type State =
|
||||||
|
{ a :: Maybe Boolean
|
||||||
|
, b :: Maybe Int
|
||||||
|
, c :: Maybe String
|
||||||
|
}
|
||||||
|
|
||||||
|
type ChildSlots =
|
||||||
|
( a :: CA.Slot Unit
|
||||||
|
, b :: CB.Slot Unit
|
||||||
|
, c :: CC.Slot Unit
|
||||||
|
, af :: AF.Slot Unit
|
||||||
|
, oi :: OI.Slot Unit
|
||||||
|
)
|
||||||
|
|
||||||
|
_a = Proxy :: Proxy "a"
|
||||||
|
_b = Proxy :: Proxy "b"
|
||||||
|
_c = Proxy :: Proxy "c"
|
||||||
|
_af = Proxy :: Proxy "af"
|
||||||
|
_oi = Proxy :: Proxy "oi"
|
||||||
|
|
||||||
|
component :: forall q i o m. MonadAff m => H.Component q i o m
|
||||||
|
component =
|
||||||
|
H.mkComponent
|
||||||
|
{ initialState
|
||||||
|
, render
|
||||||
|
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
||||||
|
}
|
||||||
|
|
||||||
|
initialState :: forall i. i -> State
|
||||||
|
initialState _ = { a: Nothing, b: Nothing, c: Nothing }
|
||||||
|
|
||||||
|
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
||||||
|
render state = HH.div_
|
||||||
|
[ HH.div
|
||||||
|
[ HP.class_ (H.ClassName "box") ]
|
||||||
|
[ HH.h1_ [ HH.text "Component A" ]
|
||||||
|
, HH.slot_ _a unit CA.component unit
|
||||||
|
]
|
||||||
|
, HH.div
|
||||||
|
[ HP.class_ (H.ClassName "box") ]
|
||||||
|
[ HH.h1_ [ HH.text "Component B" ]
|
||||||
|
, HH.slot_ _b unit CB.component unit
|
||||||
|
]
|
||||||
|
, HH.div
|
||||||
|
[ HP.class_ (H.ClassName "box") ]
|
||||||
|
[ HH.h1_ [ HH.text "Component C" ]
|
||||||
|
, HH.slot_ _c unit CC.component unit
|
||||||
|
]
|
||||||
|
, HH.p_
|
||||||
|
[ HH.text "Last observed states:" ]
|
||||||
|
, HH.ul_
|
||||||
|
[ HH.li_ [ HH.text ("Component A: " <> show state.a) ]
|
||||||
|
, HH.li_ [ HH.text ("Component B: " <> show state.b) ]
|
||||||
|
, HH.li_ [ HH.text ("Component C: " <> show state.c) ]
|
||||||
|
]
|
||||||
|
, HH.button
|
||||||
|
[ HE.onClick \_ -> ReadStates ]
|
||||||
|
[ HH.text "Check states now" ]
|
||||||
|
, HH.div
|
||||||
|
[ HP.class_ (H.ClassName "box") ]
|
||||||
|
[ HH.h1_ [ HH.text "Authentication form" ]
|
||||||
|
, HH.slot_ _af unit AF.component "ws://127.0.0.1:8080"
|
||||||
|
]
|
||||||
|
, HH.div
|
||||||
|
[ HP.class_ (H.ClassName "box") ]
|
||||||
|
[ HH.h1_ [ HH.text "Original interface" ]
|
||||||
|
, HH.slot_ _oi unit OI.component "ws://127.0.0.1:8080"
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
handleAction :: forall o m. MonadAff m => Action -> H.HalogenM State Action ChildSlots o m Unit
|
||||||
|
handleAction = case _ of
|
||||||
|
ReadStates -> do
|
||||||
|
a <- H.request _a unit CA.IsOn
|
||||||
|
b <- H.request _b unit CB.GetCount
|
||||||
|
c <- H.request _c unit CC.GetValue
|
||||||
|
H.put { a, b, c }
|
||||||
|
|
@ -0,0 +1,411 @@
|
||||||
|
module App.OriginalInterface where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.Except (runExcept)
|
||||||
|
import Control.Monad.State (class MonadState)
|
||||||
|
import Data.Array as A
|
||||||
|
import Data.Bifunctor (lmap)
|
||||||
|
-- import Data.Codec.Argonaut (JsonCodec, JsonDecodeError)
|
||||||
|
-- import Data.Codec.Argonaut as CA
|
||||||
|
import Data.Const (Const)
|
||||||
|
import Data.Either (Either(..))
|
||||||
|
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
|
||||||
|
import Data.String as String
|
||||||
|
import Effect (Effect)
|
||||||
|
import Effect.Aff.Class (class MonadAff)
|
||||||
|
import Foreign (Foreign)
|
||||||
|
import Foreign as F
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.Aff (awaitBody, runHalogenAff) as HA
|
||||||
|
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 Halogen.VDom.Driver (runUI)
|
||||||
|
import Web.Event.Event (Event)
|
||||||
|
import Web.Event.Event as Event
|
||||||
|
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 Data.ArrayBuffer.Types (ArrayBuffer)
|
||||||
|
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
|
||||||
|
|
||||||
|
import App.IPC (toIPC, fromIPC)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- WebSocketEvent type
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
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' :: 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
|
||||||
|
= MessageIsServerAdvertisement String
|
||||||
|
| UnknownError String
|
||||||
|
| UnknownWebSocketError
|
||||||
|
|
||||||
|
renderError :: ErrorType -> String
|
||||||
|
renderError = case _ of
|
||||||
|
UnknownError str ->
|
||||||
|
"Unknown error: " <> str
|
||||||
|
MessageIsServerAdvertisement str ->
|
||||||
|
"Received following advertisment from server: " <> str
|
||||||
|
UnknownWebSocketError ->
|
||||||
|
"Unknown 'error' event has been fired by WebSocket event listener"
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- `Main` function
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
main :: Effect Unit
|
||||||
|
main = HA.runHalogenAff do
|
||||||
|
body <- HA.awaitBody
|
||||||
|
let url = "ws://localhost:8080"
|
||||||
|
runUI component url body
|
||||||
|
-- runUI Container.component unit body
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- WebSocket message type
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
type WebSocketMessageType = ArrayBuffer
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Root component module
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
type Slot = H.Slot Query Void
|
||||||
|
|
||||||
|
type Query :: forall k. k -> Type
|
||||||
|
type Query = Const Void
|
||||||
|
type Input = String
|
||||||
|
type Output = Void
|
||||||
|
|
||||||
|
data Action
|
||||||
|
= Initialize
|
||||||
|
| WebSocketParseError String
|
||||||
|
| ConnectWebSocket
|
||||||
|
| HandleInputUpdate String
|
||||||
|
| SendMessage Event
|
||||||
|
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||||
|
|
||||||
|
type State =
|
||||||
|
{ messages :: Array String
|
||||||
|
, messageHistoryLength :: Int
|
||||||
|
, inputText :: String
|
||||||
|
, wsUrl :: String
|
||||||
|
, wsConnection :: Maybe WS.WebSocket
|
||||||
|
, canReconnect :: Boolean
|
||||||
|
}
|
||||||
|
|
||||||
|
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
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
initialState :: Input -> State
|
||||||
|
initialState input =
|
||||||
|
{ messages: []
|
||||||
|
, messageHistoryLength: 10
|
||||||
|
, inputText: ""
|
||||||
|
, wsUrl: input
|
||||||
|
, wsConnection: Nothing
|
||||||
|
, canReconnect: false
|
||||||
|
}
|
||||||
|
|
||||||
|
wrapperStyle :: String
|
||||||
|
wrapperStyle =
|
||||||
|
"""
|
||||||
|
display: block;
|
||||||
|
flex-direction: column;
|
||||||
|
justify-content: space-between;
|
||||||
|
height: calc(100vh - 30px);
|
||||||
|
background: #282c34;
|
||||||
|
color: #e06c75;
|
||||||
|
font-family: 'Consolas';
|
||||||
|
padding: 5px 20px 5px 20px;
|
||||||
|
"""
|
||||||
|
|
||||||
|
render :: forall m. State -> H.ComponentHTML Action () m
|
||||||
|
render { messages, inputText, wsConnection, canReconnect, messageHistoryLength } =
|
||||||
|
HH.div
|
||||||
|
[ HP.style wrapperStyle ]
|
||||||
|
[ HH.h2_ [ HH.text "WebSocket example for PureScript Halogen" ]
|
||||||
|
, HH.form
|
||||||
|
[ HE.onSubmit SendMessage ]
|
||||||
|
[ HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
|
||||||
|
, HH.p_
|
||||||
|
[ HH.div_
|
||||||
|
[ HH.input
|
||||||
|
[ HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;"
|
||||||
|
, HP.type_ HP.InputText
|
||||||
|
, HP.value inputText
|
||||||
|
, HE.onValueInput HandleInputUpdate
|
||||||
|
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||||
|
]
|
||||||
|
]
|
||||||
|
, HH.div_
|
||||||
|
[ HH.button
|
||||||
|
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||||
|
, HP.type_ HP.ButtonSubmit
|
||||||
|
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||||
|
]
|
||||||
|
[ HH.text "Send Message to Server" ]
|
||||||
|
]
|
||||||
|
]
|
||||||
|
, renderMaxHistoryLength messageHistoryLength
|
||||||
|
, renderReconnectButton (isNothing wsConnection && canReconnect)
|
||||||
|
]
|
||||||
|
]
|
||||||
|
where
|
||||||
|
renderFootnote :: String -> H.ComponentHTML Action () m
|
||||||
|
renderFootnote txt =
|
||||||
|
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
|
||||||
|
|
||||||
|
renderMaxHistoryLength :: Int -> H.ComponentHTML Action () m
|
||||||
|
renderMaxHistoryLength len =
|
||||||
|
renderFootnote ("NOTE: Maximum chat history length is " <> show len <> " messages")
|
||||||
|
|
||||||
|
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"
|
||||||
|
, renderFootnote "NOTE: You can type /disconnect to manually disconnect"
|
||||||
|
]
|
||||||
|
|
||||||
|
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||||
|
handleAction = case _ of
|
||||||
|
Initialize ->
|
||||||
|
handleAction ConnectWebSocket
|
||||||
|
|
||||||
|
WebSocketParseError error ->
|
||||||
|
systemMessage $ renderError (UnknownError error)
|
||||||
|
|
||||||
|
ConnectWebSocket -> do
|
||||||
|
{ wsUrl } <- H.get
|
||||||
|
systemMessage ("Connecting to \"" <> wsUrl <> "\"...")
|
||||||
|
webSocket <- H.liftEffect $ WS.create wsUrl []
|
||||||
|
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
|
||||||
|
H.modify_ _ { wsConnection = Just webSocket }
|
||||||
|
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
|
||||||
|
|
||||||
|
HandleInputUpdate text -> do
|
||||||
|
H.modify_ _ { inputText = text }
|
||||||
|
|
||||||
|
SendMessage ev -> do
|
||||||
|
H.liftEffect $ Event.preventDefault ev
|
||||||
|
|
||||||
|
{ wsConnection, inputText } <- H.get
|
||||||
|
|
||||||
|
case wsConnection, inputText of
|
||||||
|
Nothing, _ ->
|
||||||
|
unableToSend "Not connected to server."
|
||||||
|
|
||||||
|
Just _ , "" ->
|
||||||
|
unableToSend "Cannot send an empty message"
|
||||||
|
|
||||||
|
Just webSocket, outgoingMessage -> do
|
||||||
|
H.liftEffect (WS.readyState webSocket) >>= case _ of
|
||||||
|
Connecting ->
|
||||||
|
unableToSend "Still connecting to server."
|
||||||
|
|
||||||
|
Closing ->
|
||||||
|
unableToSend "Connection to server is closing."
|
||||||
|
|
||||||
|
Closed -> do
|
||||||
|
unableToSend "Connection to server has been closed."
|
||||||
|
maybeCurrentConnection <- H.gets _.wsConnection
|
||||||
|
when (isJust maybeCurrentConnection) do
|
||||||
|
H.modify_ _ { wsConnection = Nothing, canReconnect = true }
|
||||||
|
|
||||||
|
Open -> do
|
||||||
|
case outgoingMessage of
|
||||||
|
"/disconnect" -> do
|
||||||
|
H.liftEffect $ WS.close webSocket
|
||||||
|
systemMessageReset $ "You have requested to disconnect from the server"
|
||||||
|
otherMessage -> do
|
||||||
|
H.liftEffect $ do
|
||||||
|
ab <- toIPC otherMessage
|
||||||
|
sendArrayBuffer webSocket ab
|
||||||
|
appendMessageReset $ "[😇] You: " <> otherMessage
|
||||||
|
|
||||||
|
HandleWebSocket wsEvent ->
|
||||||
|
case wsEvent of
|
||||||
|
WebSocketMessage messageEvent -> do
|
||||||
|
receivedMessage <- H.liftEffect $ fromIPC messageEvent.message
|
||||||
|
case receivedMessage of
|
||||||
|
Left parseError -> do
|
||||||
|
handleAction $ WebSocketParseError $ show parseError
|
||||||
|
Right string -> do
|
||||||
|
appendMessage $ "[😈] Server: " <> string
|
||||||
|
|
||||||
|
WebSocketOpen -> do
|
||||||
|
{ wsUrl } <- H.get
|
||||||
|
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉")
|
||||||
|
|
||||||
|
WebSocketClose { code, reason, wasClean } -> do
|
||||||
|
systemMessage $ renderCloseMessage code wasClean reason
|
||||||
|
maybeCurrentConnection <- H.gets _.wsConnection
|
||||||
|
when (isJust maybeCurrentConnection) do
|
||||||
|
H.modify_ _ { wsConnection = Nothing, canReconnect = true }
|
||||||
|
|
||||||
|
WebSocketError errorType ->
|
||||||
|
systemMessage $ renderError errorType
|
||||||
|
|
||||||
|
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"
|
||||||
|
, "]"
|
||||||
|
]
|
||||||
|
|
||||||
|
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
|
||||||
|
sendArrayBuffer = WS.sendArrayBuffer
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Helpers for updating the array of messages sent/received
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Append a new message to the chat history, with a boolean that allows you to
|
||||||
|
-- clear the text input field or not. The number of displayed `messages` in the
|
||||||
|
-- chat history (including system) is controlled by the `messageHistoryLength`
|
||||||
|
-- field in the component `State`.
|
||||||
|
appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit
|
||||||
|
appendMessageGeneric clearField msg = do
|
||||||
|
histSize <- H.gets _.messageHistoryLength
|
||||||
|
if clearField
|
||||||
|
then H.modify_ \st ->
|
||||||
|
st { messages = appendSingle histSize msg st.messages, inputText = "" }
|
||||||
|
else H.modify_ \st ->
|
||||||
|
st { messages = appendSingle histSize msg st.messages }
|
||||||
|
where
|
||||||
|
-- Limits the nnumber of recent messages to `maxHist`
|
||||||
|
appendSingle :: Int -> String -> Array String -> Array String
|
||||||
|
appendSingle maxHist x xs
|
||||||
|
| A.length xs < maxHist = xs `A.snoc` x
|
||||||
|
| otherwise = (A.takeEnd (maxHist-1) xs) `A.snoc` x
|
||||||
|
|
||||||
|
-- Append a new message to the chat history, while not clearing
|
||||||
|
-- the user input field
|
||||||
|
appendMessage :: forall m. MonadState State m => String -> m Unit
|
||||||
|
appendMessage = appendMessageGeneric false
|
||||||
|
|
||||||
|
-- Append a new message to the chat history and also clear
|
||||||
|
-- the user input field
|
||||||
|
appendMessageReset :: forall m. MonadState State m => String -> m Unit
|
||||||
|
appendMessageReset = appendMessageGeneric true
|
||||||
|
|
||||||
|
-- Append a system message to the chat log.
|
||||||
|
systemMessage :: forall m. MonadState State m => String -> m Unit
|
||||||
|
systemMessage msg = appendMessage ("[🤖] System: " <> msg)
|
||||||
|
|
||||||
|
-- As above, but also clears the user input field. e.g. in
|
||||||
|
-- the case of a "/disconnect" command
|
||||||
|
systemMessageReset :: forall m. MonadState State m => String -> m Unit
|
||||||
|
systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
|
||||||
|
|
||||||
|
-- A system message to use when a message cannot be sent.
|
||||||
|
unableToSend :: forall m. MonadState State m => String -> m Unit
|
||||||
|
unableToSend reason = systemMessage ("Unable to send. " <> reason)
|
||||||
|
|
||||||
|
foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer
|
||||||
|
foreignToArrayBuffer
|
||||||
|
= lmap renderForeignErrors
|
||||||
|
<<< runExcept
|
||||||
|
<<< F.unsafeReadTagged "ArrayBuffer"
|
||||||
|
where
|
||||||
|
renderForeignErrors :: F.MultipleErrors -> String
|
||||||
|
renderForeignErrors =
|
||||||
|
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
|
||||||
Loading…
Reference in New Issue