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

-- | `App.MailValidationInterface` is a simple interface for mail verification.
-- | A token is sent at registration at the provided email address.
-- | This token has to be used to validate the email address.
module App.Page.MailValidation where

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

import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (maybe)
import Data.Either (Either(..))
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 Bulma as Bulma

import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD

import App.Validation.Login as L
import App.Validation.Token as T

data Output
  = MessageToSend ArrayBuffer
  | Log LogMessage

-- | The component is informed when the connection went up or down.
data Query a = DoNothing a

type Slot = H.Slot Query Output

type Input = Unit

data RegisterInput
  = VALIDATION_INP_login String
  | VALIDATION_INP_token String

data Action
  -- | Simply get the inputs from the form.
  = HandleValidationInput RegisterInput
  -- | Validate inputs (login, email, password) then send the request
  -- | (via `SendMailValidationToken`) or log errors.
  | ValidateInputs Event
  -- | Send the registration request to `dnsmanagerd`.
  -- | This action is automatically called from `ValidateInputs`.
  | SendMailValidationToken

-- | The possible errors come from either the login or token input.
data Error
  = Login (Array L.Error)
  | Token (Array T.Error)

-- | The whole mail validation form is composed of two strings: the login and the token.
type MailValidationForm = { login :: String, token :: String }

-- | State is composed of the registration form, the errors and an indication whether
-- | the websocket connection with `authd` is up or not.
type State =
  { mailValidationForm :: MailValidationForm
  , errors             :: Array Error
  }

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

initialState :: Input -> State
initialState _ =
  { mailValidationForm: { login: "", token: "" }
  , errors: []
  }

render :: forall m. State -> H.ComponentHTML Action () m
render { mailValidationForm }
  = Bulma.section_small [ Bulma.columns_ [ b mail_validation_form ] ]

  where
    b e = Bulma.column_ [ Bulma.box e ]
    mail_validation_form = [ Bulma.h3 "Verify your account", render_register_form ]

    render_register_form = HH.form
      [ HE.onSubmit ValidateInputs ]
      [ Bulma.box_input "loginValidation" "Login" "login"   -- title, placeholder
          (HandleValidationInput <<< VALIDATION_INP_login)  -- action
          mailValidationForm.login                          -- value
      , Bulma.box_input "tokenValidation" "Token" "token"   -- title, placeholder
          (HandleValidationInput <<< VALIDATION_INP_token)  -- action
          mailValidationForm.token                          -- value
      , Bulma.btn_validation
      ]

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  HandleValidationInput reginp -> do
    case reginp of
      VALIDATION_INP_login v -> H.modify_ _ { mailValidationForm { login = v } }
      VALIDATION_INP_token v -> H.modify_ _ { mailValidationForm { token = v } }

  -- Validate inputs (login, token) then send the request
  -- (via SendMailValidationToken) or log errors.
  ValidateInputs ev -> do
    H.liftEffect $ Event.preventDefault ev

    { mailValidationForm } <- H.get
    let { login, token } = mailValidationForm

    case login, token of
      "", _ ->
        H.raise $ Log $ UnableToSend "Write your login!"

      _, "" ->
        H.raise $ Log $ UnableToSend "Write your token!"

      _, _ -> do
        case L.login login, T.token token of
          Left errors, _   -> H.raise $ Log $ UnableToSend $ show_error $ Login errors
          _, Left errors   -> H.raise $ Log $ UnableToSend $ show_error $ Token errors
          Right _, Right _ -> handleAction $ SendMailValidationToken

  SendMailValidationToken -> do
    { mailValidationForm } <- H.get
    let { login, token } = mailValidationForm
    message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user: login, activation_key: token }
    H.raise $ MessageToSend message
    H.raise $ Log $ SystemLog $ "Trying to validate email address of user \"" <> login <> "\""

show_error :: Error -> String
show_error = case _ of
  Login    arr -> "Error with the Login: "    <> (A.fold $ map show_error_login arr)
  Token arr -> "Error with the Token: " <> (A.fold $ map show_error_token arr)

show_error_login :: L.Error -> String
show_error_login = case _ of
  L.ParsingError {error, position} ->
    "position " <> show position <> " " <> maybe "" string_error_login error

string_error_login :: L.LoginParsingError -> String
string_error_login = case _ of
  L.CannotParse         -> "cannot parse the login"
  L.CannotEntirelyParse -> "cannot entirely parse the login"
  L.Size min max n      -> "login size should be between "
                           <> show min <> " and " <> show max
                           <> " (currently: " <> show n <> ")"

show_error_token :: T.Error -> String
show_error_token = case _ of
  T.ParsingError {error, position} ->
    "position " <> show position <> " " <> maybe "" string_error_token error

string_error_token :: T.TokenParsingError -> String
string_error_token = case _ of
  T.CannotParse         -> "cannot parse the token"
  T.CannotEntirelyParse -> "cannot entirely parse the token"
  T.Size min max n      -> "token size should be between "
                           <> show min <> " and " <> show max
                           <> " (currently: " <> show n <> ")"