Remove printing messages in AuthenticationDaemonAdminInterface.

beta
Philippe Pittoli 2023-07-04 04:49:22 +02:00
parent 3be96bd436
commit b061c0b18e
2 changed files with 82 additions and 200 deletions

View File

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

View File

@ -17,7 +17,8 @@ import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
data Action data Action
= OutputAuthComponent AF.Output -- User has been authenticated. = OutputAuthComponent AF.Output
| OutputAuthAdminComponent AAI.Output -- Admin interface.
| AuthDEvent WS.Output -- Events from authd. | AuthDEvent WS.Output -- Events from authd.
| DNSManagerDEvent WS.Output -- Events from dnsmanagerd. | DNSManagerDEvent WS.Output -- Events from dnsmanagerd.
@ -91,7 +92,7 @@ render state
render_authd_admin_interface = Bulma.box $ case state.token of render_authd_admin_interface = Bulma.box $ case state.token of
Just _ -> Just _ ->
[ Bulma.h1 "Administrative interface for authd" [ 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." ] 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.SystemMessage message -> H.tell _log unit (Log.SystemLog message)
AF.UnableToSend message -> H.tell _log unit (Log.UnableToSend 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 -- TODO: depending on the current page, we should provide the received message to
-- different components. -- different components.
AuthDEvent ev -> case ev of AuthDEvent ev -> case ev of