Change a few names, split authentication and registration.
This commit is contained in:
parent
41b4511a94
commit
329d84e6f9
@ -1,11 +1,11 @@
|
||||
-- | `App.AuthenticationForm` is both the authentication and registration interface.
|
||||
module App.AuthenticationForm where
|
||||
-- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
|
||||
-- | TODO: token validation.
|
||||
module App.AuthenticationInterface where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), show)
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>))
|
||||
|
||||
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
@ -50,31 +50,22 @@ data AuthenticationInput
|
||||
= AUTH_INP_login String
|
||||
| AUTH_INP_pass String
|
||||
|
||||
data RegisterInput
|
||||
= REG_INP_login String
|
||||
| REG_INP_email String
|
||||
| REG_INP_pass String
|
||||
|
||||
data PasswordRecoveryInput
|
||||
= PASSR_INP_login String
|
||||
| PASSR_INP_email String
|
||||
|
||||
data Action
|
||||
= HandleAuthenticationInput AuthenticationInput
|
||||
| HandleRegisterInput RegisterInput
|
||||
| HandlePasswordRecovery PasswordRecoveryInput
|
||||
--
|
||||
| AuthenticationAttempt Event
|
||||
| RegisterAttempt Event
|
||||
| PasswordRecoveryAttempt Event
|
||||
|
||||
type StateAuthenticationForm = { login :: String, pass :: String }
|
||||
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
|
||||
type StatePasswordRecoveryForm = { login :: String, email :: String }
|
||||
|
||||
type State =
|
||||
{ authenticationForm :: StateAuthenticationForm
|
||||
, registrationForm :: StateRegistrationForm
|
||||
, passwordRecoveryForm :: StatePasswordRecoveryForm
|
||||
, wsUp :: Boolean
|
||||
}
|
||||
@ -93,25 +84,23 @@ component =
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ authenticationForm: { login: "", pass: "" }
|
||||
, registrationForm: { login: "", email: "", pass: "" }
|
||||
, passwordRecoveryForm: { login: "", email: "" }
|
||||
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, authenticationForm, registrationForm, passwordRecoveryForm}
|
||||
render { wsUp, authenticationForm, passwordRecoveryForm}
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> Bulma.columns_ [ b auth_form, b register_form, b passrecovery_form ]
|
||||
true -> Bulma.columns_ [ b auth_form, b passrecovery_form ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
|
||||
auth_form = [ Bulma.h3 "Authentication" , render_auth_form ]
|
||||
register_form = [ Bulma.h3 "Register!" , render_register_form ]
|
||||
passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
@ -134,30 +123,6 @@ render { wsUp, authenticationForm, registrationForm, passwordRecoveryForm}
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
|
||||
render_register_form = HH.form
|
||||
[ HE.onSubmit RegisterAttempt ]
|
||||
[ Bulma.box_input "loginREGISTER" "Login" "login" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_login) -- action
|
||||
registrationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "emailREGISTER" "Email" "email@example.com" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_email) -- action
|
||||
registrationForm.email -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_password "passwordREGISTER" "Password" "password" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_pass) -- action
|
||||
registrationForm.pass -- 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" ]
|
||||
]
|
||||
]
|
||||
|
||||
render_password_recovery_form = HH.form
|
||||
[ HE.onSubmit PasswordRecoveryAttempt ]
|
||||
[ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder
|
||||
@ -183,12 +148,6 @@ handleAction = case _ of
|
||||
AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
|
||||
AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = v } }
|
||||
|
||||
HandleRegisterInput reginp -> do
|
||||
case reginp of
|
||||
REG_INP_login v -> H.modify_ _ { registrationForm { login = v } }
|
||||
REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
|
||||
REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } }
|
||||
|
||||
HandlePasswordRecovery authinp -> do
|
||||
case authinp of
|
||||
PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } }
|
||||
@ -210,32 +169,6 @@ handleAction = case _ of
|
||||
H.raise $ AuthenticateToAuthd (Tuple login pass)
|
||||
H.raise $ Log $ SimpleLog $ "[😇] Trying to authenticate (login: " <> login <> ")"
|
||||
|
||||
RegisterAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ registrationForm } <- H.get
|
||||
let login = registrationForm.login
|
||||
email = registrationForm.email
|
||||
pass = registrationForm.pass
|
||||
|
||||
case login, email, pass of
|
||||
"", _, _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your login!"
|
||||
|
||||
_, "", _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your email!"
|
||||
|
||||
_, _, "" ->
|
||||
H.raise $ Log $ UnableToSend "Write your password!"
|
||||
|
||||
_, _, _ -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkRegister { login: login
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")"
|
||||
|
||||
PasswordRecoveryAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
@ -257,10 +190,10 @@ handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () O
|
||||
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 a -> do
|
||||
MessageReceived message _ -> do
|
||||
case message of
|
||||
_ -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Message not handled in AuthenticationForm."
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Message not handled in AuthenticationInterface."
|
||||
pure Nothing
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
@ -1,4 +1,36 @@
|
||||
-- | `App.Container` is the parent of all other components of the application.
|
||||
-- |
|
||||
-- | Each page has its own module and the `App.Container` informs them when the websocket is up or down.
|
||||
-- | A module implements Websocket operations and is used twice, once for the connection to `authd`,
|
||||
-- | another for the connection to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | `App.Container` stores the state of different components (domain list and zone interface)
|
||||
-- | to avoid useless requests to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | TODO: store forms in session storage?
|
||||
-- |
|
||||
-- | `App.Container` detects when a page has been reloaded and:
|
||||
-- | 1. authenticate the user to `dnsmanagerd` via a stored token in session storage.
|
||||
-- | The authentication to `dnsmanagerd` automatically provides own domains and accepted domains (such as `netlib.re`).
|
||||
-- | This is enough data for the `DomainList` page.
|
||||
-- | 2. go back to that page.
|
||||
-- | In case the old page is `Zone`, send a request to `dnsmanagerd` to get the zone content again.
|
||||
-- |
|
||||
-- | Once a message is received, it is transfered to the module of the current page;
|
||||
-- | except for the `App.Messages.DNSManagerDaemon.AnswerMessage` `Logged` which is an hint when the
|
||||
-- | page has been reloaded, thus having a special treatment.
|
||||
-- |
|
||||
-- | TODO:
|
||||
-- | Each received message is transfered to the current page module because there is no centralized state.
|
||||
-- | This may be a good idea to store the state of the entire application at the same place, avoiding to
|
||||
-- | handle messages in the different pages.
|
||||
-- | Pages could handle semantic operations directly instead.
|
||||
-- |
|
||||
-- | TODO:
|
||||
-- | Allow users to provide a validation code (received by email).
|
||||
-- |
|
||||
-- | TODO:
|
||||
-- | Verify that a user can register, update its password, login.
|
||||
module App.Container where
|
||||
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure)
|
||||
@ -11,7 +43,8 @@ import Data.Array as A
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Tuple (Tuple(..))
|
||||
import App.AuthenticationForm as AF
|
||||
import App.AuthenticationInterface as AI
|
||||
import App.RegistrationInterface as RI
|
||||
import App.Log as AppLog
|
||||
import App.WS as WS
|
||||
import App.AuthenticationDaemonAdminInterface as AAI
|
||||
@ -35,7 +68,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 | LoginRegister | DomainList | Zone String | AuthAdmin
|
||||
data Page = Home | Authentication | Registration | DomainList | Zone String | AuthAdmin
|
||||
|
||||
type Token = String
|
||||
type Login = String
|
||||
@ -43,8 +76,11 @@ type Password = String
|
||||
type LogInfo = Tuple Login Password
|
||||
|
||||
data Action
|
||||
-- | Handle events from `AuthenticationInterface`.
|
||||
= AuthenticationInterfaceEvent AI.Output
|
||||
|
||||
-- | Handle events from `AuthenticationComponent`.
|
||||
= AuthenticationComponentEvent AF.Output
|
||||
| RegistrationInterfaceEvent RI.Output
|
||||
|
||||
-- | Handle events from `AuthenticationDaemonAdminComponent`.
|
||||
| AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd.
|
||||
@ -105,14 +141,15 @@ type State = { token :: Maybe String
|
||||
}
|
||||
|
||||
-- | The list of child components: log, `WS` twice (once for each ws connection),
|
||||
-- | then all the pages (AuthenticationForm, HomeInterface, DomainListInterface, ZoneInterface and
|
||||
-- | AuthenticationDaemonAdminInterface).
|
||||
-- | then all the pages (AuthenticationInterface, RegistrationInterface, HomeInterface, DomainListInterface,
|
||||
-- | ZoneInterface and AuthenticationDaemonAdminInterface).
|
||||
type ChildSlots =
|
||||
( log :: AppLog.Slot Unit
|
||||
, ho :: HomeInterface.Slot Unit
|
||||
, ws_auth :: WS.Slot Unit
|
||||
, ws_dns :: WS.Slot Unit
|
||||
, af :: AF.Slot Unit
|
||||
, ai :: AI.Slot Unit
|
||||
, ri :: RI.Slot Unit
|
||||
, aai :: AAI.Slot Unit
|
||||
, dli :: DomainListInterface.Slot Unit
|
||||
, zi :: ZoneInterface.Slot Unit
|
||||
@ -122,7 +159,8 @@ _ho = Proxy :: Proxy "ho" -- Home Interface
|
||||
_log = Proxy :: Proxy "log" -- Log
|
||||
_ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd`
|
||||
_ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd`
|
||||
_af = Proxy :: Proxy "af" -- Authentication Form
|
||||
_ai = Proxy :: Proxy "ai" -- Authentication Interface
|
||||
_ri = Proxy :: Proxy "ri" -- Registration Interface
|
||||
_aai = Proxy :: Proxy "aai" -- Authd Administration Interface
|
||||
_dli = Proxy :: Proxy "dli" -- Domain List
|
||||
_zi = Proxy :: Proxy "zi" -- Zone Interface
|
||||
@ -149,11 +187,12 @@ render state
|
||||
[ render_header
|
||||
, render_nav
|
||||
, case state.current_page of
|
||||
Home -> render_home
|
||||
LoginRegister -> render_auth_form
|
||||
DomainList -> render_domainlist_interface
|
||||
Zone domain -> render_zone domain
|
||||
AuthAdmin -> render_authd_admin_interface
|
||||
Home -> render_home
|
||||
Authentication -> render_auth_form
|
||||
Registration -> render_registration
|
||||
DomainList -> render_domainlist_interface
|
||||
Zone domain -> render_zone domain
|
||||
AuthAdmin -> render_authd_admin_interface
|
||||
-- The footer includes logs and both the WS child components.
|
||||
, Bulma.columns_ [ Bulma.column_ [ render_logs ]
|
||||
, Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ]
|
||||
@ -165,7 +204,9 @@ render state
|
||||
render_domainlist_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_domainlist_interface = HH.slot _dli unit DomainListInterface.component unit DomainListComponentEvent
|
||||
render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_form = HH.slot _af unit AF.component unit AuthenticationComponentEvent
|
||||
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_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
|
||||
@ -179,7 +220,13 @@ render state
|
||||
admin = true
|
||||
|
||||
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_nav = Nav.netlibre_navbar authenticated admin (Routing Home) (Routing DomainList) (Routing AuthAdmin) (Routing LoginRegister) (Routing LoginRegister) Disconnection
|
||||
render_nav = Nav.netlibre_navbar authenticated admin
|
||||
(Routing Home)
|
||||
(Routing DomainList)
|
||||
(Routing AuthAdmin)
|
||||
(Routing Authentication)
|
||||
(Routing Registration)
|
||||
Disconnection
|
||||
|
||||
render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_header = case state.token of
|
||||
@ -198,15 +245,16 @@ render state
|
||||
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
handleAction = case _ of
|
||||
Routing page -> do
|
||||
-- TODO: store the current page we are on and restore it when we reload.
|
||||
-- Store the current page we are on and restore it when we reload.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- case page of
|
||||
Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
|
||||
LoginRegister -> H.liftEffect $ Storage.setItem "current-page" "LoginRegister" 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
|
||||
AuthAdmin -> H.liftEffect $ Storage.setItem "current-page" "AuthAdmin" sessionstorage
|
||||
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
|
||||
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
|
||||
AuthAdmin -> H.liftEffect $ Storage.setItem "current-page" "AuthAdmin" sessionstorage
|
||||
H.modify_ _ { current_page = page }
|
||||
|
||||
Log message -> H.tell _log unit $ AppLog.Log message
|
||||
@ -227,10 +275,14 @@ handleAction = case _ of
|
||||
handleAction $ Log $ SimpleLog $ "Let's start again to auth to dnsmanagerd with this token: " <> t
|
||||
handleAction AuthenticateToDNSManager
|
||||
|
||||
AuthenticationComponentEvent ev -> case ev of
|
||||
AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
AF.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
|
||||
AF.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
AuthenticationInterfaceEvent ev -> case ev of
|
||||
AI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
|
||||
AI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
RegistrationInterfaceEvent ev -> case ev of
|
||||
RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
RI.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)
|
||||
@ -261,11 +313,11 @@ handleAction = case _ of
|
||||
handleAction $ DecodeAuthMessage message
|
||||
|
||||
WS.WSJustConnected -> do
|
||||
H.tell _af unit AF.ConnectionIsUp
|
||||
H.tell _ai unit AI.ConnectionIsUp
|
||||
H.tell _aai unit AAI.ConnectionIsUp
|
||||
|
||||
WS.WSJustClosed -> do
|
||||
H.tell _af unit AF.ConnectionIsDown
|
||||
H.tell _ai unit AI.ConnectionIsDown
|
||||
H.tell _aai unit AAI.ConnectionIsDown
|
||||
WS.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
@ -368,7 +420,7 @@ handleAction = case _ of
|
||||
pure unit
|
||||
-- { token } <- H.get
|
||||
-- case token of
|
||||
-- Nothing -> H.tell _af unit (AF.MessageReceived message)
|
||||
-- Nothing -> H.tell _ai unit (AI.MessageReceived message)
|
||||
-- Just _ -> H.tell _aai unit (AAI.MessageReceived message)
|
||||
-- case current_page of
|
||||
-- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message)
|
||||
@ -506,9 +558,10 @@ handleAction = case _ of
|
||||
page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
|
||||
case page of
|
||||
Nothing -> pure unit
|
||||
Just "Home" -> handleAction $ Routing Home
|
||||
Just "LoginRegister" -> handleAction $ Routing LoginRegister
|
||||
Just "DomainList" -> handleAction $ Routing DomainList
|
||||
Just "Home" -> handleAction $ Routing Home
|
||||
Just "Authentication" -> handleAction $ Routing Authentication
|
||||
Just "Registration" -> handleAction $ Routing Registration
|
||||
Just "DomainList" -> handleAction $ Routing DomainList
|
||||
|
||||
Just "Zone" -> do
|
||||
handleAction $ Log $ SystemLog "wait, we were on the Zone page!!"
|
||||
|
||||
@ -21,7 +21,9 @@ import Bulma as Bulma
|
||||
-- |
|
||||
-- | 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 authenticated admin actionHome actionDomainList actionAuthdAdmin _ actionLogin actionDisconnection =
|
||||
netlibre_navbar authenticated admin
|
||||
actionHome actionDomainList actionAuthdAdmin
|
||||
actionLogin actionRegistration actionDisconnection =
|
||||
main_nav
|
||||
[ nav_brand [ logo, burger_menu ]
|
||||
, nav_menu
|
||||
@ -41,8 +43,8 @@ netlibre_navbar authenticated admin actionHome actionDomainList actionAuthdAdmin
|
||||
, navbar_end
|
||||
[ navbar_item
|
||||
[ HH.div [HP.classes C.buttons] $ case authenticated of
|
||||
false -> [ nav_button C.is_info "Login or register" actionLogin
|
||||
-- nav_button_strong "Register" actionRegister
|
||||
false -> [ nav_button C.is_info "Login" actionLogin
|
||||
, nav_button_strong "Register" actionRegistration
|
||||
, nav_button_code
|
||||
]
|
||||
_ -> [ nav_button_disconnection, nav_button_code ]
|
||||
@ -74,7 +76,7 @@ netlibre_navbar authenticated admin actionHome actionDomainList actionAuthdAdmin
|
||||
--dropdown_element str = HH.a [HP.classes C.navbar_item] [HH.text str]
|
||||
--dropdown_separator = HH.hr [HP.classes C.navbar_divider]
|
||||
nav_button_code = btn_link [] "https://git.baguette.netlib.re/Baguette/dnsmanager" "Code"
|
||||
-- nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ])
|
||||
nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ])
|
||||
nav_button classes str action = btn classes action (HH.text str)
|
||||
|
||||
navbar_item = HH.div [HP.classes C.navbar_item]
|
||||
|
||||
167
src/App/RegistrationInterface.purs
Normal file
167
src/App/RegistrationInterface.purs
Normal file
@ -0,0 +1,167 @@
|
||||
-- | `App.RegistrationInterface` is a registration interface.
|
||||
-- | Registration requires a login, an email address and a password.
|
||||
module App.RegistrationInterface where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>))
|
||||
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Maybe (Maybe(..))
|
||||
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.Email as Email
|
||||
import App.LogMessage
|
||||
import App.Messages.AuthenticationDaemon as AuthD
|
||||
|
||||
-- | 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
|
||||
| Log LogMessage
|
||||
|
||||
-- | 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 RegisterInput
|
||||
= REG_INP_login String
|
||||
| REG_INP_email String
|
||||
| REG_INP_pass String
|
||||
|
||||
data Action
|
||||
= HandleRegisterInput RegisterInput
|
||||
| RegisterAttempt Event
|
||||
|
||||
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
|
||||
|
||||
type State =
|
||||
{ registrationForm :: StateRegistrationForm
|
||||
, 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 _ =
|
||||
{ registrationForm: { login: "", email: "", pass: "" }
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, registrationForm }
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> Bulma.columns_ [ b registration_form ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
registration_form = [ Bulma.h3 "Register!" , render_register_form ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_register_form = HH.form
|
||||
[ HE.onSubmit RegisterAttempt ]
|
||||
[ Bulma.box_input "loginREGISTER" "Login" "login" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_login) -- action
|
||||
registrationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "emailREGISTER" "Email" "email@example.com" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_email) -- action
|
||||
registrationForm.email -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_password "passwordREGISTER" "Password" "password" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_pass) -- action
|
||||
registrationForm.pass -- 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
|
||||
HandleRegisterInput reginp -> do
|
||||
case reginp of
|
||||
REG_INP_login v -> H.modify_ _ { registrationForm { login = v } }
|
||||
REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
|
||||
REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } }
|
||||
|
||||
RegisterAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ registrationForm } <- H.get
|
||||
let login = registrationForm.login
|
||||
email = registrationForm.email
|
||||
pass = registrationForm.pass
|
||||
|
||||
case login, email, pass of
|
||||
"", _, _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your login!"
|
||||
|
||||
_, "", _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your email!"
|
||||
|
||||
_, _, "" ->
|
||||
H.raise $ Log $ UnableToSend "Write your password!"
|
||||
|
||||
_, _, _ -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkRegister { login: login
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")"
|
||||
|
||||
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 $ SimpleLog $ "[😈] Message not handled in the `RegistrationInterface` module."
|
||||
pure Nothing
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
Loading…
Reference in New Issue
Block a user