Add mail verification.
parent
3f2573831a
commit
f9f79875c0
|
|
@ -45,6 +45,7 @@ import Data.Either (Either(..))
|
|||
import Data.Tuple (Tuple(..))
|
||||
import App.AuthenticationInterface as AI
|
||||
import App.RegistrationInterface as RI
|
||||
import App.MailValidationInterface as MVI
|
||||
import App.Log as AppLog
|
||||
import App.WS as WS
|
||||
import App.AuthenticationDaemonAdminInterface as AAI
|
||||
|
|
@ -68,7 +69,7 @@ import App.LogMessage (LogMessage(..))
|
|||
-- | List all pages the application has:
|
||||
-- | Home, Login, Domain list, Zone, `authd` administration.
|
||||
-- | This list will grows in a near future.
|
||||
data Page = Home | Authentication | Registration | DomainList | Zone String | AuthAdmin
|
||||
data Page = Home | Authentication | Registration | MailValidation | DomainList | Zone String | AuthAdmin
|
||||
|
||||
type Token = String
|
||||
type Login = String
|
||||
|
|
@ -79,9 +80,12 @@ data Action
|
|||
-- | Handle events from `AuthenticationInterface`.
|
||||
= AuthenticationInterfaceEvent AI.Output
|
||||
|
||||
-- | Handle events from `AuthenticationComponent`.
|
||||
-- | Handle events from `RegistrationInterface`.
|
||||
| RegistrationInterfaceEvent RI.Output
|
||||
|
||||
-- | Handle events from `MailValidationInterface`.
|
||||
| MailValidationInterfaceEvent MVI.Output
|
||||
|
||||
-- | Handle events from `AuthenticationDaemonAdminComponent`.
|
||||
| AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd.
|
||||
|
||||
|
|
@ -141,8 +145,8 @@ type State = { token :: Maybe String
|
|||
}
|
||||
|
||||
-- | The list of child components: log, `WS` twice (once for each ws connection),
|
||||
-- | then all the pages (AuthenticationInterface, RegistrationInterface, HomeInterface, DomainListInterface,
|
||||
-- | ZoneInterface and AuthenticationDaemonAdminInterface).
|
||||
-- | then all the pages (AuthenticationInterface, RegistrationInterface, MailValidationInterface,
|
||||
-- | HomeInterface, DomainListInterface, ZoneInterface and AuthenticationDaemonAdminInterface).
|
||||
type ChildSlots =
|
||||
( log :: AppLog.Slot Unit
|
||||
, ho :: HomeInterface.Slot Unit
|
||||
|
|
@ -150,6 +154,7 @@ type ChildSlots =
|
|||
, ws_dns :: WS.Slot Unit
|
||||
, ai :: AI.Slot Unit
|
||||
, ri :: RI.Slot Unit
|
||||
, mvi :: MVI.Slot Unit
|
||||
, aai :: AAI.Slot Unit
|
||||
, dli :: DomainListInterface.Slot Unit
|
||||
, zi :: ZoneInterface.Slot Unit
|
||||
|
|
@ -161,6 +166,7 @@ _ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd`
|
|||
_ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd`
|
||||
_ai = Proxy :: Proxy "ai" -- Authentication Interface
|
||||
_ri = Proxy :: Proxy "ri" -- Registration Interface
|
||||
_mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface
|
||||
_aai = Proxy :: Proxy "aai" -- Authd Administration Interface
|
||||
_dli = Proxy :: Proxy "dli" -- Domain List
|
||||
_zi = Proxy :: Proxy "zi" -- Zone Interface
|
||||
|
|
@ -190,6 +196,7 @@ render state
|
|||
Home -> render_home
|
||||
Authentication -> render_auth_form
|
||||
Registration -> render_registration
|
||||
MailValidation -> render_mail_validation
|
||||
DomainList -> render_domainlist_interface
|
||||
Zone domain -> render_zone domain
|
||||
AuthAdmin -> render_authd_admin_interface
|
||||
|
|
@ -207,6 +214,8 @@ render state
|
|||
render_auth_form = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent
|
||||
render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent
|
||||
render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_mail_validation = HH.slot _mvi unit MVI.component unit MailValidationInterfaceEvent
|
||||
render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent
|
||||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
|
|
@ -226,6 +235,7 @@ render state
|
|||
(Routing AuthAdmin)
|
||||
(Routing Authentication)
|
||||
(Routing Registration)
|
||||
(Routing MailValidation)
|
||||
Disconnection
|
||||
|
||||
render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
|
|
@ -251,6 +261,7 @@ handleAction = case _ of
|
|||
Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
|
||||
Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
|
||||
Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage
|
||||
MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" sessionstorage
|
||||
DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage
|
||||
Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage
|
||||
H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
|
||||
|
|
@ -284,6 +295,10 @@ handleAction = case _ of
|
|||
RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
RI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
MailValidationInterfaceEvent ev -> case ev of
|
||||
MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
MVI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
AuthenticationDaemonAdminComponentEvent ev -> case ev of
|
||||
AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
AAI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,197 @@
|
|||
-- | `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.MailValidationInterface 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 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.LogMessage
|
||||
import App.Messages.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
|
||||
= ConnectionIsDown a
|
||||
| ConnectionIsUp 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
|
||||
, wsUp :: Boolean
|
||||
}
|
||||
|
||||
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
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ mailValidationForm: { login: "", token: "" }
|
||||
, errors: []
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, mailValidationForm }
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> 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 ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_register_form = HH.form
|
||||
[ HE.onSubmit ValidateInputs ]
|
||||
[ Bulma.box_input "loginValidation" "Login" "login" -- title, placeholder
|
||||
(HandleValidationInput <<< VALIDATION_INP_login) -- action
|
||||
mailValidationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "tokenValidation" "Token" "token" -- title, placeholder
|
||||
(HandleValidationInput <<< VALIDATION_INP_token) -- action
|
||||
mailValidationForm.token -- value
|
||||
should_be_disabled -- condition
|
||||
, HH.div_
|
||||
[ 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
|
||||
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 $ SimpleLog $ "[😇] Trying to register (login: " <> 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 <> ")"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
|
|
@ -60,11 +60,11 @@ codecRegister
|
|||
, email: CAR.optional Email.codec })
|
||||
|
||||
{- 2 -}
|
||||
type ValidateUser = { user :: UserID, activation_key :: String }
|
||||
type ValidateUser = { user :: String, activation_key :: String }
|
||||
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
||||
codecValidateUser
|
||||
= CA.object "ValidateUser" (CAR.record
|
||||
{ user: CA.int
|
||||
{ user: CA.string
|
||||
, activation_key: CA.string })
|
||||
|
||||
{- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID,
|
||||
|
|
|
|||
|
|
@ -20,10 +20,10 @@ import Bulma as Bulma
|
|||
-- | `actionDisconnection` (the action to disconnect the user)
|
||||
-- |
|
||||
-- | TODO: make the "burger" component actually useful. For now, it's empty.
|
||||
netlibre_navbar :: forall w i. Boolean -> Boolean -> i -> i -> i -> i -> i -> i -> HH.HTML w i
|
||||
netlibre_navbar :: forall w i. Boolean -> Boolean -> i -> i -> i -> i -> i -> i -> i -> HH.HTML w i
|
||||
netlibre_navbar authenticated admin
|
||||
actionHome actionDomainList actionAuthdAdmin
|
||||
actionLogin actionRegistration actionDisconnection =
|
||||
actionLogin actionRegistration actionMailValidation actionDisconnection =
|
||||
main_nav
|
||||
[ nav_brand [ logo, burger_menu ]
|
||||
, nav_menu
|
||||
|
|
@ -45,6 +45,7 @@ netlibre_navbar authenticated admin
|
|||
[ HH.div [HP.classes C.buttons] $ case authenticated of
|
||||
false -> [ nav_button C.is_info "Login" actionLogin
|
||||
, nav_button_strong "Register" actionRegistration
|
||||
, nav_button C.is_info "Mail verification" actionMailValidation
|
||||
, nav_button_code
|
||||
]
|
||||
_ -> [ nav_button_disconnection, nav_button_code ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,44 @@
|
|||
module App.Validation.Token where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Either (Either(..))
|
||||
import Data.String.CodeUnits as CU
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.RFC5234 (vchar)
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
|
||||
data TokenParsingError
|
||||
= CannotParse
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error TokenParsingError)
|
||||
|
||||
-- | TODO: this number should be exactly the size of the provided token.
|
||||
min_token_size :: Int
|
||||
min_token_size = 20
|
||||
max_token_size :: Int
|
||||
max_token_size = 60
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
token_parser :: G.Parser TokenParsingError String
|
||||
token_parser = do
|
||||
l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
|
||||
_ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
|
||||
pos <- G.current_position
|
||||
if pos < min_token_size || pos > max_token_size
|
||||
then G.Parser \i -> G.failureError i.position (Just $ Size min_token_size max_token_size pos)
|
||||
else pure $ CU.fromCharArray l
|
||||
|
||||
token :: String -> Either (Array Error) String
|
||||
token s = toEither $ parse token_parser s ParsingError
|
||||
Loading…
Reference in New Issue