Remove printing messages in AuthenticationDaemonAdminInterface.
parent
3be96bd436
commit
b061c0b18e
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue