-- | `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`. -- | -- | `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.Message.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. -- | -- | Tested features: -- | - registration, mail validation, login, disconnection -- | - domain registration -- | - zone display, RR creation, update and removal -- | -- | Validation: -- | - registration page: login, password, mail -- | - login and password recovery page: TODO -- | - mail verification: TODO -- | - domain list: domain (`label`) is insufficient. -- | -- | TODO: when reading a RR `name`, always make it an FQDN by adding `.netlib.re.`. -- | -- | TODO: remove the FQDN when showing RR names. -- | -- | TODO: application-level heartbeat to avoid disconnections. -- | -- | Untested features: -- | - mail recovery, password change module App.Container where import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure) import Bulma as Bulma import Data.Array as A import Data.Maybe (Maybe(..), maybe) import Data.Either (Either(..)) import Data.Tuple (Tuple(..)) import Halogen as H import Halogen.HTML as HH import Halogen.HTML.Properties as HP import Type.Proxy (Proxy(..)) import Effect.Aff.Class (class MonadAff) import Data.ArrayBuffer.Types (ArrayBuffer) import App.Message.DNSManagerDaemon as DNSManager import App.Message.AuthenticationDaemon as AuthD import App.Log as AppLog import App.WS as WS import App.Page.Authentication as AI import App.Page.Registration as RI import App.Page.MailValidation as MVI import App.Page.Administration as AdminInterface import App.Page.Setup as SetupInterface import App.Page.DomainList as DomainListInterface import App.Page.Zone as ZoneInterface import App.Page.Home as HomeInterface import App.Page.Navigation as NavigationInterface import Web.HTML (window) as HTML import Web.HTML.Window (sessionStorage) as Window import Web.Storage.Storage as Storage import App.Type.Email as Email import App.Type.LogMessage (LogMessage(..)) import App.Type.Pages import CSSClasses as C type Token = String type Login = String type Password = String type LogInfo = Tuple Login Password data Action -- | Handle events from `AuthenticationInterface`. = AuthenticationInterfaceEvent AI.Output -- | Handle events from `RegistrationInterface`. | RegistrationInterfaceEvent RI.Output -- | Handle events from `MailValidationInterface`. | MailValidationInterfaceEvent MVI.Output -- | Handle events from `SetupInterface`. | SetupInterfaceEvent SetupInterface.Output -- | Handle events from `NavigationInterface`. | NavigationInterfaceEvent NavigationInterface.Output -- | Handle events from `AuthenticationDaemonAdminComponent`. | AdministrationEvent AdminInterface.Output -- Administration interface. -- | Handle events from `DomainListComponent`. | DomainListComponentEvent DomainListInterface.Output -- | Handle events from `AuthenticationDaemon` (`authd websocket component`). | AuthenticationDaemonEvent WS.Output -- | Handle events from `DNSManagerDaemon` (`dnsmanagerd websocket component`). | DNSManagerDaemonEvent WS.Output -- | Handle events from `ZoneInterface`. | ZoneInterfaceEvent ZoneInterface.Output -- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets), -- | then return to the home page. | Disconnection -- | 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 -- | `KeepAlive` send a keepalive message to either `authd` or `dnsmanagerd`. | KeepAlive (Either Unit Unit) -- | `ToggleAuthenticated` performs some actions required when a connection or a disconnection occurs. -- | Currently, this handles the navigation bar. | ToggleAuthenticated (Maybe Token) -- | The component's state is composed of: -- | a potential authentication token, -- | the current page, -- | the states of both `DomainListInterface` and `AuthenticationDaemonAdmin` modules, -- | to avoid many useless network exchanges. type State = { token :: Maybe String , current_page :: Page , store_DomainListInterface_state :: Maybe DomainListInterface.State , store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State } -- | The list of child components: log, `WS` twice (once for each ws connection), -- | then all the pages (AuthenticationInterface, RegistrationInterface, MailValidationInterface, -- | HomeInterface, DomainListInterface, ZoneInterface and AdministrationInterface). type ChildSlots = ( log :: AppLog.Slot Unit , ho :: HomeInterface.Slot Unit , ws_auth :: WS.Slot Unit , ws_dns :: WS.Slot Unit , nav :: NavigationInterface.Slot Unit , ai :: AI.Slot Unit , ri :: RI.Slot Unit , mvi :: MVI.Slot Unit , admini :: AdminInterface.Slot Unit , setupi :: SetupInterface.Slot Unit , dli :: DomainListInterface.Slot Unit , zi :: ZoneInterface.Slot Unit ) _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` _nav = Proxy :: Proxy "nav" -- Navigation Interface _ai = Proxy :: Proxy "ai" -- Authentication Interface _ri = Proxy :: Proxy "ri" -- Registration Interface _mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface _admini = Proxy :: Proxy "admini" -- Administration Interface _setupi = Proxy :: Proxy "setupi" -- Setup Interface _dli = Proxy :: Proxy "dli" -- Domain List _zi = Proxy :: Proxy "zi" -- Zone Interface component :: forall q i o m. MonadAff m => H.Component q i o m component = H.mkComponent { initialState , render , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } } -- | Initial state is simple: the user is on the home page, nothing else is stored. initialState :: forall i. i -> State initialState _ = { token: Nothing , current_page: Home , store_DomainListInterface_state: Nothing , store_AuthenticationDaemonAdmin_state: Nothing } render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render state = HH.div_ $ [ render_header , render_nav , case state.current_page of Home -> render_home Authentication -> render_auth_form Registration -> render_registration MailValidation -> render_mail_validation DomainList -> render_domainlist_interface Zone domain -> render_zone domain Setup -> render_setup Administration -> render_authd_admin_interface -- The footer includes logs and both the WS child components. , Bulma.hr , Bulma.columns_ [ Bulma.column_ [ Bulma.h3 "Logs (watch this if something fails! 😅)", render_logs ] , Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ] ] where render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_home = HH.slot_ _ho unit HomeInterface.component unit 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 _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_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_setup = case state.token of Just token -> HH.slot _setupi unit SetupInterface.component token SetupInterfaceEvent Nothing -> Bulma.p "You shouldn't see this page. Reconnect!" render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_mail_validation = HH.slot _mvi unit MVI.component unit MailValidationInterfaceEvent 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 render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_header = HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ] [ HH.div [ HP.classes C.hero_body ] [ HH.div [ HP.classes $ C.container <> C.has_text_centered ] [ HH.p [ HP.classes C.subtitle ] [ HH.strong_ [ HH.u_ [ HH.text "net libre" ]] , HH.text ": providing free domains since 2015!" ] ] ] ] render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_logs = Bulma.container [ HH.slot_ _log unit AppLog.component unit ] render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_WS = HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthenticationDaemonEvent render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_dnsmanager_WS = HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDaemonEvent handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit handleAction = case _ of Routing page -> do -- 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 Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" 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 Setup -> H.liftEffect $ Storage.setItem "current-page" "Setup" sessionstorage Administration -> H.liftEffect $ Storage.setItem "current-page" "Administration" sessionstorage H.modify_ _ { current_page = page } Log message -> H.tell _log unit $ AppLog.Log message ToggleAuthenticated maybe_token -> case maybe_token of Nothing -> H.tell _nav unit $ NavigationInterface.ToggleLogged false Just _ -> H.tell _nav unit $ NavigationInterface.ToggleLogged true KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of Left _ -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {} H.tell _ws_auth unit (WS.ToSend message) Right _ -> do message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkKeepAlive {} H.tell _ws_dns unit (WS.ToSend message) 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) 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 sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage case token of Nothing -> handleAction $ Log $ ErrorLog "no token!" Just t -> do H.modify_ _ { token = Just t } handleAction AuthenticateToDNSManager NavigationInterfaceEvent ev -> case ev of NavigationInterface.Log message -> H.tell _log unit (AppLog.Log message) NavigationInterface.Routing page -> handleAction $ Routing page NavigationInterface.Disconnection -> handleAction $ Disconnection AuthenticationInterfaceEvent ev -> case ev of AI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AI.AskPasswordRecovery e -> case e of Left email -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAskPasswordRecovery { login: Nothing, email: Just (Email.Email email) } H.tell _ws_auth unit (WS.ToSend message) Right login -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAskPasswordRecovery { login: (Just login), email: Nothing } H.tell _ws_auth unit (WS.ToSend message) AI.PasswordRecovery login token pass -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkPasswordRecovery { user: login , password_renew_key: token , new_password: pass } 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) MailValidationInterfaceEvent ev -> case ev of MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) MVI.Log message -> H.tell _log unit (AppLog.Log message) SetupInterfaceEvent ev -> case ev of SetupInterface.DeleteUserAccount -> do handleAction $ Log $ SystemLog "Self termination. 😿" {- no user id, it's self termination -} dns_message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Nothing } auth_message <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Nothing } H.tell _ws_dns unit (WS.ToSend dns_message) H.tell _ws_auth unit (WS.ToSend auth_message) -- Once the user has been deleted, just act like it was just a disconnection. handleAction $ Disconnection SetupInterface.ChangePassword pass -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkModUser { user: Nothing , admin: Nothing , password: Just pass , email: Nothing } H.tell _ws_auth unit (WS.ToSend message) SetupInterface.Log message -> H.tell _log unit (AppLog.Log message) AdministrationEvent ev -> case ev of AdminInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AdminInterface.Log message -> H.tell _log unit (AppLog.Log message) AdminInterface.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s } AdminInterface.AskState -> do state <- H.get H.tell _admini unit (AdminInterface.ProvideState state.store_AuthenticationDaemonAdmin_state) AdminInterface.DeleteUserAccount uid -> do handleAction $ Log $ SystemLog "Remove user account. 😿" {- User id is provided this time, it's (probably) NOT self termination. -} dns_message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Just uid } auth_message <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid } H.tell _ws_dns unit (WS.ToSend dns_message) H.tell _ws_auth unit (WS.ToSend auth_message) AdminInterface.GetOrphanDomains -> do message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetOrphanDomains {} H.tell _ws_dns unit (WS.ToSend message) ZoneInterfaceEvent ev -> case ev of ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) ZoneInterface.Log message -> H.tell _log unit (AppLog.Log message) DomainListComponentEvent ev -> case ev of DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) DomainListInterface.Log message -> H.tell _log unit (AppLog.Log message) DomainListInterface.StoreState s -> H.modify_ _ { store_DomainListInterface_state = Just s } DomainListInterface.ChangePageZoneInterface domain -> do handleAction $ Routing $ Zone domain DomainListInterface.AskState -> do state <- H.get H.tell _dli unit (DomainListInterface.ProvideState state.store_DomainListInterface_state) -- | `authd websocket component` wants to do something. AuthenticationDaemonEvent ev -> case ev of WS.MessageReceived (Tuple _ message) -> do handleAction $ DecodeAuthMessage message WS.WSJustConnected -> do H.tell _ai unit AI.ConnectionIsUp H.tell _admini unit AdminInterface.ConnectionIsUp sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage case token of Nothing -> handleAction $ Log $ ErrorLog "no token!" Just t -> do handleAction $ Log $ SystemLog "Let's authenticate to authd" handleAction $ AuthenticateToAuthd (Left t) WS.WSJustClosed -> do H.tell _ai unit AI.ConnectionIsDown H.tell _admini unit AdminInterface.ConnectionIsDown WS.Log message -> H.tell _log unit (AppLog.Log message) WS.KeepAlive -> handleAction $ KeepAlive $ Left unit DecodeAuthMessage message -> do receivedMessage <- H.liftEffect $ AuthD.deserialize message case receivedMessage of -- Cases where we didn't understand the message. Left err -> do -- handleAction $ Log $ ErrorLog $ -- "received a message that couldn't be decoded. Reason: " <> show err case err of (AuthD.JSONERROR jerr) -> do -- print_json_string messageEvent.message handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr (AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $ "Parsing error: AuthD.UnknownError" <> (show unerr) (AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog "Parsing error: AuthD.UnknownNumber" -- Cases where we understood the message. -- TODO: create a modal to show some of these? Right response -> do case response of (AuthD.GotUser _) -> do handleAction $ Log $ ErrorLog "TODO: received a GotUser message." m@(AuthD.GotUserAdded _) -> do { current_page } <- H.get case current_page of Registration -> do handleAction $ Log $ SuccessLog """ You are now registered, copy the token we sent you by email to finish your registration. """ handleAction $ Routing MailValidation _ -> handleAction $ DispatchAuthDaemonMessage m (AuthD.GotUserEdited u) -> do handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified!" (AuthD.GotUserValidated _) -> do handleAction $ Log $ SuccessLog "User got validated! You can now log in!" handleAction $ Routing Authentication (AuthD.GotUsersList _) -> do handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message." (AuthD.GotPermissionCheck _) -> do handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message." (AuthD.GotPermissionSet _) -> do handleAction $ Log $ ErrorLog "Received a GotPermissionSet message." (AuthD.GotPasswordRecovered _) -> do handleAction $ Log $ SuccessLog "your new password is now valid!" m@(AuthD.GotMatchingUsers _) -> do { current_page } <- H.get case current_page of Administration -> handleAction $ DispatchAuthDaemonMessage 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 _ -> handleAction $ Log $ ErrorLog "received a GotUserDeleted message while not on authd admin page." (AuthD.GotErrorMustBeAuthenticated _) -> do handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message." (AuthD.GotErrorAlreadyUsedLogin _) -> do handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message." (AuthD.GotErrorUserNotFound _) -> do handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message." -- The authentication failed. (AuthD.GotError errmsg) -> do handleAction $ Log $ ErrorLog $ " generic error message: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason (AuthD.GotPasswordRecoverySent _) -> do handleAction $ Log $ SuccessLog $ "Password recovery: email sent!" (AuthD.GotErrorPasswordTooShort _) -> do handleAction $ Log $ ErrorLog "Password too short!" (AuthD.GotErrorMailRequired _) -> do handleAction $ Log $ ErrorLog "Email required!" (AuthD.GotErrorInvalidCredentials _) -> do handleAction $ Log $ ErrorLog "Invalid credentials!" handleAction $ ToggleAuthenticated Nothing (AuthD.GotErrorRegistrationsClosed _) -> do handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator." (AuthD.GotErrorInvalidLoginFormat _) -> do handleAction $ Log $ ErrorLog "Invalid login format!" (AuthD.GotErrorInvalidEmailFormat _) -> do handleAction $ Log $ ErrorLog "Invalid email format!" (AuthD.GotErrorAlreadyUsersInDB _) -> do handleAction $ Log $ ErrorLog "Login already taken!" (AuthD.GotErrorReadOnlyProfileKeys _) -> do handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys!" (AuthD.GotErrorInvalidActivationKey _) -> do handleAction $ Log $ ErrorLog "Invalid activation key!" (AuthD.GotErrorUserAlreadyValidated _) -> do handleAction $ Log $ ErrorLog "User already validated!" (AuthD.GotErrorCannotContactUser _) -> do handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid." (AuthD.GotErrorInvalidRenewKey _) -> do handleAction $ Log $ ErrorLog "Invalid renew key!" -- The authentication was a success! (AuthD.GotToken msg) -> do handleAction $ Log $ SuccessLog $ "Authenticated to authd!" H.modify_ _ { token = Just msg.token } handleAction $ ToggleAuthenticated (Just msg.token) sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window _ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage handleAction AuthenticateToDNSManager (AuthD.GotKeepAlive _) -> do -- handleAction $ Log $ SystemLog $ "KeepAlive!" pure unit pure unit -- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component. DispatchAuthDaemonMessage message -> do { current_page } <- H.get case current_page of Administration -> H.tell _admini unit (AdminInterface.MessageReceived message) _ -> handleAction $ Log $ SystemLog "unexpected message from authd" pure unit Disconnection -> do H.put $ initialState unit -- Remove all stored session data. sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window H.liftEffect $ Storage.clear sessionstorage handleAction $ Routing Home -- | `dnsmanagerd websocket component` wants to do something. DNSManagerDaemonEvent ev -> case ev of WS.MessageReceived (Tuple _ message) -> do handleAction $ DecodeDNSMessage message WS.WSJustConnected -> do handleAction $ Log $ SystemLog "Connection with dnsmanagerd was closed, let's re-authenticate" handleAction AuthenticateToDNSManager H.tell _dli unit DomainListInterface.ConnectionIsUp WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown WS.Log message -> H.tell _log unit (AppLog.Log message) WS.KeepAlive -> handleAction $ KeepAlive $ Right unit -- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`. DecodeDNSMessage message -> do receivedMessage <- H.liftEffect $ DNSManager.deserialize message case receivedMessage of -- Cases where we didn't understand the message. Left err -> do -- handleAction $ Log $ ErrorLog $ -- "received a message that couldn't be decoded. Reason: " <> show err case err of (DNSManager.JSONERROR jerr) -> do handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr (DNSManager.UnknownError unerr) -> handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr) (DNSManager.UnknownNumber ) -> handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber" -- Cases where we understood the message. Right received_msg -> do case received_msg of (DNSManager.MkDomainNotFound _) -> do handleAction $ Log $ ErrorLog $ "DomainNotFound" (DNSManager.MkRRNotFound _) -> do handleAction $ Log $ ErrorLog $ "RRNotFound" (DNSManager.MkInvalidZone _) -> do handleAction $ Log $ ErrorLog $ "InvalidZone" (DNSManager.MkDomainChanged _) -> do handleAction $ Log $ ErrorLog $ "DomainChanged" (DNSManager.MkUnknownZone _) -> do handleAction $ Log $ ErrorLog $ "UnknownZone" (DNSManager.MkDomainList _) -> do handleAction $ Log $ ErrorLog $ "MkDomainList" (DNSManager.MkUnknownUser _) -> do handleAction $ Log $ ErrorLog $ "MkUnknownUser" (DNSManager.MkNoOwnership _) -> do handleAction $ Log $ ErrorLog $ "MkNoOwnership" (DNSManager.MkInsufficientRights _) -> do handleAction $ Log $ ErrorLog $ "You do not have sufficient rights." -- The authentication failed. (DNSManager.MkError errmsg) -> do handleAction $ Log $ ErrorLog $ "reason is: " <> errmsg.reason (DNSManager.MkErrorUserNotLogged _) -> do handleAction $ Log $ ErrorLog $ "The user isn't connected!" handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..." handleAction AuthenticateToDNSManager (DNSManager.MkErrorInvalidToken _) -> do H.modify_ _ { token = Nothing, current_page = Home } handleAction $ Log $ ErrorLog $ "Invalid token! Try re-authenticate." -- TODO: should we disconnect from authd? handleAction $ ToggleAuthenticated Nothing (DNSManager.MkDomainAlreadyExists _) -> do handleAction $ Log $ ErrorLog $ "The domain already exists." m@(DNSManager.MkUnacceptableDomain _) -> do handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)." handleAction $ DispatchDNSMessage m m@(DNSManager.MkAcceptedDomains _) -> do handleAction $ Log $ SuccessLog $ "Received the list of accepted domains!" handleAction $ DispatchDNSMessage m m@(DNSManager.MkLogged _) -> do handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd!" handleAction $ DispatchDNSMessage m m@(DNSManager.MkDomainAdded response) -> do handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain handleAction $ DispatchDNSMessage 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 m@(DNSManager.MkRRAdded response) -> do handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype handleAction $ DispatchDNSMessage m m@(DNSManager.MkGeneratedZoneFile response) -> do handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain handleAction $ DispatchDNSMessage m (DNSManager.MkInvalidDomainName _) -> do handleAction $ Log $ ErrorLog $ "The domain is not valid!" m@(DNSManager.MkDomainDeleted response) -> do handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!" handleAction $ DispatchDNSMessage m m@(DNSManager.MkRRDeleted response) -> do handleAction $ Log $ SuccessLog $ "RR (rrid: '" <> show response.rrid <> "') has been deleted!" handleAction $ DispatchDNSMessage m m@(DNSManager.MkZone _) -> do handleAction $ Log $ SuccessLog $ "Zone received!" handleAction $ DispatchDNSMessage m (DNSManager.MkInvalidRR response) -> do handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors (DNSManager.MkSuccess _) -> do handleAction $ Log $ SuccessLog $ "(generic) Success!" DNSManager.MkOrphanDomainList response -> do handleAction $ Log $ SuccessLog "Received orphan domain list." H.tell _admini unit (AdminInterface.GotOrphanDomainList response.domains) (DNSManager.GotKeepAlive _) -> do -- 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 -- 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. -- Second, depending on the page, actions have to be undertaken. -- For `DomainList`, send a request to `dnsmanagerd` for the list of own domains and acceptable domains. -- For `Zone`, send a request to `dnsmanagerd` for the zone content. state <- H.get case state.current_page, message of -- Home + Logged = page just reloaded. Home, m@(DNSManager.MkLogged _) -> do update_domain_list state m revert_old_page Authentication, m@(DNSManager.MkLogged _) -> do update_domain_list state m -- handleAction $ Log $ SystemLog "go to domain list!" handleAction $ Routing DomainList -- Logged = page just reloaded, but page already changed, no need to do that again. _, m@(DNSManager.MkLogged _) -> do -- handleAction $ Log $ SystemLog "logged to dnsmanagerd, do not change page" update_domain_list state m DomainList, _ -> H.tell _dli unit (DomainListInterface.MessageReceived message) Zone _ , _ -> H.tell _zi unit (ZoneInterface.MessageReceived message) _, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd" pure unit where update_domain_list state m = do case state.store_DomainListInterface_state of Nothing -> do let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m H.modify_ _ { store_DomainListInterface_state = Just new_value } Just _ -> pure unit revert_old_page = do -- Get back to the previous page. sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage case page of Nothing -> pure unit Just "Home" -> handleAction $ Routing Home Just "Authentication" -> handleAction $ Routing Authentication Just "Registration" -> handleAction $ Routing Registration Just "DomainList" -> handleAction $ Routing DomainList Just "MailValidation" -> handleAction $ Routing MailValidation Just "Setup" -> handleAction $ Routing Setup Just "Administration" -> handleAction $ Routing Administration Just "Zone" -> do domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage case domain of Nothing -> handleAction $ Log $ SystemLog "Zone but no domain recorded!! WEIRD" Just zone -> do handleAction $ Log $ SystemLog $ "zone to display: " <> zone handleAction $ Routing (Zone zone) Just p -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p --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