Refactoring of Container: split code into multiple functions (WIP).
This commit is contained in:
parent
833f1024ef
commit
999d801eaf
1 changed files with 428 additions and 441 deletions
|
|
@ -43,7 +43,7 @@
|
|||
-- | - mail recovery
|
||||
module App.Container where
|
||||
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure, (+), (&&), (>))
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure, (+), (&&), (>), (<<<))
|
||||
|
||||
import Web as Web
|
||||
|
||||
|
|
@ -113,10 +113,8 @@ max_keepalive = 60 :: Int
|
|||
wsURLauthd = "wss://www.netlib.re/ws/authd" :: String
|
||||
wsURLdnsmanagerd = "wss://www.netlib.re/ws/dnsmanagerd" :: String
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
|
||||
| EventPageAuthentication PageAuthentication.Output
|
||||
data PageEvent
|
||||
= EventPageAuthentication PageAuthentication.Output
|
||||
| EventPageRegistration PageRegistration.Output
|
||||
| EventPageMailValidation PageMailValidation.Output
|
||||
| EventPageSetup PageSetup.Output
|
||||
|
|
@ -126,9 +124,19 @@ data Action
|
|||
| EventPageZone PageZone.Output
|
||||
| EventPageMigration PageMigration.Output
|
||||
|
||||
| EventWSAuthenticationDaemon WS.Output
|
||||
data NetworkEvent
|
||||
= EventWSAuthenticationDaemon WS.Output
|
||||
| EventWSDNSmanagerd WS.Output
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
|
||||
-- | When an event occurs on a page (including the navigation bar).
|
||||
| EventOnPage PageEvent
|
||||
|
||||
-- | When an event occurs on the network (web-socket related events).
|
||||
| EventOnNetwork NetworkEvent
|
||||
|
||||
-- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
|
||||
-- | then return to the home page.
|
||||
| Disconnection
|
||||
|
|
@ -136,31 +144,9 @@ data Action
|
|||
-- | Reconnection to both `authd` and `dnsmanagerd`.
|
||||
| Reconnection
|
||||
|
||||
-- | Try to authenticate the user to `dnsmanagerd`.
|
||||
| AuthenticateToDNSManager
|
||||
|
||||
| AuthenticateToAuthd (Either Token LogInfo)
|
||||
|
||||
-- | Change the displayed page.
|
||||
| Routing Page
|
||||
|
||||
-- | `DecodeDNSMessage`: decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`,
|
||||
-- | then provide it to `DispatchDNSMessage`.
|
||||
| DecodeDNSMessage ArrayBuffer
|
||||
|
||||
-- | `DispatchDNSMessage`: send the DNS message to the right component.
|
||||
-- | The DNS message (from `dnsmanagerd`) was first received and decoded through the `DecodeDNSMessage` action.
|
||||
| DispatchDNSMessage DNSManager.AnswerMessage
|
||||
|
||||
-- | `DecodeAuthMessage`: decode received `authd` messages into ``, then provide
|
||||
-- | Then, the message is provided to the `DispatchAuthDaemonMessage` action (when needed).
|
||||
| DecodeAuthMessage ArrayBuffer
|
||||
|
||||
-- | DispatchAuthDaemonMessage: an auth daemon message (from `authd`) was received and decoded through the
|
||||
-- | `DecodeAuthMessage` action.
|
||||
-- | The message is provided to the right component.
|
||||
| DispatchAuthDaemonMessage AuthD.AnswerMessage
|
||||
|
||||
-- | Log message (through the Log component).
|
||||
| Log LogMessage
|
||||
|
||||
|
|
@ -295,7 +281,6 @@ render state
|
|||
]
|
||||
]
|
||||
where
|
||||
|
||||
website_hero :: forall w i. HH.HTML w i
|
||||
website_hero =
|
||||
HH.section [ HP.classes [C.hero, C.is_info, C.is_small] ]
|
||||
|
|
@ -335,10 +320,10 @@ render state
|
|||
then HH.div_ []
|
||||
else Web.btn_ [C.is_large, C.is_danger] "You have been disconnected. Click here to reconnect." Reconnection
|
||||
render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_WS = HH.slot _ws_auth unit WS.component (Tuple wsURLauthd "authd") EventWSAuthenticationDaemon
|
||||
render_auth_WS = HH.slot _ws_auth unit WS.component (Tuple wsURLauthd "authd") (EventOnNetwork <<< EventWSAuthenticationDaemon)
|
||||
|
||||
render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component (Tuple wsURLdnsmanagerd "dnsmanagerd") EventWSDNSmanagerd
|
||||
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component (Tuple wsURLdnsmanagerd "dnsmanagerd") (EventOnNetwork <<< EventWSDNSmanagerd)
|
||||
|
||||
render_notifications =
|
||||
case state.notif of
|
||||
|
|
@ -349,24 +334,24 @@ render state
|
|||
render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_home = HH.slot_ _ho unit PageHome.component unit
|
||||
render_domainlist_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_domainlist_interface = HH.slot _dli unit PageDomainList.component unit EventPageDomainList
|
||||
render_domainlist_interface = HH.slot _dli unit PageDomainList.component unit (EventOnPage <<< EventPageDomainList)
|
||||
render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_form = HH.slot _ai unit PageAuthentication.component unit EventPageAuthentication
|
||||
render_auth_form = HH.slot _ai unit PageAuthentication.component unit (EventOnPage <<< EventPageAuthentication)
|
||||
render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_registration = HH.slot _ri unit PageRegistration.component unit EventPageRegistration
|
||||
render_registration = HH.slot _ri unit PageRegistration.component unit (EventOnPage <<< EventPageRegistration)
|
||||
render_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_setup = case state.user_data of
|
||||
Just user_data -> HH.slot _setupi unit PageSetup.component user_data EventPageSetup
|
||||
Just user_data -> HH.slot _setupi unit PageSetup.component user_data (EventOnPage <<< EventPageSetup)
|
||||
Nothing -> Web.p "You shouldn't see this page. Please, reconnect."
|
||||
render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_mail_validation = HH.slot _mvi unit PageMailValidation.component unit EventPageMailValidation
|
||||
render_mail_validation = HH.slot _mvi unit PageMailValidation.component unit (EventOnPage <<< EventPageMailValidation)
|
||||
render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_zone domain = HH.slot _zi unit PageZone.component domain EventPageZone
|
||||
render_zone domain = HH.slot _zi unit PageZone.component domain (EventOnPage <<< EventPageZone)
|
||||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_authd_admin_interface = HH.slot _admini unit PageAdministration.component unit EventPageAdministration
|
||||
render_authd_admin_interface = HH.slot _admini unit PageAdministration.component unit (EventOnPage <<< EventPageAdministration)
|
||||
|
||||
render_migration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_migration = HH.slot _mi unit PageMigration.component unit EventPageMigration
|
||||
render_migration = HH.slot _mi unit PageMigration.component unit (EventOnPage <<< EventPageMigration)
|
||||
|
||||
render_legal_notice :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_legal_notice
|
||||
|
|
@ -375,7 +360,7 @@ render state
|
|||
]
|
||||
|
||||
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_nav = HH.slot _nav unit PageNavigation.component unit EventPageNavigation
|
||||
render_nav = HH.slot _nav unit PageNavigation.component unit (EventOnPage <<< EventPageNavigation)
|
||||
|
||||
render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_logs = Web.container [ HH.slot_ _log unit AppLog.component unit ]
|
||||
|
|
@ -477,30 +462,35 @@ handleAction = case _ of
|
|||
else do -- handleAction $ Log $ SystemLog "KeepAlive message from WS while connection was closed."
|
||||
pure unit
|
||||
|
||||
AuthenticateToAuthd v -> case v of
|
||||
Left token -> do
|
||||
handleAction $ Log $ SystemLog "Authenticate to authd with a token."
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
EventOnPage page_event -> act_on_page_event page_event
|
||||
EventOnNetwork network_event -> act_on_network_event network_event
|
||||
|
||||
AuthenticateToDNSManager -> do
|
||||
state <- H.get
|
||||
case state.token of
|
||||
Just token -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
Nothing -> do
|
||||
AddNotif n -> H.modify_ _ { notif = n }
|
||||
CloseNotif -> H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Reconnection -> do
|
||||
H.tell _ws_auth unit WS.Connect
|
||||
H.tell _ws_dns unit WS.Connect
|
||||
H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Disconnection -> do
|
||||
handleAction $ Routing Home
|
||||
|
||||
-- Preserve the state of the connection (authd and dnsmanagerd).
|
||||
old_state <- H.get
|
||||
H.put $ initialState unit
|
||||
H.modify_ _ { are_we_connected_to_authd = old_state.are_we_connected_to_authd
|
||||
, are_we_connected_to_dnsmanagerd = old_state.are_we_connected_to_dnsmanagerd
|
||||
}
|
||||
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
|
||||
-- Remove all stored session data.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
handleAction AuthenticateToDNSManager
|
||||
H.liftEffect $ Storage.clear sessionstorage
|
||||
|
||||
act_on_page_event :: forall o monad. MonadAff monad => PageEvent -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
act_on_page_event page_event = case page_event of
|
||||
EventPageNavigation ev -> case ev of
|
||||
PageNavigation.Log message -> handleAction $ Log message
|
||||
PageNavigation.Routing page -> handleAction $ Routing page
|
||||
|
|
@ -523,7 +513,7 @@ handleAction = case _ of
|
|||
, new_password: pass }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
PageAuthentication.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
|
||||
PageAuthentication.AuthenticateToAuthd v -> authenticate_to_authd (Right v)
|
||||
PageAuthentication.Log message -> handleAction $ Log message
|
||||
PageAuthentication.UserLogin login -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
|
|
@ -564,7 +554,6 @@ handleAction = case _ of
|
|||
, email: Nothing
|
||||
}
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
PageSetup.Log message -> handleAction $ Log message
|
||||
|
||||
EventPageAdministration ev -> case ev of
|
||||
|
|
@ -648,10 +637,20 @@ handleAction = case _ of
|
|||
state <- H.get
|
||||
H.tell _dli unit (PageDomainList.ProvideState state.childstates.domainlist)
|
||||
|
||||
EventPageMigration ev -> case ev of
|
||||
PageMigration.AskNewEmailAddress email -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddress { email }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageMigration.AskNewEmailAddressTokenAddress token -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddressToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageMigration.Log message -> handleAction $ Log message
|
||||
|
||||
act_on_network_event :: forall o monad. MonadAff monad => NetworkEvent -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
act_on_network_event network_event = case network_event of
|
||||
-- | `authd websocket component` wants to do something.
|
||||
EventWSAuthenticationDaemon ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeAuthMessage message
|
||||
|
||||
WS.MessageReceived (Tuple _ message) -> decode_message_from_authd message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_authd = true }
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
|
|
@ -660,19 +659,35 @@ handleAction = case _ of
|
|||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
||||
handleAction $ AuthenticateToAuthd (Left t)
|
||||
|
||||
authenticate_to_authd (Left t)
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from authd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
|
||||
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
DecodeAuthMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ AuthD.deserialize message
|
||||
-- | `dnsmanagerd websocket component` wants to do something.
|
||||
EventWSDNSmanagerd ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> decode_message_from_dnsmanagerd message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = true }
|
||||
authenticate_to_dnsmanagerd
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
|
||||
-- | Decode received `authd` messages into ``, then provide
|
||||
-- | The message can be forwarded to a component when needed.
|
||||
decode_message_from_authd :: forall o monad. MonadAff monad => ArrayBuffer -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
decode_message_from_authd arraybuffer = do
|
||||
receivedMessage <- H.liftEffect $ AuthD.deserialize arraybuffer
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
|
|
@ -703,7 +718,7 @@ handleAction = case _ of
|
|||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> forward m
|
||||
(AuthD.GotUserEdited u) -> do
|
||||
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified."
|
||||
handleAction $ AddNotif $ GoodNotification "Modification done."
|
||||
|
|
@ -724,18 +739,18 @@ handleAction = case _ of
|
|||
"""
|
||||
m@(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SuccessLog "your new password is now valid."
|
||||
handleAction $ DispatchAuthDaemonMessage m
|
||||
forward m
|
||||
handleAction $ AddNotif $ GoodNotification "Your new password is now valid."
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
Administration -> forward m
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotMatchingUsers message while not on authd admin page."
|
||||
m@(AuthD.GotUserDeleted _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
Administration -> forward m
|
||||
_ -> pure unit
|
||||
(AuthD.GotNewEmailTokenSent _) -> do
|
||||
handleAction $ Log $ SuccessLog "New email address is pending. Please enter validation token."
|
||||
|
|
@ -768,7 +783,7 @@ handleAction = case _ of
|
|||
m@(AuthD.GotPasswordRecoverySent _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
|
||||
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
|
||||
handleAction $ DispatchAuthDaemonMessage m
|
||||
forward m
|
||||
(AuthD.GotErrorPasswordTooShort _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too short."
|
||||
handleAction $ AddNotif $ BadNotification "Your password is too short."
|
||||
|
|
@ -820,7 +835,7 @@ handleAction = case _ of
|
|||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
||||
|
||||
handleAction AuthenticateToDNSManager
|
||||
authenticate_to_dnsmanagerd
|
||||
|
||||
-- In case the account doesn't have a valid email address, the user
|
||||
-- shouldn't be able to do anything else than to add their address.
|
||||
|
|
@ -830,18 +845,10 @@ handleAction = case _ of
|
|||
|
||||
(AuthD.GotKeepAlive _) -> pure unit
|
||||
pure unit
|
||||
|
||||
EventPageMigration ev -> case ev of
|
||||
PageMigration.AskNewEmailAddress email -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddress { email }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageMigration.AskNewEmailAddressTokenAddress token -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddressToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageMigration.Log message -> handleAction $ Log message
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
DispatchAuthDaemonMessage message -> do
|
||||
where
|
||||
-- | Send a received authentication daemon message `App.Message.AuthenticationDaemon.AnswerMessage` to a component.
|
||||
-- forward :: AuthD.AnswerMessage
|
||||
forward message = do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Authentication -> H.tell _ai unit (PageAuthentication.MessageReceived message)
|
||||
|
|
@ -849,48 +856,11 @@ handleAction = case _ of
|
|||
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
||||
pure unit
|
||||
|
||||
AddNotif n -> H.modify_ _ { notif = n }
|
||||
CloseNotif -> H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Reconnection -> do
|
||||
H.tell _ws_auth unit WS.Connect
|
||||
H.tell _ws_dns unit WS.Connect
|
||||
H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Disconnection -> do
|
||||
handleAction $ Routing Home
|
||||
|
||||
-- Preserve the state of the connection (authd and dnsmanagerd).
|
||||
old_state <- H.get
|
||||
H.put $ initialState unit
|
||||
H.modify_ _ { are_we_connected_to_authd = old_state.are_we_connected_to_authd
|
||||
, are_we_connected_to_dnsmanagerd = old_state.are_we_connected_to_dnsmanagerd
|
||||
}
|
||||
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
|
||||
-- Remove all stored session data.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
H.liftEffect $ Storage.clear sessionstorage
|
||||
|
||||
-- | `dnsmanagerd websocket component` wants to do something.
|
||||
EventWSDNSmanagerd ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeDNSMessage message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = true }
|
||||
handleAction AuthenticateToDNSManager
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
|
||||
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
-- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`.
|
||||
DecodeDNSMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize message
|
||||
-- | Decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`.
|
||||
-- | Messages can be forwarded to components.
|
||||
decode_message_from_dnsmanagerd :: forall o monad. MonadAff monad => ArrayBuffer -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
decode_message_from_dnsmanagerd arraybuffer = do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize arraybuffer
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
|
|
@ -918,7 +888,7 @@ handleAction = case _ of
|
|||
handleAction $ AddNotif $ BadNotification $ "The domain zone is invalid."
|
||||
m@(DNSManager.MkDomainChanged response) -> do
|
||||
handleAction $ Log $ SystemLog $ "Domain \"" <> response.domain.name <> "\" has been updated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
(DNSManager.MkUnknownZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain zone is unknown."
|
||||
|
|
@ -938,7 +908,7 @@ handleAction = case _ of
|
|||
(DNSManager.MkErrorUserNotLogged _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The user isn't connected."
|
||||
handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..."
|
||||
handleAction AuthenticateToDNSManager
|
||||
authenticate_to_dnsmanagerd
|
||||
(DNSManager.MkErrorInvalidToken _) -> do
|
||||
H.modify_ _ { token = Nothing, current_page = Home }
|
||||
handleAction $ Log $ ErrorLog $ "Invalid token. Try re-authenticate."
|
||||
|
|
@ -949,33 +919,33 @@ handleAction = case _ of
|
|||
handleAction $ AddNotif $ BadNotification $ "The domain already exists."
|
||||
m@(DNSManager.MkUnacceptableDomain _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkAcceptedDomains _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received the list of accepted domains."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkLogged logged_message) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd."
|
||||
H.tell _nav unit $ PageNavigation.ToggleAdmin logged_message.admin
|
||||
handleAction $ AddNotif $ GoodNotification "You are now authenticated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkDomainAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
|
||||
handleAction $ AddNotif $ GoodNotification $ "You have just registered the domain \""
|
||||
<> response.domain <> "\". 🥳 You can now manage it (click on its button)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
(DNSManager.MkRRReadOnly response) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Trying to modify a read-only resource. "
|
||||
<> "domain: " <> response.domain
|
||||
<> "resource rrid: " <> show response.rr.rrid
|
||||
m@(DNSManager.MkRRUpdated _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource updated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkRRAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkGeneratedZoneFile response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
(DNSManager.MkInvalidDomainName _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain is not valid."
|
||||
handleAction $ AddNotif $ BadNotification $ "Invalid domain name."
|
||||
|
|
@ -983,13 +953,13 @@ handleAction = case _ of
|
|||
let successlog = "The domain \"" <> response.domain <> "\" has been deleted."
|
||||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkRRDeleted response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource record (rrid: \"" <> show response.rrid <> "\") has been deleted."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
m@(DNSManager.MkZone _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Zone received."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
forward m
|
||||
(DNSManager.MkInvalidRR response) -> do
|
||||
let errorlog = "Invalid resource record: " <> A.intercalate ", " response.errors
|
||||
handleAction $ Log $ ErrorLog errorlog
|
||||
|
|
@ -1006,12 +976,9 @@ handleAction = case _ of
|
|||
-- handleAction $ Log $ SystemLog $ "KeepAlive."
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | Send a received DNS manager message to a component.
|
||||
-- | TODO: in case the message is a `logged` message, it means that the connection has been reset, and should be
|
||||
-- | handled no matter the actual page we're on.
|
||||
DispatchDNSMessage message -> do
|
||||
|
||||
where
|
||||
-- | Send a received dnsmanager daemon message `App.Message.DNSManagerDaemon.AnswerMessage` to a component.
|
||||
forward message = do
|
||||
-- The message `Logged` can be received after a re-connection (typically, after a page reload).
|
||||
-- This is an hint, and the application should do a series of actions based on this.
|
||||
-- First, we should check if there is a "current page", if so, switch page.
|
||||
|
|
@ -1036,7 +1003,7 @@ handleAction = case _ of
|
|||
Zone _ , _ -> H.tell _zi unit (PageZone.MessageReceived message)
|
||||
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
||||
pure unit
|
||||
where
|
||||
|
||||
update_domain_list state m = do
|
||||
case state.childstates.domainlist of
|
||||
Nothing -> do
|
||||
|
|
@ -1044,6 +1011,7 @@ handleAction = case _ of
|
|||
H.modify_ _ { childstates { domainlist = Just new_value } }
|
||||
Just _ -> pure unit
|
||||
|
||||
revert_old_page :: forall o monad. MonadAff monad => H.HalogenM State Action ChildSlots o monad Unit
|
||||
revert_old_page = do
|
||||
-- Get back to the previous page.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
|
|
@ -1067,11 +1035,30 @@ handleAction = case _ of
|
|||
handleAction $ Routing (Zone zone)
|
||||
Just p -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p
|
||||
|
||||
-- | Try to authenticate the user to `dnsmanagerd`.
|
||||
authenticate_to_dnsmanagerd :: forall o monad. MonadAff monad => H.HalogenM State Action ChildSlots o monad Unit
|
||||
authenticate_to_dnsmanagerd = do
|
||||
state <- H.get
|
||||
case state.token of
|
||||
Just token -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
Nothing -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
authenticate_to_dnsmanagerd
|
||||
|
||||
--print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
|
||||
--print_json_string arraybuffer = do
|
||||
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
|
||||
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
|
||||
-- H.raise $ Log $ ErrorLog $ case (value) of
|
||||
-- Left _ -> "Cannot even fromTypedIPC the message."
|
||||
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
|
||||
authenticate_to_authd :: forall o monad.
|
||||
MonadAff monad => (Either Token LogInfo) -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
authenticate_to_authd v = case v of
|
||||
Left token -> do
|
||||
handleAction $ Log $ SystemLog "Authenticate to authd with a token."
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue