343 lines
13 KiB
Plaintext
343 lines
13 KiB
Plaintext
-- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
|
|
-- | TODO: token validation.
|
|
module App.Page.Authentication where
|
|
|
|
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (>), (==), map, show)
|
|
|
|
import Data.Array as A
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Maybe (Maybe(..), maybe)
|
|
import Data.Either (Either(..))
|
|
import Data.Tuple (Tuple(..))
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Events as HE
|
|
import Halogen.HTML.Properties as HP
|
|
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.Email as E
|
|
import App.Validation.Password as P
|
|
|
|
type Login = String
|
|
type Email = String
|
|
type Password = String
|
|
type PasswordRecoveryToken = String
|
|
|
|
data Error
|
|
= Login (Array L.Error)
|
|
| Email (Array E.Error)
|
|
| Password (Array P.Error)
|
|
|
|
-- | The component can inform the parent (`App.Container`) that the authentication is complete,
|
|
-- | and share both the uid and token. The token is useful to authenticate the user to the
|
|
-- | dnsmanager daemon.
|
|
-- |
|
|
-- | Also, the component can send a message to a websocket and log messages.
|
|
-- |
|
|
-- | TODO: authentication is performed in `App.Container`.
|
|
data Output
|
|
= MessageToSend ArrayBuffer
|
|
| AuthenticateToAuthd (Tuple Login Password)
|
|
| Log LogMessage
|
|
| PasswordRecovery Login PasswordRecoveryToken Password
|
|
| AskPasswordRecovery (Either Email Login)
|
|
|
|
-- | The component's parent provides received messages.
|
|
-- |
|
|
-- | Also, the component is informed when the connection went up or down.
|
|
data Query a
|
|
= MessageReceived AuthD.AnswerMessage a
|
|
| ConnectionIsDown a
|
|
| ConnectionIsUp a
|
|
|
|
type Slot = H.Slot Query Output
|
|
|
|
type Input = Unit
|
|
|
|
data AuthenticationInput
|
|
= AUTH_INP_login String
|
|
| AUTH_INP_pass String
|
|
|
|
data PasswordRecoveryInput
|
|
= PASSR_INP_login String
|
|
| PASSR_INP_email String
|
|
|
|
data NewPasswordInput
|
|
= NEWPASS_INP_login String
|
|
| NEWPASS_INP_token String
|
|
| NEWPASS_INP_password String
|
|
| NEWPASS_INP_confirmation String
|
|
|
|
data Action
|
|
= HandleAuthenticationInput AuthenticationInput
|
|
| HandlePasswordRecovery PasswordRecoveryInput
|
|
| HandleNewPassword NewPasswordInput
|
|
--
|
|
| AuthenticationAttempt Event
|
|
| PasswordRecoveryAttempt Event
|
|
| NewPasswordAttempt Event
|
|
|
|
type StateAuthenticationForm = { login :: String, pass :: String }
|
|
type StatePasswordRecoveryForm = { login :: String, email :: String }
|
|
type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String }
|
|
|
|
type State =
|
|
{ authenticationForm :: StateAuthenticationForm
|
|
, passwordRecoveryForm :: StatePasswordRecoveryForm
|
|
, newPasswordForm :: StateNewPasswordForm
|
|
, errors :: Array Error
|
|
, wsUp :: Boolean
|
|
}
|
|
|
|
initialState :: Input -> State
|
|
initialState _ =
|
|
{ authenticationForm: { login: "", pass: "" }
|
|
, passwordRecoveryForm: { login: "", email: "" }
|
|
, newPasswordForm: { login: "", token: "", password: "", confirmation: "" }
|
|
, wsUp: true
|
|
, errors: []
|
|
}
|
|
|
|
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
|
|
}
|
|
}
|
|
|
|
render :: forall m. State -> H.ComponentHTML Action () m
|
|
render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
|
|
Bulma.section_small
|
|
[ case wsUp of
|
|
false -> Bulma.p "You are disconnected."
|
|
true ->
|
|
if A.length errors > 0
|
|
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ]
|
|
, Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
|
]
|
|
else Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
|
]
|
|
|
|
where
|
|
b e = Bulma.column_ [ Bulma.box e ]
|
|
|
|
show_error :: Error -> String
|
|
show_error = case _ of
|
|
Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr)
|
|
Email arr -> "Error with the Email: " <> (A.fold $ map show_error_email arr)
|
|
Password arr -> "Error with the Password: " <> (A.fold $ map show_error_password 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_email :: E.Error -> String
|
|
show_error_email = case _ of
|
|
E.ParsingError {error, position} ->
|
|
"position " <> show position <> " " <> maybe "" string_error_email error
|
|
|
|
string_error_email :: E.EmailParsingError -> String
|
|
string_error_email = case _ of
|
|
E.CannotParse -> "cannot parse the email"
|
|
E.CannotEntirelyParse -> "cannot entirely parse the email"
|
|
E.Size min max n -> "email size should be between "
|
|
<> show min <> " and " <> show max
|
|
<> " (currently: " <> show n <> ")"
|
|
|
|
show_error_password :: P.Error -> String
|
|
show_error_password = case _ of
|
|
P.ParsingError {error, position} ->
|
|
"position " <> show position <> " " <> maybe "" string_error_password error
|
|
|
|
string_error_password :: P.PasswordParsingError -> String
|
|
string_error_password = case _ of
|
|
P.CannotParse -> "cannot parse the password"
|
|
P.CannotEntirelyParse -> "cannot entirely parse the password"
|
|
P.Size min max n -> "password size should be between "
|
|
<> show min <> " and " <> show max
|
|
<> " (currently: " <> show n <> ")"
|
|
|
|
auth_form = [ Bulma.h3 "Authentication" , render_auth_form ]
|
|
passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
|
|
newpass_form = [ Bulma.h3 "New password", render_new_password_form ]
|
|
|
|
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
|
|
|
render_auth_form = HH.form
|
|
[ HE.onSubmit AuthenticationAttempt ]
|
|
[ Bulma.box_input "loginLOGIN" "Login" "login" -- title, placeholder
|
|
(HandleAuthenticationInput <<< AUTH_INP_login) -- action
|
|
authenticationForm.login -- value
|
|
should_be_disabled -- condition
|
|
, Bulma.box_password "passwordLOGIN" "Password" "password" -- title, placeholder
|
|
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action
|
|
authenticationForm.pass -- value
|
|
should_be_disabled -- condition
|
|
, HH.button
|
|
[ HP.style "padding: 0.5rem 1.25rem;"
|
|
, HP.type_ HP.ButtonSubmit
|
|
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
|
]
|
|
[ HH.text "Send Message to Server" ]
|
|
]
|
|
|
|
render_password_recovery_form = HH.form
|
|
[ HE.onSubmit PasswordRecoveryAttempt ]
|
|
[ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder
|
|
(HandlePasswordRecovery <<< PASSR_INP_login) -- action
|
|
passwordRecoveryForm.login -- value
|
|
should_be_disabled -- condition
|
|
, Bulma.box_input "emailPASSR" "Email" "email" -- title, placeholder
|
|
(HandlePasswordRecovery <<< PASSR_INP_email) -- action
|
|
passwordRecoveryForm.email -- value
|
|
should_be_disabled -- condition
|
|
, HH.button
|
|
[ HP.style "padding: 0.5rem 1.25rem;"
|
|
, HP.type_ HP.ButtonSubmit
|
|
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
|
]
|
|
[ HH.text "Send Message to Server" ]
|
|
]
|
|
|
|
render_new_password_form = HH.form
|
|
[ HE.onSubmit NewPasswordAttempt ]
|
|
[ Bulma.box_input "loginNEWPASS" "Login" "login"
|
|
(HandleNewPassword <<< NEWPASS_INP_login)
|
|
newPasswordForm.login
|
|
should_be_disabled
|
|
, Bulma.box_input "tokenNEWPASS" "Token" "token"
|
|
(HandleNewPassword <<< NEWPASS_INP_token)
|
|
newPasswordForm.token
|
|
should_be_disabled
|
|
, Bulma.box_password "passwordNEWPASS" "Password" "password"
|
|
(HandleNewPassword <<< NEWPASS_INP_password)
|
|
newPasswordForm.password
|
|
should_be_disabled
|
|
, Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation"
|
|
(HandleNewPassword <<< NEWPASS_INP_confirmation)
|
|
newPasswordForm.confirmation
|
|
should_be_disabled
|
|
, HH.button
|
|
[ HP.style "padding: 0.5rem 1.25rem;"
|
|
, HP.type_ HP.ButtonSubmit
|
|
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
|
]
|
|
[ HH.text "Send Message to Server" ]
|
|
]
|
|
|
|
|
|
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
|
handleAction = case _ of
|
|
HandleAuthenticationInput authinp -> do
|
|
case authinp of
|
|
AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
|
|
AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = v } }
|
|
|
|
HandlePasswordRecovery passrecovinp -> do
|
|
case passrecovinp of
|
|
PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } }
|
|
PASSR_INP_email v -> H.modify_ _ { passwordRecoveryForm { email = v } }
|
|
|
|
HandleNewPassword newpassinp -> do
|
|
case newpassinp of
|
|
NEWPASS_INP_login v -> H.modify_ _ { newPasswordForm { login = v } }
|
|
NEWPASS_INP_token v -> H.modify_ _ { newPasswordForm { token = v } }
|
|
NEWPASS_INP_password v -> H.modify_ _ { newPasswordForm { password = v } }
|
|
NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } }
|
|
|
|
AuthenticationAttempt ev -> do
|
|
H.liftEffect $ Event.preventDefault ev
|
|
|
|
{ authenticationForm } <- H.get
|
|
let { login, pass } = authenticationForm
|
|
|
|
case login, pass of
|
|
"" , _ ->
|
|
H.raise $ Log $ UnableToSend "Write your login!"
|
|
|
|
_ , "" ->
|
|
H.raise $ Log $ UnableToSend "Write your password!"
|
|
|
|
_, _ -> do
|
|
case L.login login, P.password pass of
|
|
Left errors, _ -> H.modify_ _ { errors = [ Login errors ] }
|
|
_, Left errors -> H.modify_ _ { errors = [ Password errors ] }
|
|
_, _ -> do H.modify_ _ { errors = [] }
|
|
H.raise $ AuthenticateToAuthd (Tuple login pass)
|
|
H.raise $ Log $ SystemLog $ "authenticate (login: " <> login <> ")"
|
|
|
|
PasswordRecoveryAttempt ev -> do
|
|
H.liftEffect $ Event.preventDefault ev
|
|
|
|
{ passwordRecoveryForm } <- H.get
|
|
let login = passwordRecoveryForm.login
|
|
email = passwordRecoveryForm.email
|
|
|
|
case login, email of
|
|
"", "" -> H.raise $ Log $ UnableToSend "Write your login or your email!"
|
|
_, _ -> do
|
|
H.raise $ Log $ SystemLog "password recovery"
|
|
if email == ""
|
|
then case L.login login of
|
|
Left errors -> H.modify_ _ { errors = [ Login errors ] }
|
|
_ -> do H.modify_ _ { errors = [] }
|
|
H.raise $ AskPasswordRecovery (Right login)
|
|
else case E.email email of
|
|
Left errors -> H.modify_ _ { errors = [ Email errors ] }
|
|
_ -> do H.modify_ _ { errors = [] }
|
|
H.raise $ AskPasswordRecovery (Left email)
|
|
|
|
-- TODO: verify the login?
|
|
NewPasswordAttempt ev -> do
|
|
H.liftEffect $ Event.preventDefault ev
|
|
|
|
{ newPasswordForm } <- H.get
|
|
let { login, token, password, confirmation} = newPasswordForm
|
|
|
|
if A.any (_ == "") [ login, token, password, confirmation ]
|
|
then H.raise $ Log $ ErrorLog "All entries are required!"
|
|
else if password == confirmation
|
|
then case L.login login of
|
|
Left errors -> H.modify_ _ { errors = [ Login errors ] }
|
|
Right _ -> do H.modify_ _ { errors = [] }
|
|
H.raise $ PasswordRecovery login token password
|
|
else H.raise $ Log $ UnableToSend "Confirmation differs from password!"
|
|
|
|
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
|
handleQuery = case _ of
|
|
-- For now, no message actually needs to be handled here.
|
|
-- Error messages are simply logged (see the code in the Container component).
|
|
MessageReceived message _ -> do
|
|
case message of
|
|
_ -> do
|
|
H.raise $ Log $ ErrorLog $ "Message not handled in AuthenticationInterface."
|
|
pure Nothing
|
|
|
|
ConnectionIsDown a -> do
|
|
H.modify_ _ { wsUp = false }
|
|
pure (Just a)
|
|
|
|
ConnectionIsUp a -> do
|
|
H.modify_ _ { wsUp = true }
|
|
pure (Just a)
|