Administrative interface for authd now in a new container.
This commit is contained in:
parent
7576bc682c
commit
3831b275b4
505
src/App/AuthenticationDaemonAdminInterface.purs
Normal file
505
src/App/AuthenticationDaemonAdminInterface.purs
Normal file
@ -0,0 +1,505 @@
|
||||
module App.AuthenticationDaemonAdminInterface where
|
||||
|
||||
{- Administration interface for the authentication daemon.
|
||||
This interface should allow to:
|
||||
- TODO: add, remove, search, validate users
|
||||
- TODO: raise a user to admin
|
||||
-}
|
||||
|
||||
import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=))
|
||||
|
||||
import Control.Monad.Except (runExcept)
|
||||
import Control.Monad.State (class MonadState)
|
||||
import Data.Array as A
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Data.Bifunctor (lmap)
|
||||
import Data.Const (Const)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
|
||||
import Data.String as String
|
||||
import Effect (Effect)
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Foreign (Foreign)
|
||||
import Foreign as F
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.Query.Event as HQE
|
||||
import Halogen.Subscription as HS
|
||||
import Web.Event.Event (Event)
|
||||
import Web.Event.Event as Event
|
||||
import Web.Socket.Event.CloseEvent as WSCE
|
||||
import Web.Socket.Event.EventTypes as WSET
|
||||
import Web.Socket.Event.MessageEvent as WSME
|
||||
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
||||
import Web.Socket.WebSocket as WS
|
||||
|
||||
import Effect.Class (class MonadEffect)
|
||||
|
||||
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))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- WebSocketEvent type
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data WebSocketEvent :: Type -> Type
|
||||
data WebSocketEvent msg
|
||||
= WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
|
||||
| WebSocketOpen
|
||||
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
|
||||
| WebSocketError ErrorType
|
||||
|
||||
webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
webSocketEmitter socket = do
|
||||
|
||||
HS.makeEmitter \push -> do
|
||||
|
||||
openId <- HS.subscribe openEmitter push
|
||||
errorId <- HS.subscribe errorEmitter push
|
||||
closeId <- HS.subscribe closeEmitter push
|
||||
messageId <- HS.subscribe messageEmitter push
|
||||
|
||||
pure do
|
||||
HS.unsubscribe openId
|
||||
HS.unsubscribe errorId
|
||||
HS.unsubscribe closeId
|
||||
HS.unsubscribe messageId
|
||||
|
||||
where
|
||||
target = WS.toEventTarget socket
|
||||
|
||||
openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
openEmitter =
|
||||
HQE.eventListener WSET.onOpen target \_ ->
|
||||
Just WebSocketOpen
|
||||
|
||||
errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
errorEmitter =
|
||||
HQE.eventListener WSET.onError target \_ ->
|
||||
Just (WebSocketError UnknownWebSocketError)
|
||||
|
||||
closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
closeEmitter =
|
||||
HQE.eventListener WSET.onClose target \event ->
|
||||
WSCE.fromEvent event >>= \closeEvent ->
|
||||
Just $ WebSocketClose { code: WSCE.code closeEvent
|
||||
, reason: WSCE.reason closeEvent
|
||||
, wasClean: WSCE.wasClean closeEvent
|
||||
}
|
||||
|
||||
messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
|
||||
|
||||
decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
|
||||
decodeMessageEvent = \msgEvent -> do
|
||||
let
|
||||
foreign' :: Foreign
|
||||
foreign' = WSME.data_ msgEvent
|
||||
case foreignToArrayBuffer foreign' of
|
||||
Left errs -> pure $ WebSocketError $ UnknownError errs
|
||||
Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
|
||||
|
||||
---------------------------
|
||||
-- Errors
|
||||
---------------------------
|
||||
|
||||
data ErrorType
|
||||
= UnknownError String
|
||||
| UnknownWebSocketError
|
||||
|
||||
renderError :: ErrorType -> String
|
||||
renderError = case _ of
|
||||
UnknownError str ->
|
||||
"Unknown error: " <> str
|
||||
UnknownWebSocketError ->
|
||||
"Unknown 'error' event has been fired by WebSocket event listener"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- WebSocket message type
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type WebSocketMessageType = ArrayBuffer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Root component module
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Output = Void
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Query :: forall k. k -> Type
|
||||
type Query = Const Void
|
||||
type Input = String
|
||||
|
||||
data AddUserInput
|
||||
= ADDUSER_INP_secret String
|
||||
| ADDUSER_INP_login String
|
||||
| ADDUSER_INP_email String
|
||||
| ADDUSER_INP_pass String
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
| WebSocketParseError String
|
||||
| ConnectWebSocket
|
||||
|
||||
| HandleAddUserInput AddUserInput
|
||||
|
||||
| AddUserAttempt Event
|
||||
-- | Finalize
|
||||
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||
|
||||
type StateAuthenticationForm = { login :: String, pass :: String }
|
||||
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
|
||||
type StateAddUserForm = { secretKey :: String, login :: String, email :: String, pass :: String }
|
||||
|
||||
type State =
|
||||
{ messages :: Array String
|
||||
, messageHistoryLength :: Int
|
||||
|
||||
, addUserForm :: StateAddUserForm
|
||||
|
||||
-- TODO: put network stuff in a record.
|
||||
, wsUrl :: String
|
||||
, wsConnection :: Maybe WS.WebSocket
|
||||
, canReconnect :: Boolean
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ initialize = Just Initialize
|
||||
, handleAction = handleAction
|
||||
-- , finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState input =
|
||||
{ messages: []
|
||||
, messageHistoryLength: 10
|
||||
|
||||
, addUserForm: { secretKey: "", login: "", email: "", pass: "" }
|
||||
|
||||
-- TODO: put network stuff in a record.
|
||||
, wsUrl: input
|
||||
, wsConnection: Nothing
|
||||
, canReconnect: false
|
||||
}
|
||||
|
||||
wrapperStyle :: String
|
||||
wrapperStyle =
|
||||
"""
|
||||
display: block;
|
||||
flex-direction: column;
|
||||
justify-content: space-between;
|
||||
height: calc(100vh - 30px);
|
||||
background: #282c34;
|
||||
color: #e06c75;
|
||||
font-family: 'Consolas';
|
||||
padding: 5px 20px 5px 20px;
|
||||
"""
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render {
|
||||
messages,
|
||||
wsConnection,
|
||||
canReconnect,
|
||||
addUserForm }
|
||||
= HH.div
|
||||
[ HP.style wrapperStyle ]
|
||||
[ render_adduser_form
|
||||
, render_messages
|
||||
--, renderMaxHistoryLength messageHistoryLength
|
||||
, renderReconnectButton (isNothing wsConnection && canReconnect)
|
||||
]
|
||||
where
|
||||
|
||||
render_adduser_form = HH.form
|
||||
[ HE.onSubmit AddUserAttempt ]
|
||||
[ HH.h2_ [ HH.text "(admin) Add User!" ]
|
||||
, HH.p_
|
||||
[ HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.secretKey
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_secret
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.login
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_login
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.email
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_email
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputPassword
|
||||
, HP.value addUserForm.pass
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_pass
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
[ 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
|
||||
-- { wsConnection } <- H.get
|
||||
-- systemMessage "Finalize"
|
||||
-- case wsConnection 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
|
||||
{ wsUrl } <- H.get
|
||||
systemMessage ("Connecting to \"" <> wsUrl <> "\"...")
|
||||
webSocket <- H.liftEffect $ WS.create wsUrl []
|
||||
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
|
||||
H.modify_ _ { wsConnection = Just webSocket }
|
||||
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
|
||||
|
||||
HandleAddUserInput adduserinp -> do
|
||||
case adduserinp of
|
||||
ADDUSER_INP_secret v -> H.modify_ _ { addUserForm { secretKey = v } }
|
||||
ADDUSER_INP_login v -> H.modify_ _ { addUserForm { login = v } }
|
||||
ADDUSER_INP_email v -> H.modify_ _ { addUserForm { email = v } }
|
||||
ADDUSER_INP_pass v -> H.modify_ _ { addUserForm { pass = v } }
|
||||
|
||||
AddUserAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ wsConnection, addUserForm } <- H.get
|
||||
let secret = addUserForm.secretKey
|
||||
login = addUserForm.login
|
||||
email = addUserForm.email
|
||||
pass = addUserForm.pass
|
||||
|
||||
case wsConnection, secret, login, email, pass of
|
||||
Nothing, _, _, _, _ ->
|
||||
unableToSend "Not connected to server."
|
||||
|
||||
Just _, "", _, _, _ ->
|
||||
unableToSend "Write your secret key!"
|
||||
|
||||
Just _, _, "", _, _ ->
|
||||
unableToSend "Write your login!"
|
||||
|
||||
Just _, _, _, "", _ ->
|
||||
unableToSend "Write your email!"
|
||||
|
||||
Just _, _, _, _, "" ->
|
||||
unableToSend "Write your password!"
|
||||
|
||||
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 _.wsConnection
|
||||
when (isJust maybeCurrentConnection) do
|
||||
H.modify_ _ { wsConnection = Nothing, canReconnect = true }
|
||||
|
||||
Open -> do
|
||||
H.liftEffect $ do
|
||||
ab <- AuthD.serialize $ AuthD.MkAddUser { shared_key: secret
|
||||
, login: login
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass
|
||||
, phone: Nothing}
|
||||
sendArrayBuffer webSocket ab
|
||||
appendMessageReset "[😇] Trying to add a user"
|
||||
|
||||
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
|
||||
{ wsUrl } <- H.get
|
||||
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉")
|
||||
|
||||
WebSocketClose { code, reason, wasClean } -> do
|
||||
systemMessage $ renderCloseMessage code wasClean reason
|
||||
maybeCurrentConnection <- H.gets _.wsConnection
|
||||
when (isJust maybeCurrentConnection) do
|
||||
H.modify_ _ { wsConnection = Nothing, canReconnect = 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"
|
||||
, "]"
|
||||
]
|
||||
|
||||
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
|
||||
sendArrayBuffer = WS.sendArrayBuffer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Helpers for updating the array of messages sent/received
|
||||
--------------------------------------------------------------------------------
|
||||
-- Append a new message to the chat history, with a boolean that allows you to
|
||||
-- clear the text input field or not. The number of displayed `messages` in the
|
||||
-- chat history (including system) is controlled by the `messageHistoryLength`
|
||||
-- field in the component `State`.
|
||||
appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit
|
||||
appendMessageGeneric clearField msg = do
|
||||
histSize <- H.gets _.messageHistoryLength
|
||||
if clearField
|
||||
then H.modify_ \st ->
|
||||
st { messages = appendSingle histSize msg st.messages, addUserForm { login = "" }}
|
||||
else H.modify_ \st ->
|
||||
st { messages = appendSingle histSize msg st.messages }
|
||||
where
|
||||
-- Limits the nnumber of recent messages to `maxHist`
|
||||
appendSingle :: Int -> String -> Array String -> Array String
|
||||
appendSingle maxHist x xs
|
||||
| A.length xs < maxHist = xs `A.snoc` x
|
||||
| otherwise = (A.takeEnd (maxHist-1) xs) `A.snoc` x
|
||||
|
||||
-- Append a new message to the chat history, while not clearing
|
||||
-- the user input field
|
||||
appendMessage :: forall m. MonadState State m => String -> m Unit
|
||||
appendMessage = appendMessageGeneric false
|
||||
|
||||
-- Append a new message to the chat history and also clear
|
||||
-- the user input field
|
||||
appendMessageReset :: forall m. MonadState State m => String -> m Unit
|
||||
appendMessageReset = appendMessageGeneric true
|
||||
|
||||
-- Append a system message to the chat log.
|
||||
systemMessage :: forall m. MonadState State m => String -> m Unit
|
||||
systemMessage msg = appendMessage ("[🤖] System: " <> msg)
|
||||
|
||||
-- As above, but also clears the user input field. e.g. in
|
||||
-- the case of a "/disconnect" command
|
||||
systemMessageReset :: forall m. MonadState State m => String -> m Unit
|
||||
systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
|
||||
|
||||
-- A system message to use when a message cannot be sent.
|
||||
unableToSend :: forall m. MonadState State m => String -> m Unit
|
||||
unableToSend reason = systemMessage ("Unable to send. " <> reason)
|
||||
|
||||
foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer
|
||||
foreignToArrayBuffer
|
||||
= lmap renderForeignErrors
|
||||
<<< runExcept
|
||||
<<< F.unsafeReadTagged "ArrayBuffer"
|
||||
where
|
||||
renderForeignErrors :: F.MultipleErrors -> String
|
||||
renderForeignErrors =
|
||||
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
|
||||
|
||||
inputCSS = HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;"
|
||||
|
||||
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
|
||||
@ -141,12 +141,6 @@ data RegisterInput
|
||||
| REG_INP_email String
|
||||
| REG_INP_pass String
|
||||
|
||||
data AddUserInput
|
||||
= ADDUSER_INP_secret String
|
||||
| ADDUSER_INP_login String
|
||||
| ADDUSER_INP_email String
|
||||
| ADDUSER_INP_pass String
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
| WebSocketParseError String
|
||||
@ -154,17 +148,14 @@ data Action
|
||||
|
||||
| HandleAuthenticationInput AuthenticationInput
|
||||
| HandleRegisterInput RegisterInput
|
||||
| HandleAddUserInput AddUserInput -- admin operation
|
||||
|
||||
| AuthenticationAttempt Event
|
||||
| RegisterAttempt Event
|
||||
| AddUserAttempt Event
|
||||
| Finalize
|
||||
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||
|
||||
type StateAuthenticationForm = { login :: String, pass :: String }
|
||||
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
|
||||
type StateAddUserForm = { secretKey :: String, login :: String, email :: String, pass :: String }
|
||||
|
||||
type State =
|
||||
{ messages :: Array String
|
||||
@ -172,7 +163,6 @@ type State =
|
||||
|
||||
, authenticationForm :: StateAuthenticationForm
|
||||
, registrationForm :: StateRegistrationForm
|
||||
, addUserForm :: StateAddUserForm
|
||||
|
||||
-- TODO: put network stuff in a record.
|
||||
, wsUrl :: String
|
||||
@ -199,7 +189,6 @@ initialState input =
|
||||
|
||||
, authenticationForm: { login: "", pass: "" }
|
||||
, registrationForm: { login: "", email: "", pass: "" }
|
||||
, addUserForm: { secretKey: "", login: "", email: "", pass: "" }
|
||||
|
||||
-- TODO: put network stuff in a record.
|
||||
, wsUrl: input
|
||||
@ -227,13 +216,11 @@ render {
|
||||
canReconnect,
|
||||
|
||||
authenticationForm,
|
||||
registrationForm,
|
||||
addUserForm }
|
||||
registrationForm }
|
||||
= HH.div
|
||||
[ HP.style wrapperStyle ]
|
||||
[ render_auth_form
|
||||
, render_register_form
|
||||
, render_adduser_form
|
||||
, render_messages
|
||||
--, renderMaxHistoryLength messageHistoryLength
|
||||
, renderReconnectButton (isNothing wsConnection && canReconnect)
|
||||
@ -315,67 +302,12 @@ render {
|
||||
]
|
||||
]
|
||||
|
||||
render_adduser_form = HH.form
|
||||
[ HE.onSubmit AddUserAttempt ]
|
||||
[ HH.h2_ [ HH.text "(admin) Add User!" ]
|
||||
, HH.p_
|
||||
[ HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.secretKey
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_secret
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.login
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_login
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputText
|
||||
, HP.value addUserForm.email
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_email
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.input
|
||||
[ inputCSS
|
||||
, HP.type_ HP.InputPassword
|
||||
, HP.value addUserForm.pass
|
||||
, HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_pass
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
]
|
||||
, HH.div_
|
||||
[ HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
|
||||
]
|
||||
[ 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 ] ]
|
||||
|
||||
-- renderMaxHistoryLength :: Int -> H.ComponentHTML Action () m
|
||||
-- renderMaxHistoryLength len =
|
||||
-- renderFootnote ("NOTE: Maximum chat history length is " <> show len <> " messages")
|
||||
|
||||
renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
|
||||
renderReconnectButton cond =
|
||||
if cond
|
||||
@ -426,13 +358,6 @@ handleAction = case _ of
|
||||
REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
|
||||
REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } }
|
||||
|
||||
HandleAddUserInput adduserinp -> do
|
||||
case adduserinp of
|
||||
ADDUSER_INP_secret v -> H.modify_ _ { addUserForm { secretKey = v } }
|
||||
ADDUSER_INP_login v -> H.modify_ _ { addUserForm { login = v } }
|
||||
ADDUSER_INP_email v -> H.modify_ _ { addUserForm { email = v } }
|
||||
ADDUSER_INP_pass v -> H.modify_ _ { addUserForm { pass = v } }
|
||||
|
||||
RegisterAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
@ -477,55 +402,6 @@ handleAction = case _ of
|
||||
sendArrayBuffer webSocket ab
|
||||
appendMessageReset "[😇] Trying to register"
|
||||
|
||||
AddUserAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ wsConnection, addUserForm } <- H.get
|
||||
let secret = addUserForm.secretKey
|
||||
login = addUserForm.login
|
||||
email = addUserForm.email
|
||||
pass = addUserForm.pass
|
||||
|
||||
case wsConnection, secret, login, email, pass of
|
||||
Nothing, _, _, _, _ ->
|
||||
unableToSend "Not connected to server."
|
||||
|
||||
Just _, "", _, _, _ ->
|
||||
unableToSend "Write your secret key!"
|
||||
|
||||
Just _, _, "", _, _ ->
|
||||
unableToSend "Write your login!"
|
||||
|
||||
Just _, _, _, "", _ ->
|
||||
unableToSend "Write your email!"
|
||||
|
||||
Just _, _, _, _, "" ->
|
||||
unableToSend "Write your password!"
|
||||
|
||||
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 _.wsConnection
|
||||
when (isJust maybeCurrentConnection) do
|
||||
H.modify_ _ { wsConnection = Nothing, canReconnect = true }
|
||||
|
||||
Open -> do
|
||||
H.liftEffect $ do
|
||||
ab <- AuthD.serialize $ AuthD.MkAddUser { shared_key: secret
|
||||
, login: login
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass
|
||||
, phone: Nothing}
|
||||
sendArrayBuffer webSocket ab
|
||||
appendMessageReset "[😇] Trying to add a user"
|
||||
|
||||
AuthenticationAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
|
||||
@ -4,6 +4,7 @@ import Prelude
|
||||
|
||||
import Data.Maybe (Maybe(..))
|
||||
import App.AuthenticationForm as AF
|
||||
import App.AuthenticationDaemonAdminInterface as AAI
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
-- import Halogen.HTML.Events as HE
|
||||
@ -17,10 +18,12 @@ data Action
|
||||
type State = { token :: Maybe String }
|
||||
|
||||
type ChildSlots =
|
||||
( af :: AF.Slot Unit
|
||||
( af :: AF.Slot Unit
|
||||
, aai :: AAI.Slot Unit
|
||||
)
|
||||
|
||||
_af = Proxy :: Proxy "af"
|
||||
_aai = Proxy :: Proxy "aai"
|
||||
|
||||
component :: forall q i o m. MonadAff m => H.Component q i o m
|
||||
component =
|
||||
@ -37,6 +40,7 @@ render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
||||
render state
|
||||
= HH.div_ $
|
||||
[ render_auth_form
|
||||
, render_authd_admin_interface
|
||||
, div_token
|
||||
]
|
||||
where
|
||||
@ -57,6 +61,16 @@ render state
|
||||
[ HP.class_ (H.ClassName "box") ]
|
||||
[ HH.p_ [ HH.text ("Token is: " <> current_token) ] ]
|
||||
|
||||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_authd_admin_interface = case state.token of
|
||||
Just _ -> HH.div
|
||||
[ HP.class_ (H.ClassName "box") ]
|
||||
[ HH.h1_ [ HH.text "Administrative interface for authd" ]
|
||||
, HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8081"
|
||||
]
|
||||
Nothing -> HH.div
|
||||
[ HP.class_ (H.ClassName "box") ]
|
||||
[ HH.p_ [ HH.text ("Here will be the administrative box.") ] ]
|
||||
|
||||
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
handleAction = case _ of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user