dnsmanager-webclient/src/App/Page/Administration.purs

{- 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)