355 lines
13 KiB
Text
355 lines
13 KiB
Text
{- Administration interface.
|
|
Enables to:
|
|
- add, remove, search for users
|
|
- TODO: validate users
|
|
- TODO: change user password
|
|
- TODO: show user details (list of owned domains)
|
|
- TODO: search for domains
|
|
- TODO: show user domain details (zone content) and to modify users' zone
|
|
- TODO: raise a user to admin (and vice versa)
|
|
- TODO: list users (getting them slowly, otherwise it will cause problems with thousands of logins)
|
|
-}
|
|
module App.Page.Administration where
|
|
|
|
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==), unit)
|
|
import Data.Eq (class Eq)
|
|
|
|
import Utils (not_empty_string)
|
|
import Web as Web
|
|
import App.Templates.Table as Templates
|
|
|
|
import Data.Maybe (Maybe(..))
|
|
import Data.Array as A
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Events as HE
|
|
import Web.Event.Event (Event)
|
|
import Web.Event.Event as Event
|
|
|
|
import CSSClasses as C
|
|
|
|
import Web.HTML (window) as HTML
|
|
import Web.HTML.Window (sessionStorage) as Window
|
|
import Web.Storage.Storage as Storage
|
|
|
|
import App.Type.UserPublic (UserPublic)
|
|
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
|
|
| DeleteUserAccount Int
|
|
| GetOrphanDomains
|
|
|
|
data Query a
|
|
= MessageReceived AuthD.AnswerMessage a
|
|
| GotOrphanDomainList (Array String) a
|
|
| GotFoundDomains (Array String) a
|
|
| ProvideState (Maybe State) a
|
|
|
|
type Slot = H.Slot Query Output
|
|
|
|
type Input = Unit
|
|
|
|
data AddUserInput
|
|
= ADDUSER_INP_login String
|
|
| ADDUSER_INP_email String
|
|
| ADDUSER_toggle_admin
|
|
| ADDUSER_INP_pass String
|
|
|
|
data SearchUserInput
|
|
= SEARCHUSER_INP_regex String
|
|
--| SEARCHUSER_toggle_admin Boolean
|
|
|
|
data SearchDomainInput
|
|
= SEARCHDOMAIN_INP_domain String
|
|
|
|
data Action
|
|
= ActionOnAddUserForm AddUserInput
|
|
| ActionOnSearchUserForm SearchUserInput
|
|
| ActionOnSearchDomainForm SearchDomainInput
|
|
|
|
| AddUserAttempt
|
|
| SearchUserAttempt
|
|
| SearchDomainAttempt
|
|
| PreventSubmit Event
|
|
|
|
-- Users.
|
|
| ShowUser Int
|
|
| RemoveUser Int
|
|
|
|
-- Domains.
|
|
| RemoveDomain String
|
|
| EnterDomain String
|
|
|
|
| ShowOrphanDomains
|
|
|
|
-- | Change the displayed tab.
|
|
| ChangeTab Tab
|
|
|
|
| Initialize
|
|
| Finalize
|
|
|
|
-- | 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
|
|
derive instance eqTab :: Eq Tab
|
|
|
|
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
|
|
type StateSearchUserForm = { regex :: String {- , admin :: Boolean -} }
|
|
type StateSearchDomainForm = { domain :: String }
|
|
|
|
type State =
|
|
{ addUserForm :: StateAddUserForm
|
|
, searchUserForm :: StateSearchUserForm
|
|
, searchDomainForm :: StateSearchDomainForm
|
|
, current_tab :: Tab
|
|
, matching_users :: Array UserPublic
|
|
, matching_domains :: Array String
|
|
, orphan_domains :: Array String
|
|
}
|
|
|
|
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
|
|
, handleQuery = handleQuery
|
|
, finalize = Just Finalize
|
|
}
|
|
}
|
|
|
|
initialState :: Input -> State
|
|
initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }
|
|
, searchUserForm: { regex: "" {- , admin: false -} }
|
|
, searchDomainForm: { domain: "" }
|
|
, matching_users: []
|
|
, matching_domains: []
|
|
, orphan_domains: []
|
|
, current_tab: Home
|
|
}
|
|
|
|
render :: forall m. State -> H.ComponentHTML Action () m
|
|
render { addUserForm, searchUserForm, searchDomainForm
|
|
, matching_users, matching_domains
|
|
, current_tab, orphan_domains }
|
|
= Web.section_small
|
|
[ fancy_tab_bar
|
|
, case current_tab of
|
|
Home -> Web.h3 "Select an action"
|
|
SearchUser -> Web.columns_
|
|
[ Web.column [C.is 3] [Web.article (Web.p "Search users") render_searchuser_form]
|
|
, Web.column_ [ Templates.found_users ShowUser matching_users ]
|
|
]
|
|
SearchDomain -> 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_
|
|
[ Web.column [C.is 5] [Web.article (Web.p "Add a new user") render_adduser_form] ]
|
|
OrphanDomains -> HH.div_
|
|
[ Web.btn_ [C.is_small] "Get orphan domains" ShowOrphanDomains
|
|
, show_orphan_domains
|
|
]
|
|
]
|
|
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)
|
|
]
|
|
is_tab_active tab = current_tab == tab
|
|
|
|
show_orphan_domains = Web.box [ HH.ul_ $ map domain_entry orphan_domains ]
|
|
domain_entry domain = HH.li_ [ Web.btn_delete (RemoveDomain domain)
|
|
, Web.btn_ [C.is_small] domain (EnterDomain domain)
|
|
]
|
|
|
|
render_adduser_form =
|
|
HH.form
|
|
[ HE.onSubmit PreventSubmit ]
|
|
[ Web.box_input "login" "User login" "login" (ActionOnAddUserForm <<< ADDUSER_INP_login) addUserForm.login
|
|
, Web.btn_labeled "adminbtn" "Admin" (show addUserForm.admin) (ActionOnAddUserForm ADDUSER_toggle_admin)
|
|
, Web.box_input "email" "User email" "email" (ActionOnAddUserForm <<< ADDUSER_INP_email) addUserForm.email
|
|
, Web.box_password "password" "User password" "password" (ActionOnAddUserForm <<< ADDUSER_INP_pass) addUserForm.pass
|
|
, Web.btn "Send" AddUserAttempt
|
|
]
|
|
|
|
render_searchuser_form =
|
|
HH.form
|
|
[ HE.onSubmit PreventSubmit ]
|
|
[ Web.p """
|
|
Following input accepts any regex.
|
|
This is used to search for a user based on their login, full name or email address.
|
|
"""
|
|
, Web.box_input "regex" "Regex" "regex" (ActionOnSearchUserForm <<< SEARCHUSER_INP_regex) searchUserForm.regex
|
|
--, Web.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin)
|
|
-- (ActionOnSearchUserForm <<< SEARCHUSER_toggle_admin)
|
|
, Web.btn "Send" SearchUserAttempt
|
|
]
|
|
|
|
render_searchdomain_form =
|
|
HH.form
|
|
[ HE.onSubmit PreventSubmit ]
|
|
[ Web.p "Following input accepts any regex to search for a domain."
|
|
, Web.box_input "domain" "Domain owned" "blah.netlib.re."
|
|
(ActionOnSearchDomainForm <<< SEARCHDOMAIN_INP_domain) searchDomainForm.domain
|
|
, Web.btn "Send" SearchDomainAttempt
|
|
]
|
|
|
|
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_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage
|
|
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
|
|
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
|
|
|
|
Finalize -> do
|
|
state <- H.get
|
|
H.raise $ StoreState state
|
|
|
|
ActionOnAddUserForm adduserinp -> do
|
|
{ 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 } }
|
|
|
|
ActionOnSearchUserForm searchuserinp -> do
|
|
case searchuserinp of
|
|
SEARCHUSER_INP_regex v -> H.modify_ _ { searchUserForm { regex = v } }
|
|
|
|
ActionOnSearchDomainForm searchdomaininp -> do
|
|
case searchdomaininp of
|
|
SEARCHDOMAIN_INP_domain v -> H.modify_ _ { searchDomainForm { domain = v } }
|
|
|
|
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
|
|
|
|
ShowUser uid -> do
|
|
H.raise $ Log $ SystemLog $ "Show a user details (uid: " <> show uid <> ")"
|
|
|
|
ShowOrphanDomains -> do
|
|
H.raise $ Log $ SystemLog $ "Get orphan domains"
|
|
H.raise $ GetOrphanDomains
|
|
|
|
RemoveUser 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
|
|
|
|
EnterDomain domain -> do
|
|
H.raise $ Log $ SystemLog $ "show domain " <> domain
|
|
H.raise $ ShowZone domain
|
|
|
|
AddUserAttempt -> do
|
|
{ addUserForm } <- H.get
|
|
let login = addUserForm.login
|
|
email = addUserForm.email
|
|
pass = addUserForm.pass
|
|
|
|
case login, email, pass of
|
|
"", _, _ -> H.raise $ Log $ UnableToSend "Write the user's login."
|
|
_, "", _ -> H.raise $ Log $ UnableToSend "Write the user's email."
|
|
_, _, "" -> 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"
|
|
|
|
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
|
|
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.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.modify_ _ { matching_domains = [] }
|
|
|
|
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
|
handleQuery = case _ of
|
|
|
|
ProvideState maybe_state a -> do
|
|
case maybe_state of
|
|
Nothing -> pure Nothing
|
|
Just s -> do
|
|
H.put s
|
|
pure (Just a)
|
|
|
|
MessageReceived message a -> do
|
|
case message of
|
|
(AuthD.GotUserAdded msg) -> do
|
|
H.raise $ Log $ SuccessLog $ "Added user: " <> show msg.user
|
|
|
|
(AuthD.GotMatchingUsers msg) -> do
|
|
H.raise $ Log $ SuccessLog "Got list of matched users."
|
|
H.modify_ _ { matching_users = msg.users }
|
|
|
|
(AuthD.GotUserDeleted msg) -> do
|
|
H.raise $ Log $ SuccessLog $ "User (uid: " <> show msg.uid <> ") got removed."
|
|
{ matching_users } <- H.get
|
|
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
|
|
|
|
-- Unexpected message.
|
|
_ -> H.raise $ Log $ ErrorLog $ "Authentication server didn't send a valid message."
|
|
pure (Just a)
|
|
|
|
GotOrphanDomainList domains a -> do
|
|
H.modify_ _ { orphan_domains = domains }
|
|
pure (Just a)
|
|
|
|
GotFoundDomains domains a -> do
|
|
H.modify_ _ { matching_domains = domains }
|
|
pure (Just a)
|