{- Administration interface. Enables to: - add, remove, search users - TODO: validate users - TODO: change user password - TODO: show user details (list of owned 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 Bulma as Bulma 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.IPC as IPC import App.Type.Email as Email -- import App.Message.DNSManagerDaemon as DNSManager import App.Message.AuthenticationDaemon as AuthD data Output = MessageToSend ArrayBuffer | Log LogMessage | AskState | StoreState State | DeleteUserAccount Int | GetOrphanDomains --| DeleteDomain String --| RequestDomain String data Query a = MessageReceived AuthD.AnswerMessage a | GotOrphanDomainList (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 | SEARCHUSER_INP_regex String --| SEARCHUSER_INP_domain String data Action = HandleAddUserInput AddUserInput | AddUserAttempt | SearchUserAttempt | PreventSubmit Event | ShowUser Int | RemoveUser Int -- Domains. | ShowOrphanDomains | RemoveDomain String | ShowDomain String -- | 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 | Search | Add | OrphanDomains derive instance eqTab :: Eq Tab type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String } type StateSearchUserForm = { regex :: String {-, admin :: Boolean, domain :: String -} } type State = { addUserForm :: StateAddUserForm , searchUserForm :: StateSearchUserForm , current_tab :: Tab , matching_users :: Array UserPublic , 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, domain: "" -} } , matching_users: [] , orphan_domains: [] , current_tab: Home } render :: forall m. State -> H.ComponentHTML Action () m render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domains } = Bulma.section_small [ fancy_tab_bar , case current_tab of Home -> Bulma.h3 "Select an action" Search -> Bulma.columns_ [ Bulma.column (C.is 3) [Bulma.article (Bulma.p "Search users") render_searchuser_form] , Bulma.column_ [ Bulma.h3 "Result", show_found_users ] ] Add -> Bulma.columns_ [ Bulma.column (C.is 5) [Bulma.article (Bulma.p "Add a new user") render_adduser_form] ] OrphanDomains -> HH.div_ [ Bulma.btn_ (C.is_small) "Get orphan domains" ShowOrphanDomains , show_orphan_domains ] ] where fancy_tab_bar = Bulma.fancy_tabs [ Bulma.tab_entry (is_tab_active Home) "Home" (ChangeTab Home) , Bulma.tab_entry (is_tab_active Search) "Search" (ChangeTab Search) , Bulma.tab_entry (is_tab_active Add) "Add" (ChangeTab Add) , Bulma.tab_entry (is_tab_active OrphanDomains) "OrphanDomains" (ChangeTab OrphanDomains) ] is_tab_active tab = current_tab == tab show_found_users = Bulma.box [ HH.ul_ $ map user_card matching_users ] user_card user = HH.li_ [ Bulma.btn_delete (RemoveUser user.uid) , Bulma.btn_ (C.is_small) user.login (ShowUser user.uid) ] show_orphan_domains = Bulma.box [ HH.ul_ $ map domain_entry orphan_domains ] domain_entry domain = HH.li_ [ Bulma.btn_delete (RemoveDomain domain) , Bulma.btn_ (C.is_small) domain (ShowDomain domain) ] up x = HandleAddUserInput <<< x render_adduser_form = HH.form [ HE.onSubmit PreventSubmit ] [ Bulma.box_input "login" "User login" "login" (up ADDUSER_INP_login) addUserForm.login , Bulma.btn_labeled "adminbtn" "Admin" (show addUserForm.admin) (HandleAddUserInput ADDUSER_toggle_admin) , Bulma.box_input "email" "User email" "email" (up ADDUSER_INP_email) addUserForm.email , Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass , Bulma.btn "Send" AddUserAttempt ] render_searchuser_form = HH.form [ HE.onSubmit PreventSubmit ] [ Bulma.p """ Following input accepts any regex. This is used to search for a user based on their login, full name or email address. """ , Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex --, 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.domain , Bulma.btn "Send" SearchUserAttempt ] 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 "Search" -> handleAction $ ChangeTab Search "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 HandleAddUserInput 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 } } SEARCHUSER_INP_regex v -> H.modify_ _ { searchUserForm { regex = 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 ShowDomain domain -> do H.raise $ Log $ SystemLog $ "TODO: show domain " <> domain -- H.raise $ RequestDomain 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 $ MessageToSend 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 Search -> H.liftEffect $ Storage.setItem "current-ada-tab" "Search" 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 -- 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 = [] } 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 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)