WIP: cleaner API for components.

This commit is contained in:
Philippe Pittoli 2025-05-09 20:49:25 +02:00
parent 6392c1941c
commit 507588cd66
6 changed files with 45 additions and 45 deletions

View file

@ -524,7 +524,6 @@ handleAction = case _ of
PageNavigation.Disconnection -> handleAction $ Disconnection PageNavigation.Disconnection -> handleAction $ Disconnection
EventPageAuthentication ev -> case ev of EventPageAuthentication ev -> case ev of
PageAuthentication.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
PageAuthentication.AskPasswordRecovery e -> case e of PageAuthentication.AskPasswordRecovery e -> case e of
Left email -> do Left email -> do
message <- H.liftEffect $ AuthD.serialize $ message <- H.liftEffect $ AuthD.serialize $
@ -550,11 +549,15 @@ handleAction = case _ of
H.tell _nav unit $ PageNavigation.TellLogin (Just login) H.tell _nav unit $ PageNavigation.TellLogin (Just login)
EventPageRegistration ev -> case ev of EventPageRegistration ev -> case ev of
PageRegistration.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) PageRegistration.AskRegister login email password -> do
PageRegistration.Log message -> handleAction $ Log message message <- H.liftEffect $ AuthD.serialize $ AuthD.MkRegister { login, email, password }
H.tell _ws_auth unit (WS.ToSend message)
PageRegistration.Log message -> handleAction $ Log message
EventPageMailValidation ev -> case ev of EventPageMailValidation ev -> case ev of
PageMailValidation.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) PageMailValidation.AskValidateUser user activation_key -> do
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user, activation_key }
H.tell _ws_auth unit (WS.ToSend message)
PageMailValidation.Log message -> handleAction $ Log message PageMailValidation.Log message -> handleAction $ Log message
EventPageSetup ev -> case ev of EventPageSetup ev -> case ev of
@ -582,8 +585,6 @@ handleAction = case _ of
PageSetup.Log message -> handleAction $ Log message PageSetup.Log message -> handleAction $ Log message
EventPageAdministration ev -> case ev of EventPageAdministration ev -> case ev of
PageAdministration.SendToAuthd message -> H.tell _ws_auth unit (WS.ToSend message)
PageAdministration.SendToDNSManager message -> H.tell _ws_dns unit (WS.ToSend message)
PageAdministration.DeleteDomain domain -> do PageAdministration.DeleteDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain } message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain }
H.tell _ws_dns unit (WS.ToSend message) H.tell _ws_dns unit (WS.ToSend message)
@ -620,7 +621,24 @@ handleAction = case _ of
PageZone.ToDomainList -> handleAction $ Routing DomainList PageZone.ToDomainList -> handleAction $ Routing DomainList
EventPageDomainList ev -> case ev of EventPageDomainList ev -> case ev of
PageDomainList.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) PageDomainList.AskShareToken domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskShareToken { domain }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.AskTransferToken domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskTransferToken { domain }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.AskUnShareDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskUnShareDomain { domain }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.AskDeleteDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.AskNewDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkNewDomain { domain }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.AskGainOwnership uuid -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGainOwnership { uuid }
H.tell _ws_dns unit (WS.ToSend message)
PageDomainList.Log message -> handleAction $ Log message PageDomainList.Log message -> handleAction $ Log message
PageDomainList.StoreState s -> H.modify_ _ { childstates { domainlist = Just s } } PageDomainList.StoreState s -> H.modify_ _ { childstates { domainlist = Just s } }
PageDomainList.ChangePageZoneInterface domain -> do PageDomainList.ChangePageZoneInterface domain -> do

View file

@ -34,7 +34,6 @@ import Web.HTML.Window (sessionStorage) as Window
import Web.Storage.Storage as Storage import Web.Storage.Storage as Storage
import App.Type.UserPublic (UserPublic) import App.Type.UserPublic (UserPublic)
import Data.ArrayBuffer.Types (ArrayBuffer)
import App.Type.LogMessage import App.Type.LogMessage
import App.Type.Email as Email import App.Type.Email as Email
@ -42,10 +41,7 @@ import App.Type.Email as Email
import App.Message.AuthenticationDaemon as AuthD import App.Message.AuthenticationDaemon as AuthD
data Output data Output
= SendToAuthd ArrayBuffer = AddUser String Boolean (Maybe Email.Email) String
| SendToDNSManager ArrayBuffer
| AddUser String Boolean (Maybe Email.Email) String
| SearchUser (Maybe String) (Maybe Int) | SearchUser (Maybe String) (Maybe Int)
| DeleteUserAccount Int | DeleteUserAccount Int

View file

@ -5,7 +5,6 @@ module App.Page.Authentication where
import Prelude (Unit, bind, discard, pure, ($), (<<<), (=<<), (<>), (>), (==), map, show, unit) import Prelude (Unit, bind, discard, pure, ($), (<<<), (=<<), (<>), (>), (==), map, show, unit)
import Data.Array as A import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Eq (class Eq) import Data.Eq (class Eq)
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
@ -48,8 +47,7 @@ data Error
-- | -- |
-- | TODO: authentication is performed in `App.Container`. -- | TODO: authentication is performed in `App.Container`.
data Output data Output
= MessageToSend ArrayBuffer = AuthenticateToAuthd (Tuple Login Password)
| AuthenticateToAuthd (Tuple Login Password)
| Log LogMessage | Log LogMessage
| UserLogin String | UserLogin String
| PasswordRecovery Login PasswordRecoveryToken Password | PasswordRecovery Login PasswordRecoveryToken Password

View file

@ -15,7 +15,6 @@ module App.Page.DomainList where
import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>), (>), (==)) import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>), (>), (==))
import Data.Array as A import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.String (toLower) import Data.String (toLower)
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
@ -52,7 +51,12 @@ import App.Message.DNSManagerDaemon as DNSManager
-- | component is removed. This way, the data is conserved. -- | component is removed. This way, the data is conserved.
data Output data Output
= MessageToSend ArrayBuffer = AskShareToken String
| AskTransferToken String
| AskUnShareDomain String
| AskDeleteDomain String
| AskNewDomain String
| AskGainOwnership String
| Log LogMessage | Log LogMessage
| ChangePageZoneInterface String | ChangePageZoneInterface String
| AskState | AskState
@ -328,27 +332,23 @@ handleAction = case _ of
H.raise $ ChangePageZoneInterface domain H.raise $ ChangePageZoneInterface domain
ShareDomain domain -> do ShareDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskShareToken { domain: domain }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Ask a \"share token\" for domain " <> domain <> "." H.raise $ Log $ SystemLog $ "Ask a \"share token\" for domain " <> domain <> "."
H.raise $ AskShareToken domain
TransferDomain domain -> do TransferDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskTransferToken { domain: domain }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Ask a \"transfer token\" for domain " <> domain <> "." H.raise $ Log $ SystemLog $ "Ask a \"transfer token\" for domain " <> domain <> "."
H.raise $ AskTransferToken domain
UnShareDomain domain -> do UnShareDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskUnShareDomain { domain: domain }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Ask for exclusive ownership for domain " <> domain <> "." H.raise $ Log $ SystemLog $ "Ask for exclusive ownership for domain " <> domain <> "."
H.raise $ AskUnShareDomain domain
DeleteDomainModal domain -> do DeleteDomainModal domain -> do
H.modify_ _ { deletion_modal = Just domain } H.modify_ _ { deletion_modal = Just domain }
RemoveDomain domain -> do RemoveDomain domain -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Remove domain: " <> domain H.raise $ Log $ SystemLog $ "Remove domain: " <> domain
H.raise $ AskDeleteDomain domain
H.modify_ _ { deletion_modal = Nothing } H.modify_ _ { deletion_modal = Nothing }
NewDomainAttempt ev -> do NewDomainAttempt ev -> do
@ -361,10 +361,7 @@ handleAction = case _ of
"", _, _ -> "", _, _ ->
H.raise $ Log $ UnableToSend "Please enter the new domain." H.raise $ Log $ UnableToSend "Please enter the new domain."
_, [], _ -> do _, [], _ -> do
message <- H.liftEffect H.raise $ AskNewDomain new_domain
$ DNSManager.serialize
$ DNSManager.MkNewDomain { domain: new_domain }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")" H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")"
handleAction $ HandleNewDomainInput $ INP_newdomain "" handleAction $ HandleNewDomainInput $ INP_newdomain ""
_, _, _ -> _, _, _ ->
@ -374,14 +371,12 @@ handleAction = case _ of
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ askDomainTransferForm } <- H.get { askDomainTransferForm } <- H.get
case askDomainTransferForm.uuid, askDomainTransferForm._errors of let { uuid, _errors } = askDomainTransferForm
case uuid, _errors of
"", _ -> "", _ ->
H.raise $ Log $ UnableToSend "Please enter the UUID of the transfer." H.raise $ Log $ UnableToSend "Please enter the UUID of the transfer."
uuid, [] -> do uuid, [] -> do
message <- H.liftEffect H.raise $ AskGainOwnership uuid
$ DNSManager.serialize
$ DNSManager.MkGainOwnership { uuid: uuid }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Gain ownership of a domain (" <> uuid <> ")." H.raise $ Log $ SystemLog $ "Gain ownership of a domain (" <> uuid <> ")."
handleAction $ AskDomainTransferUUIDInput "" handleAction $ AskDomainTransferUUIDInput ""
_, _ -> _, _ ->

View file

@ -6,7 +6,6 @@ module App.Page.MailValidation where
import Prelude (Unit, bind, discard, ($), (<<<), (<>), map, show) import Prelude (Unit, bind, discard, ($), (<<<), (<>), map, show)
import Data.Array as A import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (maybe) import Data.Maybe (maybe)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
@ -19,13 +18,12 @@ import Web.Event.Event (Event)
import Web as Web import Web as Web
import App.Type.LogMessage import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
import App.Validation.Login as L import App.Validation.Login as L
import App.Validation.Token as T import App.Validation.Token as T
data Output data Output
= MessageToSend ArrayBuffer = AskValidateUser String String
| Log LogMessage | Log LogMessage
-- | The component is informed when the connection went up or down. -- | The component is informed when the connection went up or down.
@ -127,8 +125,7 @@ handleAction = case _ of
SendMailValidationToken -> do SendMailValidationToken -> do
{ mailValidationForm } <- H.get { mailValidationForm } <- H.get
let { login, token } = mailValidationForm let { login, token } = mailValidationForm
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user: login, activation_key: token } H.raise $ AskValidateUser login token
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Trying to validate email address of user \"" <> login <> "\"" H.raise $ Log $ SystemLog $ "Trying to validate email address of user \"" <> login <> "\""
show_error :: Error -> String show_error :: Error -> String

View file

@ -5,7 +5,6 @@ module App.Page.Registration where
import Prelude (Unit, bind, discard, ($), (<<<), (<>), map, between, not) import Prelude (Unit, bind, discard, ($), (<<<), (<>), map, between, not)
import Data.Array as A import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Either (Either(..)) import Data.Either (Either(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
@ -24,7 +23,6 @@ import CSSClasses as C
import Data.String as S import Data.String as S
import App.Type.Email as Email import App.Type.Email as Email
import App.Type.LogMessage import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
import App.DisplayErrors (show_error_login, show_error_email, show_error_password) import App.DisplayErrors (show_error_login, show_error_email, show_error_password)
@ -35,7 +33,7 @@ import App.Validation.Email as E
import App.Validation.Password as P import App.Validation.Password as P
data Output data Output
= MessageToSend ArrayBuffer = AskRegister String (Maybe Email.Email) String
| Log LogMessage | Log LogMessage
data Query a = DoNothing a data Query a = DoNothing a
@ -193,9 +191,7 @@ handleAction = case _ of
SendRegistrationRequest -> do SendRegistrationRequest -> do
{ registrationForm } <- H.get { registrationForm } <- H.get
let { login, email, pass } = registrationForm let { login, email, pass } = registrationForm
message <- H.liftEffect $ AuthD.serialize $ H.raise $ AskRegister login (Just (Email.Email email)) pass
AuthD.MkRegister { login, email: Just (Email.Email email), password: pass }
H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Trying to register (login: " <> login <> ")" H.raise $ Log $ SystemLog $ "Trying to register (login: " <> login <> ")"
show_error :: Error -> String show_error :: Error -> String