New LogMessage structure.

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
+  | Log LogMessage
-  | SystemMessage String
-  | UnableToSend String
 
 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

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
+  | Log LogMessage
-  | SystemMessage String
-  | UnableToSend String
 
 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

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.Log message                   -> H.tell _log unit (Log.Log message)
-    AF.SystemMessage message         -> H.tell _log unit (Log.SystemLog message)
-    AF.UnableToSend  message         -> H.tell _log unit (Log.UnableToSend 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.Log message                  -> H.tell _log unit (Log.Log message)
-    AAI.SystemMessage message        -> H.tell _log unit (Log.SystemLog message)
-    AAI.UnableToSend  message        -> H.tell _log unit (Log.UnableToSend message)
 
-  NewDomainComponentEvent ev -> case ev of
+  DomainListComponentEvent ev -> case ev of
-    DomainListInterface.MessageToSend message        -> H.tell _ws_dns unit (WS.ToSend message)
+    DomainListInterface.MessageToSend message  -> H.tell _ws_dns unit (WS.ToSend message)
-    DomainListInterface.AppendMessage message        -> H.tell _log unit (Log.SimpleLog message)
+    DomainListInterface.Log message            -> H.tell _log unit (Log.Log message)
-    DomainListInterface.SystemMessage message        -> H.tell _log unit (Log.SystemLog message)
-    DomainListInterface.UnableToSend  message        -> H.tell _log unit (Log.UnableToSend 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.Log message                       -> H.tell _log unit (Log.Log message)
-    WS.AppendSystemMessage msg  -> H.tell _log unit (Log.SystemLog msg)
-    WS.UnableToSend msg         -> H.tell _log unit (Log.UnableToSend msg)
 
+  -- 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.Log message                       -> H.tell _log unit (Log.Log message)
-    WS.AppendSystemMessage msg           -> H.tell _log unit (Log.SystemLog msg)
-    WS.UnableToSend msg                  -> H.tell _log unit (Log.UnableToSend msg)
 

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
+  | Log LogMessage
-  | SystemMessage String
-  | UnableToSend String
 
 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 $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
-              H.raise $ AppendMessage $ "[🤖] Trying to authenticate to fix the problem..."
+              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

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
+data Query a = Log LogMessage a
-  = SimpleLog String a
-  | SystemLog String a
-  | UnableToSend String 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
-
+  Log message a -> do
-  SimpleLog str a -> do
+    case message of
-    appendMessage str
+      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
+type IncompleteState rows
-    unableToSend str
+  = { messages :: Array String
-    pure (Just a)
+    , 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)

src/App/LogMessage.purs

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

src/App/Utils.purs

@@ -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

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 Halogen.Query.Event as HQE
-import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
+import Halogen.Subscription as HS
-
-import App.Utils
-
-import Data.ArrayBuffer.Types (ArrayBuffer)
 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.
+  | Log LogMessage
-  | AppendMessage String                        -- Basic message to print.
-  | UnableToSend String                         -- Message to print: cannot send a packet.
 
 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