Log component!

beta
Philippe Pittoli 2023-07-04 02:58:17 +02:00
parent 51f5ba79f1
commit 6d4268820d
4 changed files with 111 additions and 42 deletions

View File

@ -35,7 +35,6 @@ data Query a = MessageReceived ArrayBuffer a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
-- No input.
type Input = Unit type Input = Unit
data AuthenticationInput data AuthenticationInput

View File

@ -7,6 +7,7 @@ import Bulma as Bulma
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..)) import Data.Tuple (Tuple(..))
import App.AuthenticationForm as AF import App.AuthenticationForm as AF
import App.Log as Log
import App.WS as WS import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI import App.AuthenticationDaemonAdminInterface as AAI
import App.DNSManagerDomainsInterface as NewDomainInterface import App.DNSManagerDomainsInterface as NewDomainInterface
@ -27,16 +28,18 @@ type State = { token :: Maybe String
} }
type ChildSlots = type ChildSlots =
( af :: AF.Slot Unit ( log :: Log.Slot Unit
, ws_auth :: WS.Slot Unit , ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit , ws_dns :: WS.Slot Unit
, af :: AF.Slot Unit
, aai :: AAI.Slot Unit , aai :: AAI.Slot Unit
, ndi :: NewDomainInterface.Slot Unit , ndi :: NewDomainInterface.Slot Unit
) )
_af = Proxy :: Proxy "af" _log = Proxy :: Proxy "log"
_ws_auth = Proxy :: Proxy "ws_auth" _ws_auth = Proxy :: Proxy "ws_auth"
_ws_dns = Proxy :: Proxy "ws_dns" _ws_dns = Proxy :: Proxy "ws_dns"
_af = Proxy :: Proxy "af"
_aai = Proxy :: Proxy "aai" _aai = Proxy :: Proxy "aai"
_ndi = Proxy :: Proxy "ndi" _ndi = Proxy :: Proxy "ndi"
@ -58,8 +61,7 @@ initialState _ = { token: Nothing
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
render state render state
= HH.div_ $ = HH.div_ $
[ render_auth_WS [ Bulma.columns_ [ Bulma.column_ [ render_logs ], Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ]
, render_dnsmanager_WS
, render_auth_form , render_auth_form
, render_authd_admin_interface , render_authd_admin_interface
, render_newdomain_interface , render_newdomain_interface
@ -69,6 +71,9 @@ render state
div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad 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) ] 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 :: 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 ] 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 AF.MessageToSend message -> do
H.tell _ws_auth unit (WS.ToSend message) 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 AuthDEvent ev -> case ev of
WS.MessageReceived (Tuple _ message) -> WS.MessageReceived (Tuple _ message) ->
H.tell _af unit (AF.MessageReceived message) H.tell _af unit (AF.MessageReceived message)
WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true } WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true }
WS.WSJustClosed -> H.modify_ _ { auth_ws_connected = false } 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 DNSManagerDEvent ev -> case ev of
WS.MessageReceived (Tuple _ _) -> pure unit -- TODO WS.MessageReceived (Tuple _ _) -> pure unit
-- TODO: H.tell _ndi unit (NewDomainInterface.MessageReceived message)
WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true } WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true }
WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false } 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)

65
src/App/Log.purs Normal file
View File

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

View File

@ -2,7 +2,7 @@ module App.WS where
{- This component handles all WS operations. -} {- 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 import Bulma as Bulma
@ -30,8 +30,9 @@ data Output
= MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent. = MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent.
| WSJustConnected -- Inform the parent the connection is up. | WSJustConnected -- Inform the parent the connection is up.
| WSJustClosed -- Inform the parent the connection is down. | WSJustClosed -- Inform the parent the connection is down.
--| AppendSystemMessage String -- System message to print. | AppendSystemMessage String -- System message to print.
--| AppendMessage String -- Basic message to print. | AppendMessage String -- Basic message to print.
| UnableToSend String -- Message to print: cannot send a packet.
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
@ -54,11 +55,7 @@ type WSInfo
, reconnect :: Boolean , reconnect :: Boolean
} }
type State = type State = { wsInfo :: WSInfo }
{ messages :: Array String
, messageHistoryLength :: Int
, wsInfo :: WSInfo
}
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
component = component =
@ -75,25 +72,19 @@ component =
initialState :: Input -> State initialState :: Input -> State
initialState url = initialState url =
{ messages: [] { wsInfo: { url: url
, messageHistoryLength: 10
, wsInfo: { url: url
, connection: Nothing , connection: Nothing
, reconnect: false , reconnect: false
} }
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { messages, wsInfo } render { wsInfo }
= HH.div_ = HH.div_
[ Bulma.h1 "WS BOX" [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
, render_messages
, renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
] ]
where where
render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote :: String -> H.ComponentHTML Action () m
renderFootnote txt = renderFootnote txt =
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text 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 handleAction ConnectWebSocket
Finalize -> do Finalize -> do
systemMessage "Finalize" H.raise $ AppendSystemMessage "Finalize"
case wsInfo.connection of 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 Just socket -> H.liftEffect $ WS.close socket
WebSocketParseError error -> WebSocketParseError error ->
systemMessage $ renderError (UnknownError error) H.raise $ AppendSystemMessage $ renderError (UnknownError error)
ConnectWebSocket -> do ConnectWebSocket -> do
systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...") H.raise $ AppendSystemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
webSocket <- H.liftEffect $ WS.create wsInfo.url [] webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsInfo { connection = Just webSocket } } H.modify_ _ { wsInfo { connection = Just webSocket } }
@ -139,29 +130,29 @@ handleAction action = do
SendMessage array_buffer_to_send -> do SendMessage array_buffer_to_send -> do
case wsInfo.connection of 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 Just webSocket -> H.liftEffect $ do
sendArrayBuffer webSocket array_buffer_to_send sendArrayBuffer webSocket array_buffer_to_send
HandleWebSocket wsEvent -> do HandleWebSocket wsEvent -> do
case wsEvent of case wsEvent of
WebSocketMessage received_message -> do WebSocketMessage received_message -> do
appendMessage $ "[😈] Received a message"
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
H.raise $ AppendMessage $ "[😈] Received a message"
WebSocketOpen -> do WebSocketOpen -> do
systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉") H.raise $ AppendSystemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
H.raise $ WSJustConnected H.raise $ WSJustConnected
WebSocketClose { code, reason, wasClean } -> do WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason H.raise $ AppendSystemMessage $ renderCloseMessage code wasClean reason
maybeCurrentConnection <- H.gets _.wsInfo.connection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
H.raise $ WSJustClosed H.raise $ WSJustClosed
WebSocketError errorType -> WebSocketError errorType ->
systemMessage $ renderError errorType H.raise $ AppendSystemMessage $ renderError errorType
-- TODO: MAYBE inform the parent the connection is closed (if it's the case). -- TODO: MAYBE inform the parent the connection is closed (if it's the case).
where where
@ -191,21 +182,21 @@ handleQuery = case _ of
{ wsInfo } <- H.get { wsInfo } <- H.get
case wsInfo.connection of case wsInfo.connection of
Nothing -> do Nothing -> do
unableToSend "Not connected to server." H.raise $ UnableToSend "Not connected to server."
pure Nothing pure Nothing
Just webSocket -> do Just webSocket -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting -> do Connecting -> do
unableToSend "Still connecting to server." H.raise $ UnableToSend "Still connecting to server."
pure Nothing pure Nothing
Closing -> do Closing -> do
unableToSend "Connection to server is closing." H.raise $ UnableToSend "Connection to server is closing."
pure Nothing pure Nothing
Closed -> do Closed -> do
unableToSend "Connection to server has been closed." H.raise $ UnableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsInfo.connection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }