karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

New LogMessage structure.

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-05 04:49:32 +02:00
parent d99e38d1b8
commit 53fdefd790
8 changed files with 229 additions and 270 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/App/AuthenticationDaemonAdminInterface.purs
View File

@ -22,7 +22,7 @@ import Web.Event.Event as Event
import Data.ArrayBuffer.Types (ArrayBuffer)
import App.Utils
import App.LogMessage
-- import App.IPC as IPC
import App.Email as Email
@ -30,9 +30,7 @@ import App.Messages.AuthenticationDaemon as AuthD
data Output
= MessageToSend ArrayBuffer
| AppendMessage String
| SystemMessage String
| UnableToSend String
| Log LogMessage
data Query a
= MessageReceived ArrayBuffer a
@ -50,9 +48,7 @@ data AddUserInput
| ADDUSER_INP_pass String
data Action
= WebSocketParseError String
| HandleAddUserInput AddUserInput
= HandleAddUserInput AddUserInput
| AddUserAttempt
-- | Finalize
@ -128,9 +124,6 @@ render { addUserForm, wsUp }
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
WebSocketParseError error ->
H.raise $ SystemMessage $ renderError (UnknownError error)
HandleAddUserInput adduserinp -> do
{ addUserForm } <- H.get
case adduserinp of
@ -149,13 +142,13 @@ handleAction = case _ of
case login, email, pass of
"", _, _ ->
H.raise $ UnableToSend "Write the user's login!"
H.raise $ Log $ UnableToSend "Write the user's login!"
_, "", _ ->
H.raise $ UnableToSend "Write the user's email!"
H.raise $ Log $ UnableToSend "Write the user's email!"
_, _, "" ->
H.raise $ UnableToSend "Write the user's password!"
H.raise $ Log $ UnableToSend "Write the user's password!"
_, _, _ -> do
ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkAddUser { login: login
@ -163,7 +156,7 @@ handleAction = case _ of
, email: Just (Email.Email email)
, password: pass }
H.raise $ MessageToSend ab
H.raise $ AppendMessage "[😇] Trying to add a user"
H.raise $ Log $ SimpleLog "[😇] Trying to add a user"
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
@ -174,7 +167,7 @@ handleQuery = case _ of
case receivedMessage of
-- Cases where we didn't understand the message.
Left _ -> do
H.raise $ SystemMessage $ "Received a message that could not be deserialized."
H.raise $ Log $ SystemLog $ "Received a message that could not be deserialized."
pure Nothing
--case err of
-- (AuthD.JSONERROR jerr) -> do
@ -187,14 +180,14 @@ handleQuery = case _ of
Right response -> do
case response of
(AuthD.GotError errmsg) -> do
H.raise $ AppendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
H.raise $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
pure (Just a)
(AuthD.GotUserAdded msg) -> do
H.raise $ AppendMessage $ "[😈] Success! Server added user: " <> show msg.user
H.raise $ Log $ SimpleLog $ "[😈] Success! Server added user: " <> show msg.user
pure (Just a)
-- WTH?!
_ -> do
H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
pure (Just a)
ConnectionIsDown a -> do
@ -210,6 +203,6 @@ handleQuery = case _ of
--print_json_string arraybuffer = do
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-- H.raise $ AppendMessage $ case (value) of
-- H.raise $ Log $ SimpleLog $ case (value) of
-- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

27
src/App/AuthenticationForm.purs
View File

@ -22,6 +22,7 @@ import Effect.Class (class MonadEffect)
import App.IPC as IPC
import App.Email as Email
import App.LogMessage
import App.Messages.AuthenticationDaemon as AuthD
@ -30,9 +31,7 @@ import Data.ArrayBuffer.Types (ArrayBuffer)
data Output
= AuthToken (Tuple Int String)
| MessageToSend ArrayBuffer
| AppendMessage String
| SystemMessage String
| UnableToSend String
| Log LogMessage
data Query a
= MessageReceived ArrayBuffer a
@ -178,13 +177,13 @@ handleAction = case _ of
case login, email, pass of
"", _, _ ->
H.raise $ UnableToSend "Write your login!"
H.raise $ Log $ UnableToSend "Write your login!"
_, "", _ ->
H.raise $ UnableToSend "Write your email!"
H.raise $ Log $ UnableToSend "Write your email!"
_, _, "" ->
H.raise $ UnableToSend "Write your password!"
H.raise $ Log $ UnableToSend "Write your password!"
_, _, _ -> do
message <- H.liftEffect $ AuthD.serialize $
@ -192,7 +191,7 @@ handleAction = case _ of
, email: Just (Email.Email email)
, password: pass }
H.raise $ MessageToSend message
H.raise $ AppendMessage $ "[😇] Trying to register (login: " <> login <> ")"
H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")"
AuthenticationAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
@ -201,15 +200,15 @@ handleAction = case _ of
case authenticationForm.login, authenticationForm.pass of
"" , _ ->
H.raise $ UnableToSend "Write your login!"
H.raise $ Log $ UnableToSend "Write your login!"
_ , "" ->
H.raise $ UnableToSend "Write your password!"
H.raise $ Log $ UnableToSend "Write your password!"
login, pass -> do
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass }
H.raise $ MessageToSend message
H.raise $ AppendMessage $ "[😇] Trying to authenticate (login: " <> login <> ")"
H.raise $ Log $ SimpleLog $ "[😇] Trying to authenticate (login: " <> login <> ")"
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
@ -230,16 +229,16 @@ handleQuery = case _ of
case response of
-- The authentication failed.
(AuthD.GotError errmsg) -> do
H.raise $ AppendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
H.raise $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
pure (Just a)
-- The authentication was a success!
(AuthD.GotToken msg) -> do
H.raise $ AppendMessage $ "[🎉] Authenticated to authd!"
H.raise $ Log $ SimpleLog $ "[🎉] Authenticated to authd!"
H.raise $ AuthToken (Tuple msg.uid msg.token)
pure (Just a)
-- WTH?!
_ -> do
H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
pure Nothing
ConnectionIsDown a -> do
@ -254,6 +253,6 @@ handleQuery = case _ of
--print_json_string arraybuffer = do
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-- H.raise $ AppendMessage $ case (value) of
-- H.raise $ Log $ SimpleLog $ case (value) of
-- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

27
src/App/Container.purs
View File

@ -19,7 +19,7 @@ import Effect.Aff.Class (class MonadAff)
data Action
= AuthenticationComponentEvent AF.Output
| AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd.
| NewDomainComponentEvent DomainListInterface.Output
| DomainListComponentEvent DomainListInterface.Output
| AuthenticationDaemonEvent WS.Output
| DNSManagerDaemonEvent WS.Output
@ -93,7 +93,7 @@ render state
render_newdomain_interface = case state.token of
Just token -> Bulma.box $
[ Bulma.h1 "New domain interface!"
, HH.slot _dli unit DomainListInterface.component token NewDomainComponentEvent
, HH.slot _dli unit DomainListInterface.component token DomainListComponentEvent
]
Nothing -> render_nothing
@ -105,21 +105,15 @@ handleAction = case _ of
AuthenticationComponentEvent ev -> case ev of
AF.AuthToken (Tuple uid token) -> H.modify_ _ { uid = Just uid, token = Just token }
AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
AF.AppendMessage message -> H.tell _log unit (Log.SimpleLog message)
AF.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
AF.UnableToSend message -> H.tell _log unit (Log.UnableToSend message)
AF.Log message -> H.tell _log unit (Log.Log message)
AuthenticationDaemonAdminComponentEvent ev -> case ev of
AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
AAI.AppendMessage message -> H.tell _log unit (Log.SimpleLog message)
AAI.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
AAI.UnableToSend message -> H.tell _log unit (Log.UnableToSend message)
AAI.Log message -> H.tell _log unit (Log.Log message)
NewDomainComponentEvent ev -> case ev of
DomainListComponentEvent ev -> case ev of
DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
DomainListInterface.AppendMessage message -> H.tell _log unit (Log.SimpleLog message)
DomainListInterface.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
DomainListInterface.UnableToSend message -> H.tell _log unit (Log.UnableToSend message)
DomainListInterface.Log message -> H.tell _log unit (Log.Log message)
-- TODO: depending on the current page, we should provide the received message to different components.
AuthenticationDaemonEvent ev -> case ev of
@ -134,15 +128,12 @@ handleAction = case _ of
WS.WSJustClosed -> do
H.tell _af unit AF.ConnectionIsDown
H.tell _aai unit AAI.ConnectionIsDown
WS.AppendMessage msg -> H.tell _log unit (Log.SimpleLog msg)
WS.AppendSystemMessage msg -> H.tell _log unit (Log.SystemLog msg)
WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg)
WS.Log message -> H.tell _log unit (Log.Log message)
-- TODO: depending on the current page, we should provide the received message to different components.
DNSManagerDaemonEvent ev -> case ev of
WS.MessageReceived (Tuple _ message) -> H.tell _dli unit (DomainListInterface.MessageReceived message)
WS.WSJustConnected -> H.tell _dli unit DomainListInterface.ConnectionIsUp
WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
WS.AppendMessage msg -> H.tell _log unit (Log.SimpleLog msg)
WS.AppendSystemMessage msg -> H.tell _log unit (Log.SystemLog msg)
WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg)
WS.Log message -> H.tell _log unit (Log.Log message)

51
src/App/DomainListInterface.purs
View File

@ -20,11 +20,8 @@ import Data.String.Utils (endsWith)
import Halogen.HTML.Events as HHE
import Control.Monad.State (class MonadState)
import Data.Array as A
import Data.Tuple (Tuple(..))
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.String as String
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
@ -32,23 +29,19 @@ import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event (Event)
import Web.Event.Event as Event
import Web.Socket.WebSocket as WS
import Effect.Class (class MonadEffect)
import App.Utils
import App.LogMessage
import App.IPC as IPC
import App.Messages.DNSManagerDaemon as DNSManager
import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
data Output
= MessageToSend ArrayBuffer
| AppendMessage String
| SystemMessage String
| UnableToSend String
| Log LogMessage
data Query a
= MessageReceived ArrayBuffer a
@ -195,29 +188,29 @@ handleAction = case _ of
UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } }
EnterDomain domain -> do
H.raise $ AppendMessage $ "[???] trying to enter domain: " <> domain
H.raise $ Log $ SimpleLog $ "[???] trying to enter domain: " <> domain
RemoveDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
H.raise $ MessageToSend message
H.raise $ AppendMessage $ "[😇] Removing domain: " <> domain
H.raise $ Log $ SimpleLog $ "[😇] Removing domain: " <> domain
NewDomainAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
H.raise $ AppendMessage "[😇] Trying to add a new domain"
H.raise $ Log $ SimpleLog "[😇] Trying to add a new domain"
{ newDomainForm } <- H.get
let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain
case new_domain of
"" ->
H.raise $ UnableToSend "You didn't enter the new domain!"
H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
_ -> do
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkNewDomain { domain: new_domain }
H.raise $ MessageToSend message
H.raise $ AppendMessage "[😇] Trying to add a new domain"
H.raise $ Log $ SimpleLog "[😇] Trying to add a new domain"
handleAction $ HandleNewDomainInput $ INP_newdomain ""
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
@ -241,45 +234,45 @@ handleQuery = case _ of
case received_msg of
-- The authentication failed.
(DNSManager.MkError errmsg) -> do
H.raise $ AppendMessage $ "[😈] Failed, reason is: " <> errmsg.reason
H.raise $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
(DNSManager.MkErrorUserNotLogged _) -> do
H.raise $ AppendMessage $ "[😈] Failed! The user isn't connected!"
H.raise $ AppendMessage $ "[🤖] Trying to authenticate to fix the problem..."
H.raise $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
H.raise $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
handleAction AuthenticateToDNSManager
(DNSManager.MkErrorInvalidToken _) -> do
H.raise $ AppendMessage $ "[😈] Failed connection! Invalid token!"
H.raise $ Log $ SimpleLog $ "[😈] Failed connection! Invalid token!"
(DNSManager.MkDomainAlreadyExists _) -> do
H.raise $ AppendMessage $ "[😈] Failed! The domain already exists."
H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain already exists."
(DNSManager.MkUnacceptableDomain _) -> do
H.raise $ AppendMessage $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)."
H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)."
(DNSManager.MkAcceptedDomains response) -> do
H.raise $ AppendMessage $ "[😈] Received the list of accepted domains!"
H.raise $ Log $ SimpleLog $ "[😈] Received the list of accepted domains!"
handleAction $ UpdateAcceptedDomains response.domains
(DNSManager.MkLogged response) -> do
H.raise $ AppendMessage $ "[🎉] Authenticated to dnsmanagerd!"
H.raise $ Log $ SimpleLog $ "[🎉] Authenticated to dnsmanagerd!"
handleAction $ UpdateAcceptedDomains response.accepted_domains
handleAction $ UpdateMyDomains response.my_domains
(DNSManager.MkDomainAdded response) -> do
{ my_domains } <- H.get
H.raise $ AppendMessage $ "[😈] Domain added: " <> response.domain
H.raise $ Log $ SimpleLog $ "[😈] Domain added: " <> response.domain
handleAction $ UpdateMyDomains (my_domains <> [response.domain])
(DNSManager.MkInvalidDomainName _) -> do
H.raise $ AppendMessage $ "[😈] Failed! The domain is not valid!"
H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"
(DNSManager.MkDomainDeleted response) -> do
{ my_domains } <- H.get
H.raise $ AppendMessage $ "[😈] The domain '" <> response.domain <> "' has been deleted!"
H.raise $ Log $ SimpleLog $ "[😈] The domain '" <> response.domain <> "' has been deleted!"
handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains
(DNSManager.MkSuccess _) -> do
H.raise $ AppendMessage $ "[😈] Success!"
H.raise $ Log $ SimpleLog $ "[😈] Success!"
-- WTH?!
_ -> do
H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
pure (Just a)
ConnectionIsDown a -> do
@ -288,7 +281,7 @@ handleQuery = case _ of
ConnectionIsUp a -> do
H.modify_ _ { wsUp = true }
H.raise $ AppendMessage "Connection with dnsmanagerd was closed, let's re-authenticate"
H.raise $ Log $ SimpleLog "Connection with dnsmanagerd was closed, let's re-authenticate"
handleAction AuthenticateToDNSManager
pure (Just a)
@ -301,6 +294,6 @@ build_new_domain sub tld
--print_json_string arraybuffer = do
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-- H.raise $ AppendMessage $ case (value) of
-- H.raise $ Log $ SimpleLog $ case (value) of
-- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

51
src/App/Log.purs
View File

@ -2,23 +2,22 @@ module App.Log where
{- Simple log component, showing the current events. -}
import Prelude (Unit, discard, map, pure, ($))
import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (-), (<), (<>))
import Control.Monad.State (class MonadState)
import Data.Array as A
import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import App.Utils
import App.LogMessage
data Output = Void
type Slot = H.Slot Query Output
-- type Query :: forall k. k -> Type
data Query a
= SimpleLog String a
| SystemLog String a
| UnableToSend String a
data Query a = Log LogMessage a
type Input = Unit
@ -51,15 +50,37 @@ render { messages }
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
SimpleLog str a -> do
appendMessage str
Log message a -> do
case message of
SimpleLog str -> appendMessage str
SystemLog str -> systemMessage str
UnableToSend str -> unableToSend str
pure (Just a)
SystemLog str a -> do
systemMessage str
pure (Just a)
UnableToSend str a -> do
unableToSend str
pure (Just a)
type IncompleteState rows
= { messages :: Array String
, messageHistoryLength :: Int
| rows }
-- Append a new message to the chat history.
-- The number of displayed `messages` in the chat history (including system)
-- is controlled by the `messageHistoryLength` field in the component `State`.
appendMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
appendMessage msg = do
histSize <- H.gets _.messageHistoryLength
H.modify_ \st -> st { messages = appendSingle histSize msg st.messages }
where
-- Limits the number 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 system message to the chat log.
systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
systemMessage msg = appendMessage ("[🤖] System: " <> msg)
-- A system message to use when a message cannot be sent.
unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
unableToSend reason = systemMessage ("Unable to send. " <> reason)

6
src/App/LogMessage.purs Normal file
View File

@ -0,0 +1,6 @@
module App.LogMessage where
data LogMessage
= SimpleLog String
| SystemLog String
| UnableToSend String

150
src/App/Utils.purs
View File

@ -1,150 +0,0 @@
module App.Utils 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.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String as String
import Effect (Effect)
import Foreign as F
import Halogen as H
import Halogen.Query.Event as HQE
import Halogen.Subscription as HS
import Web.Socket.Event.CloseEvent as WSCE
import Web.Socket.Event.EventTypes as WSET
import Web.Socket.Event.MessageEvent as WSME
import Web.Socket.WebSocket as WS
import Data.ArrayBuffer.Types (ArrayBuffer)
--------------------------------------------------------------------------------
-- 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' :: F.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
= UnknownError String
| UnknownWebSocketError
renderError :: ErrorType -> String
renderError = case _ of
UnknownError str ->
"Unknown error: " <> str
UnknownWebSocketError ->
"Unknown 'error' event has been fired by WebSocket event listener"
--------------------------------------------------------------------------------
-- WebSocket message type
--------------------------------------------------------------------------------
type WebSocketMessageType = ArrayBuffer
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
sendArrayBuffer = WS.sendArrayBuffer
type IncompleteState rows
= { messages :: Array String
, messageHistoryLength :: Int
| rows }
--------------------------------------------------------------------------------
-- Helpers for updating the array of messages sent/received
--------------------------------------------------------------------------------
-- Append a new message to the chat history.
-- The number of displayed `messages` in the chat history (including system)
-- is controlled by the `messageHistoryLength` field in the component `State`.
appendMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
appendMessage msg = do
histSize <- H.gets _.messageHistoryLength
H.modify_ \st -> st { messages = appendSingle histSize msg st.messages }
where
-- Limits the number 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 system message to the chat log.
systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
systemMessage msg = appendMessage ("[🤖] System: " <> msg)
-- A system message to use when a message cannot be sent.
unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
unableToSend reason = systemMessage ("Unable to send. " <> reason)
foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
foreignToArrayBuffer
= lmap renderForeignErrors
<<< runExcept
<<< F.unsafeReadTagged "ArrayBuffer"
where
renderForeignErrors :: F.MultipleErrors -> String
renderForeignErrors =
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError

154
src/App/WS.purs
View File

@ -2,24 +2,34 @@ module App.WS where
{- This component handles all WS operations. -}
import Prelude (Unit, bind, discard, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=))
import Prelude (Unit, bind, discard, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map)
import Control.Monad.Except (runExcept)
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.String as String
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Foreign as F
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 Halogen.Query.Event as HQE
import Halogen.Subscription as HS
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
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 App.LogMessage
-- Input is the WS url.
type Input = String
@ -29,9 +39,7 @@ 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.
| UnableToSend String -- Message to print: cannot send a packet.
| Log LogMessage
type Slot = H.Slot Query Output
@ -112,16 +120,16 @@ handleAction action = do
handleAction ConnectWebSocket
Finalize -> do
-- H.raise $ AppendSystemMessage $ "Closing websocket for '" <> wsInfo.url <> "'"
-- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
case wsInfo.connection of
Nothing -> H.raise $ AppendSystemMessage "No socket? How is that even possible?"
Nothing -> H.raise $ Log $ SystemLog "No socket? How is that even possible?"
Just socket -> H.liftEffect $ WS.close socket
WebSocketParseError error ->
H.raise $ AppendSystemMessage $ renderError (UnknownError error)
H.raise $ Log $ SystemLog $ renderError (UnknownError error)
ConnectWebSocket -> do
-- H.raise $ AppendSystemMessage $ "Connecting to \"" <> wsInfo.url <> "\"..."
-- H.raise $ Log $ SystemLog $ "Connecting to \"" <> wsInfo.url <> "\"..."
webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsInfo { connection = Just webSocket } }
@ -129,29 +137,29 @@ handleAction action = do
SendMessage array_buffer_to_send -> do
case wsInfo.connection of
Nothing -> H.raise $ AppendMessage $ "[🤖] Can't send a message, websocket is down!"
Nothing -> H.raise $ Log $ SimpleLog $ "[🤖] 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
-- H.raise $ AppendMessage $ "[😈] Received a message"
-- H.raise $ Log $ SimpleLog $ "[😈] Received a message"
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
WebSocketOpen -> do
-- H.raise $ AppendSystemMessage ("Successfully connected to \"" <> wsInfo.url <> "\"!🎉")
-- H.raise $ Log $ SystemLog ("Successfully connected to \"" <> wsInfo.url <> "\"!🎉")
H.raise $ WSJustConnected
WebSocketClose { code, reason, wasClean } -> do
H.raise $ AppendSystemMessage $ renderCloseMessage code wasClean reason
H.raise $ Log $ SystemLog $ 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 ->
H.raise $ AppendSystemMessage $ renderError errorType
H.raise $ Log $ SystemLog $ renderError errorType
-- TODO: MAYBE inform the parent the connection is closed (if it's the case).
where
@ -177,21 +185,21 @@ handleQuery = case _ of
{ wsInfo } <- H.get
case wsInfo.connection of
Nothing -> do
H.raise $ UnableToSend "Not connected to server."
H.raise $ Log $ UnableToSend "Not connected to server."
pure Nothing
Just webSocket -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting -> do
H.raise $ UnableToSend "Still connecting to server."
H.raise $ Log $ UnableToSend "Still connecting to server."
pure Nothing
Closing -> do
H.raise $ UnableToSend "Connection to server is closing."
H.raise $ Log $ UnableToSend "Connection to server is closing."
pure Nothing
Closed -> do
H.raise $ UnableToSend "Connection to server has been closed."
H.raise $ Log $ UnableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
@ -201,3 +209,101 @@ handleQuery = case _ of
H.liftEffect $ do
sendArrayBuffer webSocket message
pure (Just a)
--------------------------------------------------------------------------------
-- WebSocket mess.
--------------------------------------------------------------------------------
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' :: F.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
= UnknownError String
| UnknownWebSocketError
renderError :: ErrorType -> String
renderError = case _ of
UnknownError str ->
"Unknown error: " <> str
UnknownWebSocketError ->
"Unknown 'error' event has been fired by WebSocket event listener"
--------------------------------------------------------------------------------
-- WebSocket message type
--------------------------------------------------------------------------------
type WebSocketMessageType = ArrayBuffer
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
sendArrayBuffer = WS.sendArrayBuffer
foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
foreignToArrayBuffer
= lmap renderForeignErrors
<<< runExcept
<<< F.unsafeReadTagged "ArrayBuffer"
where
renderForeignErrors :: F.MultipleErrors -> String
renderForeignErrors =
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError