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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
src/App/AuthenticationForm.purs → src/App/AuthenticationInterface.purs
View File

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

93
src/App/Container.purs
View File

@ -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
@ -150,7 +188,8 @@ render state
, render_nav
, case state.current_page of
Home -> render_home
LoginRegister -> render_auth_form
Authentication -> render_auth_form
Registration -> render_registration
DomainList -> render_domainlist_interface
Zone domain -> render_zone domain
AuthAdmin -> render_authd_admin_interface
@ -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,11 +245,12 @@ 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
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
@ -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)
@ -507,7 +559,8 @@ handleAction = case _ of
case page of
Nothing -> pure unit
Just "Home" -> handleAction $ Routing Home
Just "LoginRegister" -> handleAction $ Routing LoginRegister
Just "Authentication" -> handleAction $ Routing Authentication
Just "Registration" -> handleAction $ Routing Registration
Just "DomainList" -> handleAction $ Routing DomainList
Just "Zone" -> do

10
src/App/Nav.purs
View File

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