re: better with the attached files.

master
Philippe Pittoli 10 months ago
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…
Cancel
Save