karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add mail verification.

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-11 16:24:42 +01:00
parent 3f2573831a
commit f9f79875c0
5 changed files with 265 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/App/Container.purs
View File

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

197
src/App/MailValidationInterface.purs Normal file
View File

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

4
src/App/Messages/AuthenticationDaemon.purs
View File

@ -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,

5
src/App/Nav.purs
View File

@ -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 ]

44
src/App/Validation/Token.purs Normal file
View File

@ -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