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

Log component!

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-04 02:58:17 +02:00
parent 51f5ba79f1
commit 6d4268820d
4 changed files with 111 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/App/AuthenticationForm.purs
View File

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

36
src/App/Container.purs
View File

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

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)

51
src/App/WS.purs
View File

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