From 6d4268820d5bf5681c9d62b32597be2c221f9858 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Tue, 4 Jul 2023 02:58:17 +0200 Subject: [PATCH] Log component! --- src/App/AuthenticationForm.purs | 1 - src/App/Container.purs | 36 ++++++++++++------ src/App/Log.purs | 65 +++++++++++++++++++++++++++++++++ src/App/WS.purs | 51 +++++++++++--------------- 4 files changed, 111 insertions(+), 42 deletions(-) create mode 100644 src/App/Log.purs diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 17e3783..233ee9a 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -35,7 +35,6 @@ data Query a = MessageReceived ArrayBuffer a type Slot = H.Slot Query Output --- No input. type Input = Unit data AuthenticationInput diff --git a/src/App/Container.purs b/src/App/Container.purs index ae376cc..bcf6a20 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -7,6 +7,7 @@ import Bulma as Bulma import Data.Maybe (Maybe(..)) import Data.Tuple (Tuple(..)) import App.AuthenticationForm as AF +import App.Log as Log import App.WS as WS import App.AuthenticationDaemonAdminInterface as AAI import App.DNSManagerDomainsInterface as NewDomainInterface @@ -27,16 +28,18 @@ type State = { token :: Maybe String } type ChildSlots = - ( af :: AF.Slot Unit + ( log :: Log.Slot Unit , ws_auth :: WS.Slot Unit , ws_dns :: WS.Slot Unit - , aai :: AAI.Slot Unit - , ndi :: NewDomainInterface.Slot Unit + , af :: AF.Slot Unit + , aai :: AAI.Slot Unit + , ndi :: NewDomainInterface.Slot Unit ) -_af = Proxy :: Proxy "af" +_log = Proxy :: Proxy "log" _ws_auth = Proxy :: Proxy "ws_auth" _ws_dns = Proxy :: Proxy "ws_dns" +_af = Proxy :: Proxy "af" _aai = Proxy :: Proxy "aai" _ndi = Proxy :: Proxy "ndi" @@ -58,8 +61,7 @@ initialState _ = { token: Nothing render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render state = HH.div_ $ - [ render_auth_WS - , render_dnsmanager_WS + [ Bulma.columns_ [ Bulma.column_ [ render_logs ], Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ] , render_auth_form , render_authd_admin_interface , render_newdomain_interface @@ -69,6 +71,9 @@ render state div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ] + render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + render_logs = Bulma.box [ HH.slot_ _log unit Log.component unit ] + render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_WS = Bulma.box [ HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthDEvent ] @@ -105,14 +110,23 @@ handleAction = case _ of AF.MessageToSend message -> do H.tell _ws_auth unit (WS.ToSend message) + -- TODO: depending on the current page, we should provide the received message to + -- different components. AuthDEvent ev -> case ev of WS.MessageReceived (Tuple _ message) -> H.tell _af unit (AF.MessageReceived message) - WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true } - WS.WSJustClosed -> H.modify_ _ { auth_ws_connected = false } + WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true } + WS.WSJustClosed -> H.modify_ _ { auth_ws_connected = false } + 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) DNSManagerDEvent ev -> case ev of - WS.MessageReceived (Tuple _ _) -> pure unit -- TODO - WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true } - WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false } + WS.MessageReceived (Tuple _ _) -> pure unit + -- TODO: H.tell _ndi unit (NewDomainInterface.MessageReceived message) + WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true } + WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false } + 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) diff --git a/src/App/Log.purs b/src/App/Log.purs new file mode 100644 index 0000000..0b8bf30 --- /dev/null +++ b/src/App/Log.purs @@ -0,0 +1,65 @@ +module App.Log where + +{- Simple log component, showing the current events. -} + +import Prelude (Unit, discard, map, pure, ($)) + +import Data.Maybe (Maybe(..)) +import Effect.Aff.Class (class MonadAff) +import Halogen as H +import Halogen.HTML as HH + +import App.Utils + +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 + +type Input = Unit + +type Action = Unit + +type State = + { messages :: Array String + , messageHistoryLength :: Int + } + +component :: forall m. MonadAff m => H.Component Query Input Output m +component = + H.mkComponent + { initialState + , render + , eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery } + } + +initialState :: Input -> State +initialState _ = + { messages: [] + , messageHistoryLength: 10 + } + +render :: forall m. State -> H.ComponentHTML Action () m +render { messages } + = HH.div_ [ render_messages ] + where + render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) 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 + pure (Just a) + + SystemLog str a -> do + systemMessage str + pure (Just a) + + UnableToSend str a -> do + unableToSend str + pure (Just a) diff --git a/src/App/WS.purs b/src/App/WS.purs index 7ca5764..157171e 100644 --- a/src/App/WS.purs +++ b/src/App/WS.purs @@ -2,7 +2,7 @@ module App.WS where {- This component handles all WS operations. -} -import Prelude (Unit, bind, discard, map, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=)) +import Prelude (Unit, bind, discard, map, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=), unit) import Bulma as Bulma @@ -30,8 +30,9 @@ 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. + | AppendSystemMessage String -- System message to print. + | AppendMessage String -- Basic message to print. + | UnableToSend String -- Message to print: cannot send a packet. type Slot = H.Slot Query Output @@ -54,11 +55,7 @@ type WSInfo , reconnect :: Boolean } -type State = - { messages :: Array String - , messageHistoryLength :: Int - , wsInfo :: WSInfo - } +type State = { wsInfo :: WSInfo } component :: forall m. MonadAff m => H.Component Query Input Output m component = @@ -75,25 +72,19 @@ component = initialState :: Input -> State initialState url = - { messages: [] - , messageHistoryLength: 10 - , wsInfo: { url: url + { wsInfo: { url: url , connection: Nothing , reconnect: false } } render :: forall m. State -> H.ComponentHTML Action () m -render { messages, wsInfo } +render { wsInfo } = HH.div_ - [ Bulma.h1 "WS BOX" - , render_messages - , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) + [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ] where - render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages - renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote txt = HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ] @@ -122,16 +113,16 @@ handleAction action = do handleAction ConnectWebSocket Finalize -> do - systemMessage "Finalize" + H.raise $ AppendSystemMessage "Finalize" case wsInfo.connection of - Nothing -> systemMessage "No socket? How is that even possible?" + Nothing -> H.raise $ AppendSystemMessage "No socket? How is that even possible?" Just socket -> H.liftEffect $ WS.close socket WebSocketParseError error -> - systemMessage $ renderError (UnknownError error) + H.raise $ AppendSystemMessage $ renderError (UnknownError error) ConnectWebSocket -> do - systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...") + H.raise $ AppendSystemMessage ("Connecting to \"" <> wsInfo.url <> "\"...") webSocket <- H.liftEffect $ WS.create wsInfo.url [] H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer H.modify_ _ { wsInfo { connection = Just webSocket } } @@ -139,29 +130,29 @@ handleAction action = do SendMessage array_buffer_to_send -> do case wsInfo.connection of - Nothing -> appendMessage $ "[🤖] Can't send a message, websocket is down!" + Nothing -> H.raise $ AppendMessage $ "[🤖] 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 - appendMessage $ "[😈] Received a message" H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message + H.raise $ AppendMessage $ "[😈] Received a message" WebSocketOpen -> do - systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉") + H.raise $ AppendSystemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉") H.raise $ WSJustConnected WebSocketClose { code, reason, wasClean } -> do - systemMessage $ renderCloseMessage code wasClean reason + H.raise $ AppendSystemMessage $ 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 -> - systemMessage $ renderError errorType + H.raise $ AppendSystemMessage $ renderError errorType -- TODO: MAYBE inform the parent the connection is closed (if it's the case). where @@ -191,21 +182,21 @@ handleQuery = case _ of { wsInfo } <- H.get case wsInfo.connection of Nothing -> do - unableToSend "Not connected to server." + H.raise $ UnableToSend "Not connected to server." pure Nothing Just webSocket -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> do - unableToSend "Still connecting to server." + H.raise $ UnableToSend "Still connecting to server." pure Nothing Closing -> do - unableToSend "Connection to server is closing." + H.raise $ UnableToSend "Connection to server is closing." pure Nothing Closed -> do - unableToSend "Connection to server has been closed." + H.raise $ UnableToSend "Connection to server has been closed." maybeCurrentConnection <- H.gets _.wsInfo.connection when (isJust maybeCurrentConnection) do H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }