Change a few names, split authentication and registration.

beta
Philippe Pittoli 2024-02-10 03:10:29 +01:00
parent 41b4511a94
commit 329d84e6f9
4 changed files with 265 additions and 110 deletions

View File

@ -1,11 +1,11 @@
-- | `App.AuthenticationForm` is both the authentication and registration interface. -- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
module App.AuthenticationForm where -- | 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.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..)) import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
@ -50,31 +50,22 @@ data AuthenticationInput
= AUTH_INP_login String = AUTH_INP_login String
| AUTH_INP_pass String | AUTH_INP_pass String
data RegisterInput
= REG_INP_login String
| REG_INP_email String
| REG_INP_pass String
data PasswordRecoveryInput data PasswordRecoveryInput
= PASSR_INP_login String = PASSR_INP_login String
| PASSR_INP_email String | PASSR_INP_email String
data Action data Action
= HandleAuthenticationInput AuthenticationInput = HandleAuthenticationInput AuthenticationInput
| HandleRegisterInput RegisterInput
| HandlePasswordRecovery PasswordRecoveryInput | HandlePasswordRecovery PasswordRecoveryInput
-- --
| AuthenticationAttempt Event | AuthenticationAttempt Event
| RegisterAttempt Event
| PasswordRecoveryAttempt Event | PasswordRecoveryAttempt Event
type StateAuthenticationForm = { login :: String, pass :: String } type StateAuthenticationForm = { login :: String, pass :: String }
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
type StatePasswordRecoveryForm = { login :: String, email :: String } type StatePasswordRecoveryForm = { login :: String, email :: String }
type State = type State =
{ authenticationForm :: StateAuthenticationForm { authenticationForm :: StateAuthenticationForm
, registrationForm :: StateRegistrationForm
, passwordRecoveryForm :: StatePasswordRecoveryForm , passwordRecoveryForm :: StatePasswordRecoveryForm
, wsUp :: Boolean , wsUp :: Boolean
} }
@ -93,25 +84,23 @@ component =
initialState :: Input -> State initialState :: Input -> State
initialState _ = initialState _ =
{ authenticationForm: { login: "", pass: "" } { authenticationForm: { login: "", pass: "" }
, registrationForm: { login: "", email: "", pass: "" }
, passwordRecoveryForm: { login: "", email: "" } , passwordRecoveryForm: { login: "", email: "" }
, wsUp: true , wsUp: true
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { wsUp, authenticationForm, registrationForm, passwordRecoveryForm} render { wsUp, authenticationForm, passwordRecoveryForm}
= Bulma.section_small = Bulma.section_small
[ case wsUp of [ case wsUp of
false -> Bulma.p "You are disconnected." 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 where
b e = Bulma.column_ [ Bulma.box e ] b e = Bulma.column_ [ Bulma.box e ]
auth_form = [ Bulma.h3 "Authentication" , render_auth_form ] 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 ] passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true)) 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" ] [ 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 render_password_recovery_form = HH.form
[ HE.onSubmit PasswordRecoveryAttempt ] [ HE.onSubmit PasswordRecoveryAttempt ]
[ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder [ 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_login v -> H.modify_ _ { authenticationForm { login = v } }
AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = 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 HandlePasswordRecovery authinp -> do
case authinp of case authinp of
PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } } PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } }
@ -210,32 +169,6 @@ handleAction = case _ of
H.raise $ AuthenticateToAuthd (Tuple login pass) H.raise $ AuthenticateToAuthd (Tuple login pass)
H.raise $ Log $ SimpleLog $ "[😇] Trying to authenticate (login: " <> login <> ")" 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 PasswordRecoveryAttempt ev -> do
H.liftEffect $ Event.preventDefault ev 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 handleQuery = case _ of
-- For now, no message actually needs to be handled here. -- For now, no message actually needs to be handled here.
-- Error messages are simply logged (see the code in the Container component). -- Error messages are simply logged (see the code in the Container component).
MessageReceived message a -> do MessageReceived message _ -> do
case message of case message of
_ -> do _ -> do
H.raise $ Log $ SimpleLog $ "[😈] Message not handled in AuthenticationForm." H.raise $ Log $ SimpleLog $ "[😈] Message not handled in AuthenticationInterface."
pure Nothing pure Nothing
ConnectionIsDown a -> do ConnectionIsDown a -> do

View File

@ -1,4 +1,36 @@
-- | `App.Container` is the parent of all other components of the application. -- | `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 module App.Container where
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure) import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure)
@ -11,7 +43,8 @@ import Data.Array as A
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Tuple (Tuple(..)) 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.Log as AppLog
import App.WS as WS import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI import App.AuthenticationDaemonAdminInterface as AAI
@ -35,7 +68,7 @@ import App.LogMessage (LogMessage(..))
-- | List all pages the application has: -- | List all pages the application has:
-- | Home, Login, Domain list, Zone, `authd` administration. -- | Home, Login, Domain list, Zone, `authd` administration.
-- | This list will grows in a near future. -- | 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 Token = String
type Login = String type Login = String
@ -43,8 +76,11 @@ type Password = String
type LogInfo = Tuple Login Password type LogInfo = Tuple Login Password
data Action data Action
-- | Handle events from `AuthenticationInterface`.
= AuthenticationInterfaceEvent AI.Output
-- | Handle events from `AuthenticationComponent`. -- | Handle events from `AuthenticationComponent`.
= AuthenticationComponentEvent AF.Output | RegistrationInterfaceEvent RI.Output
-- | Handle events from `AuthenticationDaemonAdminComponent`. -- | Handle events from `AuthenticationDaemonAdminComponent`.
| AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd. | 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), -- | The list of child components: log, `WS` twice (once for each ws connection),
-- | then all the pages (AuthenticationForm, HomeInterface, DomainListInterface, ZoneInterface and -- | then all the pages (AuthenticationInterface, RegistrationInterface, HomeInterface, DomainListInterface,
-- | AuthenticationDaemonAdminInterface). -- | ZoneInterface and AuthenticationDaemonAdminInterface).
type ChildSlots = type ChildSlots =
( log :: AppLog.Slot Unit ( log :: AppLog.Slot Unit
, ho :: HomeInterface.Slot Unit , ho :: HomeInterface.Slot Unit
, ws_auth :: WS.Slot Unit , ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit , ws_dns :: WS.Slot Unit
, af :: AF.Slot Unit , ai :: AI.Slot Unit
, ri :: RI.Slot Unit
, aai :: AAI.Slot Unit , aai :: AAI.Slot Unit
, dli :: DomainListInterface.Slot Unit , dli :: DomainListInterface.Slot Unit
, zi :: ZoneInterface.Slot Unit , zi :: ZoneInterface.Slot Unit
@ -122,7 +159,8 @@ _ho = Proxy :: Proxy "ho" -- Home Interface
_log = Proxy :: Proxy "log" -- Log _log = Proxy :: Proxy "log" -- Log
_ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd` _ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd`
_ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd` _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 _aai = Proxy :: Proxy "aai" -- Authd Administration Interface
_dli = Proxy :: Proxy "dli" -- Domain List _dli = Proxy :: Proxy "dli" -- Domain List
_zi = Proxy :: Proxy "zi" -- Zone Interface _zi = Proxy :: Proxy "zi" -- Zone Interface
@ -149,11 +187,12 @@ render state
[ render_header [ render_header
, render_nav , render_nav
, case state.current_page of , case state.current_page of
Home -> render_home Home -> render_home
LoginRegister -> render_auth_form Authentication -> render_auth_form
DomainList -> render_domainlist_interface Registration -> render_registration
Zone domain -> render_zone domain DomainList -> render_domainlist_interface
AuthAdmin -> render_authd_admin_interface Zone domain -> render_zone domain
AuthAdmin -> render_authd_admin_interface
-- The footer includes logs and both the WS child components. -- The footer includes logs and both the WS child components.
, Bulma.columns_ [ Bulma.column_ [ render_logs ] , Bulma.columns_ [ Bulma.column_ [ render_logs ]
, Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ] , 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 :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_domainlist_interface = HH.slot _dli unit DomainListInterface.component unit DomainListComponentEvent 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 :: 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 :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
@ -179,7 +220,13 @@ render state
admin = true admin = true
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad 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 :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_header = case state.token of 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 :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
handleAction = case _ of handleAction = case _ of
Routing page -> do 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 sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
_ <- case page of _ <- case page of
Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
LoginRegister -> H.liftEffect $ Storage.setItem "current-page" "LoginRegister" sessionstorage Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage
Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage
H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage
AuthAdmin -> H.liftEffect $ Storage.setItem "current-page" "AuthAdmin" sessionstorage H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
AuthAdmin -> H.liftEffect $ Storage.setItem "current-page" "AuthAdmin" sessionstorage
H.modify_ _ { current_page = page } H.modify_ _ { current_page = page }
Log message -> H.tell _log unit $ AppLog.Log message 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 $ Log $ SimpleLog $ "Let's start again to auth to dnsmanagerd with this token: " <> t
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
AuthenticationComponentEvent ev -> case ev of AuthenticationInterfaceEvent ev -> case ev of
AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
AF.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v) AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
AF.Log message -> H.tell _log unit (AppLog.Log message) 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 AuthenticationDaemonAdminComponentEvent ev -> case ev of
AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
@ -261,11 +313,11 @@ handleAction = case _ of
handleAction $ DecodeAuthMessage message handleAction $ DecodeAuthMessage message
WS.WSJustConnected -> do WS.WSJustConnected -> do
H.tell _af unit AF.ConnectionIsUp H.tell _ai unit AI.ConnectionIsUp
H.tell _aai unit AAI.ConnectionIsUp H.tell _aai unit AAI.ConnectionIsUp
WS.WSJustClosed -> do WS.WSJustClosed -> do
H.tell _af unit AF.ConnectionIsDown H.tell _ai unit AI.ConnectionIsDown
H.tell _aai unit AAI.ConnectionIsDown H.tell _aai unit AAI.ConnectionIsDown
WS.Log message -> H.tell _log unit (AppLog.Log message) WS.Log message -> H.tell _log unit (AppLog.Log message)
@ -368,7 +420,7 @@ handleAction = case _ of
pure unit pure unit
-- { token } <- H.get -- { token } <- H.get
-- case token of -- 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) -- Just _ -> H.tell _aai unit (AAI.MessageReceived message)
-- case current_page of -- case current_page of
-- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message) -- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message)
@ -506,9 +558,10 @@ handleAction = case _ of
page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
case page of case page of
Nothing -> pure unit Nothing -> pure unit
Just "Home" -> handleAction $ Routing Home Just "Home" -> handleAction $ Routing Home
Just "LoginRegister" -> handleAction $ Routing LoginRegister Just "Authentication" -> handleAction $ Routing Authentication
Just "DomainList" -> handleAction $ Routing DomainList Just "Registration" -> handleAction $ Routing Registration
Just "DomainList" -> handleAction $ Routing DomainList
Just "Zone" -> do Just "Zone" -> do
handleAction $ Log $ SystemLog "wait, we were on the Zone page!!" handleAction $ Log $ SystemLog "wait, we were on the Zone page!!"

View File

@ -21,7 +21,9 @@ import Bulma as Bulma
-- | -- |
-- | TODO: make the "burger" component actually useful. For now, it's empty. -- | 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 -> 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 main_nav
[ nav_brand [ logo, burger_menu ] [ nav_brand [ logo, burger_menu ]
, nav_menu , nav_menu
@ -41,8 +43,8 @@ netlibre_navbar authenticated admin actionHome actionDomainList actionAuthdAdmin
, navbar_end , navbar_end
[ navbar_item [ navbar_item
[ HH.div [HP.classes C.buttons] $ case authenticated of [ HH.div [HP.classes C.buttons] $ case authenticated of
false -> [ nav_button C.is_info "Login or register" actionLogin false -> [ nav_button C.is_info "Login" actionLogin
-- nav_button_strong "Register" actionRegister , nav_button_strong "Register" actionRegistration
, nav_button_code , nav_button_code
] ]
_ -> [ nav_button_disconnection, 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_element str = HH.a [HP.classes C.navbar_item] [HH.text str]
--dropdown_separator = HH.hr [HP.classes C.navbar_divider] --dropdown_separator = HH.hr [HP.classes C.navbar_divider]
nav_button_code = btn_link [] "https://git.baguette.netlib.re/Baguette/dnsmanager" "Code" 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) nav_button classes str action = btn classes action (HH.text str)
navbar_item = HH.div [HP.classes C.navbar_item] navbar_item = HH.div [HP.classes C.navbar_item]

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