Log component!
parent
51f5ba79f1
commit
6d4268820d
|
|
@ -35,7 +35,6 @@ data Query a = MessageReceived ArrayBuffer a
|
|||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
-- No input.
|
||||
type Input = Unit
|
||||
|
||||
data AuthenticationInput
|
||||
|
|
|
|||
|
|
@ -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
|
||||
, 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.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.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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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 } }
|
||||
|
|
|
|||
Loading…
Reference in New Issue