Authentication Daemon Administration Interface: search for a user!
This commit is contained in:
parent
98a30b6c1d
commit
f53c265114
@ -7,7 +7,7 @@
|
||||
-}
|
||||
module App.AuthenticationDaemonAdminInterface where
|
||||
|
||||
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<))
|
||||
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
@ -27,12 +27,14 @@ import Web.HTML (window) as HTML
|
||||
import Web.HTML.Window (sessionStorage) as Window
|
||||
import Web.Storage.Storage as Storage
|
||||
|
||||
import App.UserPublic (UserPublic)
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
|
||||
import App.LogMessage
|
||||
-- import App.IPC as IPC
|
||||
import App.Email as Email
|
||||
|
||||
-- import App.Messages.DNSManagerDaemon as DNSManager
|
||||
import App.Messages.AuthenticationDaemon as AuthD
|
||||
|
||||
data Output
|
||||
@ -42,7 +44,7 @@ data Output
|
||||
| StoreState State
|
||||
|
||||
data Query a
|
||||
= MessageReceived ArrayBuffer a
|
||||
= MessageReceived AuthD.AnswerMessage a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
| ProvideState (Maybe State) a
|
||||
@ -56,16 +58,12 @@ data AddUserInput
|
||||
| ADDUSER_INP_email String
|
||||
| ADDUSER_toggle_admin
|
||||
| ADDUSER_INP_pass String
|
||||
| SEARCHUSER_INP_login String
|
||||
| SEARCHUSER_INP_email String
|
||||
| SEARCHUSER_toggle_admin
|
||||
--| SEARCHUSER_INP_domain
|
||||
| SEARCHUSER_INP_regex String
|
||||
--| SEARCHUSER_INP_domain String
|
||||
|
||||
data Action
|
||||
= HandleAddUserInput AddUserInput
|
||||
|
||||
| CancelModal
|
||||
|
||||
| AddUserAttempt
|
||||
| SearchUserAttempt
|
||||
| PreventSubmit Event
|
||||
@ -81,13 +79,14 @@ data Action
|
||||
data Page = Home | Search | Add
|
||||
|
||||
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
|
||||
type StateSearchUserForm = { login :: String, admin :: Boolean, email :: String, domain :: String }
|
||||
type StateSearchUserForm = { regex :: String {-, admin :: Boolean, domain :: String -} }
|
||||
|
||||
type State =
|
||||
{ addUserForm :: StateAddUserForm
|
||||
, searchUserForm :: StateSearchUserForm
|
||||
, page :: Page
|
||||
, wsUp :: Boolean
|
||||
, matching_users :: Array UserPublic
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
@ -105,26 +104,29 @@ component =
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }
|
||||
, searchUserForm: { login: "", admin: false, email: "", domain: "" }
|
||||
, searchUserForm: { regex: "" {-, admin: false, domain: "" -} }
|
||||
, matching_users: []
|
||||
, page: Home
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { addUserForm, searchUserForm, page, wsUp }
|
||||
render { addUserForm, searchUserForm, matching_users, page, wsUp }
|
||||
= HH.div_
|
||||
[ Bulma.box [routing_search_button, routing_add_button]
|
||||
, case page of
|
||||
Home -> Bulma.section_small [Bulma.h3 "Select an action"]
|
||||
Search -> Bulma.columns_
|
||||
[ Bulma.column (C.is_size 3) [Bulma.article (Bulma.p "Search users") render_searchuser_form]
|
||||
, Bulma.column_ [ Bulma.h3 "Result", Bulma.subtitle "TODO" ]
|
||||
, Bulma.column_ [ Bulma.h3 "Result", show_found_users ]
|
||||
]
|
||||
Add -> Bulma.columns_
|
||||
[ Bulma.column (C.is_size 5) [Bulma.article (Bulma.p "Add a new user") render_adduser_form] ]
|
||||
]
|
||||
where
|
||||
|
||||
show_found_users = HH.div_ $ map user_card matching_users
|
||||
user_card user = Bulma.box [Bulma.p user.login]
|
||||
up x = HandleAddUserInput <<< x
|
||||
active = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_adduser_form =
|
||||
@ -137,49 +139,53 @@ render { addUserForm, searchUserForm, page, wsUp }
|
||||
, Bulma.btn "Send" AddUserAttempt
|
||||
]
|
||||
|
||||
up x = HandleAddUserInput <<< x
|
||||
|
||||
render_searchuser_form =
|
||||
HH.form
|
||||
[ HE.onSubmit PreventSubmit ]
|
||||
[ Bulma.box_input "login" "Login" "login" (up SEARCHUSER_INP_login) searchUserForm.login active
|
||||
, Bulma.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin) (HandleAddUserInput SEARCHUSER_toggle_admin)
|
||||
, Bulma.box_input "email" "Email" "email" (up SEARCHUSER_INP_email) searchUserForm.email active
|
||||
[ Bulma.p """
|
||||
Following input accepts any regex.
|
||||
This will be used to search an user based on his login, full name or email address.
|
||||
"""
|
||||
, Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex active
|
||||
--, Bulma.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin)
|
||||
-- (HandleAddUserInput SEARCHUSER_toggle_admin)
|
||||
--, Bulma.box_input "domain" "Domain owned" "blah.netlib.re."
|
||||
-- (up SEARCHUSER_INP_domain) searchUserForm.email active
|
||||
-- (up SEARCHUSER_INP_domain) searchUserForm.domain active
|
||||
, Bulma.btn "Send" SearchUserAttempt
|
||||
]
|
||||
|
||||
routing_search_button = Bulma.btn "Search" $ Routing Search
|
||||
routing_add_button = Bulma.btn "Add" $ Routing Add
|
||||
cancel_button = Bulma.cancel_button CancelModal
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
Initialize -> do
|
||||
H.raise $ AskState
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
old_page <- H.liftEffect $ Storage.getItem "current-ada-page" sessionstorage
|
||||
case old_page of
|
||||
Nothing -> H.raise $ Log $ SimpleLog "we hadn't changed page before reload apparently."
|
||||
Just page -> case page of
|
||||
"Home" -> handleAction $ Routing Home
|
||||
"Search" -> handleAction $ Routing Search
|
||||
"Add" -> handleAction $ Routing Add
|
||||
_ -> H.raise $ Log $ SimpleLog $ "reload but cannot understand old page: " <> page
|
||||
|
||||
Finalize -> do
|
||||
state <- H.get
|
||||
H.raise $ StoreState state
|
||||
|
||||
HandleAddUserInput adduserinp -> do
|
||||
{ addUserForm, searchUserForm } <- H.get
|
||||
{ addUserForm } <- H.get
|
||||
case adduserinp of
|
||||
ADDUSER_INP_login v -> H.modify_ _ { addUserForm { login = v } }
|
||||
ADDUSER_INP_email v -> H.modify_ _ { addUserForm { email = v } }
|
||||
ADDUSER_toggle_admin -> H.modify_ _ { addUserForm { admin = not addUserForm.admin } }
|
||||
ADDUSER_INP_pass v -> H.modify_ _ { addUserForm { pass = v } }
|
||||
SEARCHUSER_INP_login v -> H.modify_ _ { searchUserForm { login = v } }
|
||||
SEARCHUSER_INP_email v -> H.modify_ _ { searchUserForm { email = v } }
|
||||
SEARCHUSER_toggle_admin -> H.modify_ _ { searchUserForm { admin = not searchUserForm.admin } }
|
||||
-- SEARCHUSER_INP_domain v -> H.modify_ _ { searchUserForm { domain = v } }
|
||||
SEARCHUSER_INP_regex v -> H.modify_ _ { searchUserForm { regex = v } }
|
||||
|
||||
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
CancelModal -> do
|
||||
handleAction $ Routing Search
|
||||
|
||||
AddUserAttempt -> do
|
||||
{ addUserForm } <- H.get
|
||||
let login = addUserForm.login
|
||||
@ -209,18 +215,19 @@ handleAction = case _ of
|
||||
H.modify_ _ { page = page }
|
||||
|
||||
SearchUserAttempt -> do
|
||||
--{ searchUserForm } <- H.get
|
||||
--let login = searchUserForm.login
|
||||
-- email = searchUserForm.email
|
||||
-- -- domain = searchUserForm.domain
|
||||
-- admin = searchUserForm.admin
|
||||
--ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkSearchUser { login:
|
||||
-- , admin:
|
||||
-- , email: Just (Email.Email email)
|
||||
-- , domain:
|
||||
-- }
|
||||
--H.raise $ MessageToSend ab
|
||||
H.raise $ Log $ SimpleLog "[😇] TODO: Trying to add a user"
|
||||
{ searchUserForm } <- H.get
|
||||
let regex = searchUserForm.regex
|
||||
-- domain = searchUserForm.domain
|
||||
-- admin = searchUserForm.admin
|
||||
ab <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 }
|
||||
H.raise $ MessageToSend ab
|
||||
H.modify_ _ { matching_users = [] }
|
||||
H.raise $ Log $ SimpleLog "[😇] Trying to search a user"
|
||||
|
||||
not_empty_string :: String -> Maybe String
|
||||
not_empty_string "" = Nothing
|
||||
not_empty_string v = Just v
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
@ -233,32 +240,20 @@ handleQuery = case _ of
|
||||
pure (Just a)
|
||||
|
||||
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 $ Log $ SystemLog $ "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")
|
||||
case message of
|
||||
(AuthD.GotError errmsg) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
||||
(AuthD.GotUserAdded msg) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[🎉] Success! Server added user: " <> show msg.user
|
||||
|
||||
-- Cases where we understood the message.
|
||||
Right response -> do
|
||||
case response of
|
||||
(AuthD.GotError errmsg) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
||||
pure (Just a)
|
||||
(AuthD.GotUserAdded msg) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Success! Server added user: " <> show msg.user
|
||||
pure (Just a)
|
||||
-- WTH?!
|
||||
_ -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
|
||||
pure (Just a)
|
||||
(AuthD.GotMatchingUsers msg) -> do
|
||||
H.raise $ Log $ SimpleLog "[🎉] Received a list of users."
|
||||
H.modify_ _ { matching_users = msg.users }
|
||||
|
||||
-- Unexpected message.
|
||||
_ -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
@ -267,12 +262,3 @@ handleQuery = case _ of
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
|
||||
|
||||
----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 $ Log $ SimpleLog $ case (value) of
|
||||
-- Left _ -> "Cannot even fromTypedIPC the message."
|
||||
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
|
||||
|
||||
@ -368,11 +368,15 @@ handleAction = case _ of
|
||||
case response of
|
||||
(AuthD.GotUser _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUser message."
|
||||
(AuthD.GotUserAdded _) -> do
|
||||
handleAction $ Log $ SimpleLog """
|
||||
[🎉] you are now registered, copy the token we sent you by email to finish your registration.
|
||||
"""
|
||||
handleAction $ Routing MailValidation
|
||||
m@(AuthD.GotUserAdded _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Registration -> do
|
||||
handleAction $ Log $ SimpleLog """
|
||||
[🎉] you are now registered, copy the token we sent you by email to finish your registration.
|
||||
"""
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> handleAction $ DispatchAuthDaemonMessage m
|
||||
(AuthD.GotUserEdited _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUserEdited message."
|
||||
(AuthD.GotUserValidated _) -> do
|
||||
@ -386,8 +390,12 @@ handleAction = case _ of
|
||||
handleAction $ Log $ SimpleLog "[😈] Received a GotPermissionSet message."
|
||||
(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotPasswordRecovered message."
|
||||
(AuthD.GotMatchingUsers _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotMatchingUsers message."
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
AuthAdmin -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ SimpleLog
|
||||
"[😈] received a GotMatchingUsers message while not on authd admin page."
|
||||
(AuthD.GotUserDeleted _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Received a GotUserDeleted message."
|
||||
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
||||
@ -447,19 +455,12 @@ handleAction = case _ of
|
||||
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
-- | TODO: **CURRENTLY** this dispatch function is useless since no component require `authd` messages directly.
|
||||
DispatchAuthDaemonMessage _ -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] DispatchAuthDaemonMessage action, called for no reason!"
|
||||
DispatchAuthDaemonMessage message -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
AuthAdmin -> H.tell _aai unit (AAI.MessageReceived message)
|
||||
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
||||
pure unit
|
||||
-- { token } <- H.get
|
||||
-- case token of
|
||||
-- Nothing -> H.tell _ai unit (AI.MessageReceived message)
|
||||
-- Just _ -> H.tell _aai unit (AAI.MessageReceived message)
|
||||
-- case current_page of
|
||||
-- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message)
|
||||
-- Zone _ -> H.tell _zi unit (ZoneInterface.MessageReceived message)
|
||||
-- _ -> H.tell _log unit (AppLog.Log $ SystemLog "unexpected message from authd")
|
||||
-- pure unit
|
||||
|
||||
Disconnection -> do
|
||||
H.put $ initialState unit
|
||||
|
||||
Loading…
Reference in New Issue
Block a user