From 53fdefd79071598c8150b1526c10233078cbb9c0 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Wed, 5 Jul 2023 04:49:32 +0200 Subject: [PATCH] New LogMessage structure. --- .../AuthenticationDaemonAdminInterface.purs | 31 ++-- src/App/AuthenticationForm.purs | 27 ++- src/App/Container.purs | 29 ++-- src/App/DomainListInterface.purs | 51 +++--- src/App/Log.purs | 51 ++++-- src/App/LogMessage.purs | 6 + src/App/Utils.purs | 150 ----------------- src/App/WS.purs | 154 +++++++++++++++--- 8 files changed, 229 insertions(+), 270 deletions(-) create mode 100644 src/App/LogMessage.purs delete mode 100644 src/App/Utils.purs diff --git a/src/App/AuthenticationDaemonAdminInterface.purs b/src/App/AuthenticationDaemonAdminInterface.purs index d7701ea..226fb1c 100644 --- a/src/App/AuthenticationDaemonAdminInterface.purs +++ b/src/App/AuthenticationDaemonAdminInterface.purs @@ -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 diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 729d148..e4da4f9 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -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 diff --git a/src/App/Container.purs b/src/App/Container.purs index de6e267..7f0bfcb 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -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 - 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) + DomainListComponentEvent ev -> case ev of + DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend 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) diff --git a/src/App/DomainListInterface.purs b/src/App/DomainListInterface.purs index 9670e68..ac205e2 100644 --- a/src/App/DomainListInterface.purs +++ b/src/App/DomainListInterface.purs @@ -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 diff --git a/src/App/Log.purs b/src/App/Log.purs index 0b8bf30..9ac78c1 100644 --- a/src/App/Log.purs +++ b/src/App/Log.purs @@ -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) diff --git a/src/App/LogMessage.purs b/src/App/LogMessage.purs new file mode 100644 index 0000000..c1820ff --- /dev/null +++ b/src/App/LogMessage.purs @@ -0,0 +1,6 @@ +module App.LogMessage where + +data LogMessage + = SimpleLog String + | SystemLog String + | UnableToSend String diff --git a/src/App/Utils.purs b/src/App/Utils.purs deleted file mode 100644 index 11b215c..0000000 --- a/src/App/Utils.purs +++ /dev/null @@ -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 diff --git a/src/App/WS.purs b/src/App/WS.purs index 2814b5e..696c625 100644 --- a/src/App/WS.purs +++ b/src/App/WS.purs @@ -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