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

Remove printing messages in AuthenticationDaemonAdminInterface.

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-04 04:49:22 +02:00
parent 3be96bd436
commit b061c0b18e
2 changed files with 82 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

267
src/App/AuthenticationDaemonAdminInterface.purs
View File

@ -4,20 +4,14 @@ module App.AuthenticationDaemonAdminInterface where
This interface should allow to:
- TODO: add, remove, search, validate users
- TODO: raise a user to admin
TODO: authenticate
-}
import Prelude (Unit, Void, bind, discard, map, not, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=))
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>))
import Bulma as Bulma
import Control.Monad.State (class MonadState)
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 Data.Maybe (Maybe(..), maybe)
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
@ -25,30 +19,25 @@ 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.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
import Web.Socket.WebSocket as WS
import Effect.Class (class MonadEffect)
import Data.ArrayBuffer.Types (ArrayBuffer)
import App.Utils
import App.IPC as IPC
-- import App.IPC as IPC
import App.Email as Email
import App.Messages.AuthenticationDaemon as AuthD
import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
data Output
= MessageToSend ArrayBuffer
| AppendMessage String
| SystemMessage String
| UnableToSend String
--------------------------------------------------------------------------------
-- Root component module
--------------------------------------------------------------------------------
data Output = Void
data Query a = MessageReceived ArrayBuffer a
type Slot = H.Slot Query Output
type Query :: forall k. k -> Type
type Query = Const Void
type Input = String
type Input = Unit
data AddUserInput
= ADDUSER_INP_login String
@ -57,32 +46,19 @@ data AddUserInput
| ADDUSER_INP_pass String
data Action
= Initialize
| WebSocketParseError String
| ConnectWebSocket
= WebSocketParseError String
| HandleAddUserInput AddUserInput
| AddUserAttempt
-- | Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
| PreventSubmit Event
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
type WSInfo
= { url :: String
, connection :: Maybe WS.WebSocket
, reconnect :: Boolean
}
type State =
{ messages :: Array String
, messageHistoryLength :: Int
, addUserForm :: StateAddUserForm
, wsInfo :: WSInfo
{ addUserForm :: StateAddUserForm
, wsUp :: Boolean
}
component :: forall m. MonadAff m => H.Component Query Input Output m
@ -91,35 +67,19 @@ component =
{ initialState
, render
, eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize
, handleAction = handleAction
{ handleAction = handleAction
, handleQuery = handleQuery
-- , finalize = Just Finalize
}
}
initialState :: Input -> State
initialState input =
{ messages: []
, messageHistoryLength: 10
, addUserForm: { login: "", admin: false, email: "", pass: "" }
, wsInfo: { url: input
, connection: Nothing
, reconnect: false
}
}
initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }, wsUp: true }
render :: forall m. State -> H.ComponentHTML Action () m
render {
messages,
wsInfo,
addUserForm }
render { addUserForm, wsUp }
= HH.div_
[ Bulma.columns_ [ Bulma.column_ adduser_form ]
, render_messages
--, renderMaxHistoryLength messageHistoryLength
, renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
]
where
@ -128,7 +88,7 @@ render {
, render_adduser_form
]
should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection)
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
render_adduser_form = HH.form
[ HE.onSubmit PreventSubmit ]
@ -156,55 +116,16 @@ render {
[ HP.style "padding: 0.5rem 1.25rem;"
, HP.type_ HP.ButtonSubmit
, HE.onClick \ _ -> AddUserAttempt
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
, (if wsUp then (HP.enabled true) else (HP.disabled true))
]
[ HH.text "Send Message to Server" ]
]
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 ] ]
renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
renderReconnectButton cond =
if cond
then
HH.p_
[ HH.button
[ HP.type_ HP.ButtonButton
, HE.onClick \_ -> ConnectWebSocket
]
[ HH.text "Reconnect?" ]
]
else
HH.p_
[ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops"
]
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
Initialize ->
handleAction ConnectWebSocket
-- Finalize -> do
-- { wsInfo } <- H.get
-- systemMessage "Finalize"
-- case wsInfo.connection of
-- Nothing -> systemMessage "No socket? How is that even possible?"
-- Just socket -> H.liftEffect $ WS.close socket
WebSocketParseError error ->
systemMessage $ renderError (UnknownError error)
ConnectWebSocket -> do
{ wsInfo } <- H.get
systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsInfo { connection = Just webSocket } }
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
H.raise $ SystemMessage $ renderError (UnknownError error)
HandleAddUserInput adduserinp -> do
{ addUserForm } <- H.get
@ -217,111 +138,65 @@ handleAction = case _ of
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
AddUserAttempt -> do
{ wsInfo, addUserForm } <- H.get
{ addUserForm } <- H.get
let login = addUserForm.login
email = addUserForm.email
pass = addUserForm.pass
case wsInfo.connection, login, email, pass of
Nothing, _, _, _ ->
unableToSend "Not connected to server."
case login, email, pass of
"", _, _ ->
H.raise $ UnableToSend "Write the user's login!"
Just _, "", _, _ ->
unableToSend "Write the user's login!"
_, "", _ ->
H.raise $ UnableToSend "Write the user's email!"
Just _, _, "", _ ->
unableToSend "Write the user's email!"
_, _, "" ->
H.raise $ UnableToSend "Write the user's password!"
Just _, _, _, "" ->
unableToSend "Write the user's password!"
_, _, _ -> do
ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkAddUser { login: login
, admin: addUserForm.admin
, email: Just (Email.Email email)
, password: pass }
H.raise $ MessageToSend ab
H.raise $ AppendMessage "[😇] Trying to add a user"
Just webSocket, _, _, _ -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting ->
unableToSend "Still connecting to server."
Closing ->
unableToSend "Connection to server is closing."
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
Closed -> do
unableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
MessageReceived message a -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize message
case receivedMessage of
-- Cases where we didn't understand the message.
Left _ -> do
H.raise $ SystemMessage $ "Received a message that could not be deserialized."
pure Nothing
--case err of
-- (AuthD.JSONERROR jerr) -> do
-- print_json_string messageEvent.message
-- handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
-- (AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
-- (AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
Open -> do
H.liftEffect $ do
ab <- AuthD.serialize $ AuthD.MkAddUser { login: login
, admin: addUserForm.admin
, email: Just (Email.Email email)
, password: pass }
sendArrayBuffer webSocket ab
appendMessage "[😇] Trying to add a user"
-- Cases where we understood the message.
Right response -> do
case response of
(AuthD.GotError errmsg) -> do
H.raise $ AppendMessage $ "[😈] 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
pure (Just a)
-- WTH?!
_ -> do
H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
pure (Just a)
HandleWebSocket wsEvent ->
case wsEvent of
WebSocketMessage messageEvent -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
case receivedMessage of
-- Cases where we didn't understand the message.
Left err -> do
case err of
(AuthD.JSONERROR jerr) -> do
print_json_string messageEvent.message
handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
(AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
(AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
-- Cases where we understood the message.
Right response -> do
case response of
-- The authentication failed.
(AuthD.GotError errmsg) -> do
appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
(AuthD.GotUserAdded msg) -> do
appendMessage $ "[😈] Success! Server added user: " <> show msg.user
-- WTH?!
_ -> do
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
WebSocketOpen -> do
{ wsInfo } <- H.get
systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
WebSocketError errorType ->
systemMessage $ renderError errorType
where
renderCloseMessage
:: Int
-> Boolean
-> String
-> String
renderCloseMessage code wasClean = case _ of
"" -> baseCloseMessage
reason -> baseCloseMessage <> "Reason: " <> reason
where
baseCloseMessage :: String
baseCloseMessage =
String.joinWith " "
[ "Connection to WebSocket closed"
, "[ CODE:"
, show code
, "|"
, if wasClean then "CLEAN" else "DIRTY"
, "]"
]
print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
print_json_string arraybuffer = do
-- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
appendMessage $ case (value) of
Left _ -> "Cannot even fromTypedIPC the message."
Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
----print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
--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
-- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

15
src/App/Container.purs
View File

@ -17,9 +17,10 @@ import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff)
data Action
= OutputAuthComponent AF.Output -- User has been authenticated.
| AuthDEvent WS.Output -- Events from authd.
| DNSManagerDEvent WS.Output -- Events from dnsmanagerd.
= OutputAuthComponent AF.Output
| OutputAuthAdminComponent AAI.Output -- Admin interface.
| AuthDEvent WS.Output -- Events from authd.
| DNSManagerDEvent WS.Output -- Events from dnsmanagerd.
type State = { token :: Maybe String
, uid :: Maybe Int
@ -91,7 +92,7 @@ render state
render_authd_admin_interface = Bulma.box $ case state.token of
Just _ ->
[ Bulma.h1 "Administrative interface for authd"
, HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8080"
, HH.slot _aai unit AAI.component unit OutputAuthAdminComponent
]
Nothing -> [ Bulma.p "Here will be the administrative box." ]
@ -112,6 +113,12 @@ handleAction = case _ of
AF.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
AF.UnableToSend message -> H.tell _log unit (Log.UnableToSend message)
OutputAuthAdminComponent 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.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
AAI.UnableToSend message -> H.tell _log unit (Log.UnableToSend message)
-- TODO: depending on the current page, we should provide the received message to
-- different components.
AuthDEvent ev -> case ev of