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

-- | `App.Page.Migration` is the interface for migrated users before they validate their email address.
-- | To complete their migration, they need to provide an email address that will be validated with a token.
-- | This token will be required before the user can do anything else on the website.
-- |
-- | Exchanges between the webapp and authd:
-- |
-- | ```
-- | User gives a valid email address -> authd
-- | (authd accepts the email address and sends an email)
-- |
-- | authd -> email pending
-- | (we switch tab to "mail validation tab")
-- |
-- | User gives the received token -> authd
-- | (authd accepts the token and validates the email address)
-- |
-- | authd -> EmailChanged
-- | (webapp switches to domain list)
-- | ```
module App.Page.Migration where

import Prelude (Unit, between, bind, discard, map, pure, ($), (<>))

import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String as S
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 as Event
import Web.Event.Event (Event)

-- import Data.Generic.Rep (class Generic)
-- import Data.Show.Generic (genericShow)

import Bulma as Bulma
import Scroll (scrollToTop)

import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
import App.DisplayErrors (show_error_email)
import App.Validation.Email as E

data Output = MessageToSend ArrayBuffer | Log LogMessage

-- | Once the new email address has been accepted by `authd` as "pending",
-- | this page automatically switches to a second tab.
data Query a = WaitingForToken a

type Slot = H.Slot Query Output

type Input = Unit

-- | Both value types to validate before sending the appropriate messages to `authd`.
data Subject = EmailAddress | Token

--derive instance eqSubject :: Eq Subject
--derive instance genericSubject :: Generic Subject _
--instance showSubject :: Show Subject where
--  show = genericShow

data Action
  -- | Copy user input in the different HTML inputs.
  = UserInput Subject String

  -- | Verify either the format of the new email address or the token then send the request.
  | Verify Subject Event

  -- | Send either the new email address or the token to `authd`.
  | ContactAuthd Subject

  -- | Change the current tab.
  -- | ChangeTab Subject

-- | The possible errors from the email format.
-- | TODO: check the token.
data Error = Email (Array E.Error)

-- | State is composed of the new email address, the token and the possible errors.
type State
  = { email :: String
    , token :: String
    , errors :: Array Error
    -- , current_tab :: Subject
    }

initialState :: Input -> State
initialState _
  = { email: ""
    , token: ""
    , errors: []
    -- , current_tab: EmailAddress
    }

component :: forall m. MonadAff m => H.Component Query Input Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval
        { handleAction = handleAction
        , handleQuery  = handleQuery
        }
    }

handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
  -- TODO
  WaitingForToken a -> pure (Just a)

render :: forall m. State -> H.ComponentHTML Action () m
render state
  = Bulma.section_small [Bulma.columns_
      [ b email_form
      , b token_form
      ]]

  where
    b e = Bulma.column_ [ Bulma.box e ]

    email_form
      = [ Bulma.h3 "New Email address"
        -- TODO: put some text here
        , HH.form
            [ HE.onSubmit (Verify EmailAddress) ]
            [ email_input, email_error, Bulma.btn_validation ]
        ]

    email_input = Bulma.email_input "Email" state.email (UserInput EmailAddress)

    email_error
      = case between 0 5 (S.length state.email), E.email state.email of
          true, _        -> HH.text ""
          _, Left errors -> Bulma.error_box "newAddress" "Email error" (show_error $ Email errors)
          _, Right _     -> HH.text ""

    token_form
      = [ Bulma.h3 "Email validation token"
        -- TODO: put some text here
        , HH.form
            [ HE.onSubmit (Verify Token) ]
            [ token_input {-, token_error -}, Bulma.btn_validation ]
        ]

    token_input = Bulma.token_input "Token" state.token (UserInput Token)

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  UserInput subject value -> do
    case subject of
      EmailAddress -> H.modify_ _ { email = value }
      Token        -> H.modify_ _ { token = value }

  -- Validate either the email address or the token then send the related requests to `authd`.
  Verify subject ev -> do
    H.liftEffect $ Event.preventDefault ev

    state <- H.get
    case subject of
      EmailAddress -> do
        case state.email of
          "" -> do
            H.raise $ Log $ UnableToSend "Please, write your new email address."
            H.liftEffect scrollToTop
          _ -> do
            case E.email state.email of
              Left errors  -> H.raise $ Log $ UnableToSend $ show_error $ Email errors
              Right _      -> handleAction $ ContactAuthd EmailAddress

      Token -> do
        case state.token of
          "" -> do
            H.raise $ Log $ UnableToSend "Please, write your validation token."
            H.liftEffect scrollToTop
          _ -> handleAction $ ContactAuthd Token

  ContactAuthd subject -> do
    state <- H.get
    case subject of
      EmailAddress -> do
        message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddress { email: state.email }
        H.raise $ MessageToSend message
        H.raise $ Log $ SystemLog $ "Sending a new email address."
      Token -> do
        message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddressToken { token: state.token }
        H.raise $ MessageToSend message
        H.raise $ Log $ SystemLog $ "Sending a validation token."

show_error :: Error -> String
show_error = case _ of
  Email    arr -> "Error with the Email: "    <> (A.fold $ map show_error_email arr)