Admin page: can now delete user accounts.
This commit is contained in:
parent
35ff1d1347
commit
a88eda1d94
3 changed files with 63 additions and 50 deletions
|
|
@ -584,6 +584,12 @@ handleAction = case _ of
|
|||
EventPageAdministration ev -> case ev of
|
||||
PageAdministration.SendToAuthd message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageAdministration.SendToDNSManager message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
PageAdministration.DeleteDomain domain -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
PageAdministration.SearchDomain domain -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkSearchDomain { domain, offset: Just 0 }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
PageAdministration.ShowZone domain -> handleAction $ Routing $ Zone domain
|
||||
PageAdministration.Log message -> handleAction $ Log message
|
||||
PageAdministration.StoreState s -> H.modify_ _ { childstates { administration = Just s } }
|
||||
|
|
@ -598,6 +604,12 @@ handleAction = case _ of
|
|||
auth_message <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid }
|
||||
H.tell _ws_dns unit (WS.ToSend dns_message)
|
||||
H.tell _ws_auth unit (WS.ToSend auth_message)
|
||||
PageAdministration.AddUser login admin email password -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAddUser { login, admin, email, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageAdministration.SearchUser regex offset -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkSearchUser { regex, offset }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageAdministration.GetOrphanDomains -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetOrphanDomains {}
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
|
|
|
|||
|
|
@ -39,19 +39,26 @@ import Data.ArrayBuffer.Types (ArrayBuffer)
|
|||
import App.Type.LogMessage
|
||||
import App.Type.Email as Email
|
||||
|
||||
import App.Message.DNSManagerDaemon as DNSManager
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
data Output
|
||||
= SendToAuthd ArrayBuffer
|
||||
| SendToDNSManager ArrayBuffer
|
||||
| ShowZone String
|
||||
| Log LogMessage
|
||||
| AskState
|
||||
| StoreState State
|
||||
|
||||
| AddUser String Boolean (Maybe Email.Email) String
|
||||
| SearchUser (Maybe String) (Maybe Int)
|
||||
| DeleteUserAccount Int
|
||||
|
||||
| GetOrphanDomains
|
||||
|
||||
| DeleteDomain String
|
||||
| SearchDomain String
|
||||
| ShowZone String
|
||||
|
||||
| Log LogMessage
|
||||
| StoreState State
|
||||
| AskState
|
||||
|
||||
data Query a
|
||||
= MessageReceived AuthD.AnswerMessage a
|
||||
| GotOrphanDomainList (Array String) a
|
||||
|
|
@ -87,7 +94,7 @@ data Action
|
|||
|
||||
-- Users.
|
||||
| ShowUser Int
|
||||
| RemoveUser Int
|
||||
| DeleteUser Int
|
||||
|
||||
-- Domains.
|
||||
| RemoveDomain String
|
||||
|
|
@ -103,7 +110,7 @@ data Action
|
|||
|
||||
-- | There are different tabs in the administration page.
|
||||
-- | For example, users can be searched (`authd`) and a list is provided.
|
||||
data Tab = Home | SearchUser | SearchDomain | Add | OrphanDomains
|
||||
data Tab = TabHome | TabSearchUser | TabSearchDomain | TabAddUser | TabOrphanDomains
|
||||
derive instance eqTab :: Eq Tab
|
||||
|
||||
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
|
||||
|
|
@ -140,7 +147,7 @@ initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "
|
|||
, matching_users: []
|
||||
, matching_domains: []
|
||||
, orphan_domains: []
|
||||
, current_tab: Home
|
||||
, current_tab: TabHome
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
|
|
@ -150,18 +157,18 @@ render { addUserForm, searchUserForm, searchDomainForm
|
|||
= Web.section_small
|
||||
[ fancy_tab_bar
|
||||
, case current_tab of
|
||||
Home -> Web.h3 "Select an action"
|
||||
SearchUser -> Web.columns_
|
||||
TabHome -> Web.h3 "Select an action"
|
||||
TabSearchUser -> Web.columns_
|
||||
[ Web.column [C.is 3] [Web.article (Web.p "Search users") render_searchuser_form]
|
||||
, Web.column_ [ Templates.found_users ShowUser matching_users ]
|
||||
, Web.column_ [ Templates.found_users ShowUser DeleteUser matching_users ]
|
||||
]
|
||||
SearchDomain -> Web.columns_
|
||||
TabSearchDomain -> Web.columns_
|
||||
[ Web.column [C.is 3] [Web.article (Web.p "Search domains") render_searchdomain_form]
|
||||
, Web.column_ [ Templates.found_domains EnterDomain RemoveDomain matching_domains ]
|
||||
]
|
||||
Add -> Web.columns_
|
||||
TabAddUser -> Web.columns_
|
||||
[ Web.column [C.is 5] [Web.article (Web.p "Add a new user") render_adduser_form] ]
|
||||
OrphanDomains -> HH.div_
|
||||
TabOrphanDomains -> HH.div_
|
||||
[ Web.btn_ [C.is_small] "Get orphan domains" ShowOrphanDomains
|
||||
, show_orphan_domains
|
||||
]
|
||||
|
|
@ -169,11 +176,11 @@ render { addUserForm, searchUserForm, searchDomainForm
|
|||
where
|
||||
fancy_tab_bar =
|
||||
Web.fancy_tabs
|
||||
[ Web.tab_entry (is_tab_active Home) "Home" (ChangeTab Home)
|
||||
, Web.tab_entry (is_tab_active SearchUser) "SearchUser" (ChangeTab SearchUser)
|
||||
, Web.tab_entry (is_tab_active SearchDomain) "SearchDomain" (ChangeTab SearchDomain)
|
||||
, Web.tab_entry (is_tab_active Add) "Add" (ChangeTab Add)
|
||||
, Web.tab_entry (is_tab_active OrphanDomains) "OrphanDomains" (ChangeTab OrphanDomains)
|
||||
[ Web.tab_entry (is_tab_active TabHome) "Home" (ChangeTab TabHome)
|
||||
, Web.tab_entry (is_tab_active TabSearchUser) "SearchUser" (ChangeTab TabSearchUser)
|
||||
, Web.tab_entry (is_tab_active TabSearchDomain) "SearchDomain" (ChangeTab TabSearchDomain)
|
||||
, Web.tab_entry (is_tab_active TabAddUser) "AddUser" (ChangeTab TabAddUser)
|
||||
, Web.tab_entry (is_tab_active TabOrphanDomains) "OrphanDomains" (ChangeTab TabOrphanDomains)
|
||||
]
|
||||
is_tab_active tab = current_tab == tab
|
||||
|
||||
|
|
@ -223,11 +230,11 @@ handleAction = case _ of
|
|||
case old_tab of
|
||||
Nothing -> pure unit
|
||||
Just current_tab -> case current_tab of
|
||||
"Home" -> handleAction $ ChangeTab Home
|
||||
"SearchUser" -> handleAction $ ChangeTab SearchUser
|
||||
"SearchDomain" -> handleAction $ ChangeTab SearchDomain
|
||||
"Add" -> handleAction $ ChangeTab Add
|
||||
"OrphanDomains" -> handleAction $ ChangeTab OrphanDomains
|
||||
"TabHome" -> handleAction $ ChangeTab TabHome
|
||||
"TabSearchUser" -> handleAction $ ChangeTab TabSearchUser
|
||||
"TabSearchDomain" -> handleAction $ ChangeTab TabSearchDomain
|
||||
"TabAddUser" -> handleAction $ ChangeTab TabAddUser
|
||||
"TabOrphanDomains" -> handleAction $ ChangeTab TabOrphanDomains
|
||||
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
|
||||
|
||||
Finalize -> do
|
||||
|
|
@ -259,16 +266,16 @@ handleAction = case _ of
|
|||
H.raise $ Log $ SystemLog $ "Get orphan domains"
|
||||
H.raise $ GetOrphanDomains
|
||||
|
||||
RemoveUser uid -> do
|
||||
DeleteUser uid -> do
|
||||
H.raise $ Log $ SystemLog $ "Remove user " <> show uid
|
||||
H.raise $ DeleteUserAccount uid
|
||||
|
||||
RemoveDomain domain -> do
|
||||
H.raise $ Log $ SystemLog $ "TODO: remove domain " <> domain
|
||||
--H.raise $ DeleteDomain domain
|
||||
H.raise $ Log $ SystemLog $ "Remove domain " <> domain
|
||||
H.raise $ DeleteDomain domain
|
||||
|
||||
EnterDomain domain -> do
|
||||
H.raise $ Log $ SystemLog $ "show domain " <> domain
|
||||
H.raise $ Log $ SystemLog $ "Show zone " <> domain
|
||||
H.raise $ ShowZone domain
|
||||
|
||||
AddUserAttempt -> do
|
||||
|
|
@ -283,39 +290,31 @@ handleAction = case _ of
|
|||
_, _, "" -> H.raise $ Log $ 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 $ SendToAuthd ab
|
||||
H.raise $ Log $ SystemLog "Add a user"
|
||||
H.raise $ AddUser login addUserForm.admin (Just (Email.Email email)) pass
|
||||
|
||||
ChangeTab current_tab -> do
|
||||
-- Store the current tab we are on and restore it when we reload.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- case current_tab of
|
||||
Home -> H.liftEffect $ Storage.setItem "current-ada-tab" "Home" sessionstorage
|
||||
SearchUser -> H.liftEffect $ Storage.setItem "current-ada-tab" "SearchUser" sessionstorage
|
||||
SearchDomain -> H.liftEffect $ Storage.setItem "current-ada-tab" "SearchDomain" sessionstorage
|
||||
Add -> H.liftEffect $ Storage.setItem "current-ada-tab" "Add" sessionstorage
|
||||
OrphanDomains -> H.liftEffect $ Storage.setItem "current-ada-tab" "OrphanDomains" sessionstorage
|
||||
TabHome -> H.liftEffect $ Storage.setItem "current-ada-tab" "TabHome" sessionstorage
|
||||
TabSearchUser -> H.liftEffect $ Storage.setItem "current-ada-tab" "TabSearchUser" sessionstorage
|
||||
TabSearchDomain -> H.liftEffect $ Storage.setItem "current-ada-tab" "TabSearchDomain" sessionstorage
|
||||
TabAddUser -> H.liftEffect $ Storage.setItem "current-ada-tab" "TabAddUser" sessionstorage
|
||||
TabOrphanDomains -> H.liftEffect $ Storage.setItem "current-ada-tab" "TabOrphanDomains" sessionstorage
|
||||
H.modify_ _ { current_tab = current_tab }
|
||||
|
||||
SearchUserAttempt -> do
|
||||
{ searchUserForm } <- H.get
|
||||
let regex = searchUserForm.regex
|
||||
ab <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 }
|
||||
H.raise $ SendToAuthd ab
|
||||
H.raise $ SearchUser (not_empty_string regex) (Just 0)
|
||||
H.modify_ _ { matching_users = [] }
|
||||
|
||||
SearchDomainAttempt -> do
|
||||
{ searchDomainForm } <- H.get
|
||||
let domain = searchDomainForm.domain
|
||||
H.raise $ Log $ SystemLog $ "TODO: search for this domain: " <> domain
|
||||
ab <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkSearchDomain { domain, offset: Just 0 }
|
||||
H.raise $ SendToDNSManager ab
|
||||
H.raise $ Log $ SystemLog $ "Search for this domain: " <> domain
|
||||
H.raise $ SearchDomain domain
|
||||
H.modify_ _ { matching_domains = [] }
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
|
|
|
|||
|
|
@ -570,8 +570,10 @@ display_dmarc_mail_addresses f ms = Web.table [] [ header, HH.tbody_ $ map row $
|
|||
, HH.td_ [ Button.alert_btn "x" (f i) ]
|
||||
]
|
||||
|
||||
found_users :: forall w i. (Int -> i) -> Array UserPublic -> HH.HTML w i
|
||||
found_users f users = Web.table [] [ header, HH.tbody_ $ map row users ]
|
||||
type ActionShowUser i = (Int -> i)
|
||||
type ActionDeleteUser i = (Int -> i)
|
||||
found_users :: forall w i. ActionShowUser i -> ActionDeleteUser i -> Array UserPublic -> HH.HTML w i
|
||||
found_users action_show_user action_delete_user users = Web.table [] [ header, HH.tbody_ $ map row users ]
|
||||
where
|
||||
header :: HH.HTML w i
|
||||
header
|
||||
|
|
@ -583,10 +585,10 @@ found_users f users = Web.table [] [ header, HH.tbody_ $ map row users ]
|
|||
]
|
||||
row :: UserPublic -> HH.HTML w i
|
||||
row user = HH.tr_
|
||||
[ HH.td_ [ Web.p user.login ]
|
||||
[ HH.td_ [ Button.btn user.login (action_show_user user.uid) ]
|
||||
, HH.td_ [ Web.p $ show user.uid ]
|
||||
, HH.td_ [ Web.p $ fromMaybe "" user.date_registration ]
|
||||
, HH.td_ [ Button.alert_btn "x" (f user.uid) ]
|
||||
, HH.td_ [ Button.alert_btn "x" (action_delete_user user.uid) ]
|
||||
]
|
||||
|
||||
type ActionEnterDomain i = (String -> i)
|
||||
|
|
@ -599,7 +601,7 @@ found_domains action_enter_domain action_delete_domain domains = Web.table [] [
|
|||
row dom = HH.tr_
|
||||
[ HH.td_ [ Button.btn dom (action_enter_domain dom) ]
|
||||
, HH.td_ [ Web.p "" ]
|
||||
, HH.td_ [ Button.alert_btn "x" (action_delete_domain dom) ]
|
||||
, HH.td_ [ Button.alert_btn "x" (action_delete_domain dom) ]
|
||||
]
|
||||
header :: HH.HTML w i
|
||||
header
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue