1032 lines
51 KiB
Text
1032 lines
51 KiB
Text
-- | `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
|
|
-- | - mail verification
|
|
-- | - domain list: domain (`label`) is insufficient.
|
|
-- |
|
|
-- | TODO: when reading a RR `name`, always make it an FQDN by adding `<user-domain>.netlib.re.`.
|
|
-- |
|
|
-- | TODO: remove the FQDN when showing RR names.
|
|
-- |
|
|
-- | 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.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Either (Either(..))
|
|
import Data.Foldable (for_)
|
|
import Data.Maybe (Maybe(..), maybe)
|
|
import Data.Tuple (Tuple(..))
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Effect (Effect)
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Properties as HP
|
|
import Type.Proxy (Proxy(..))
|
|
import Web.HTML (HTMLElement)
|
|
|
|
import App.Message.DNSManagerDaemon as DNSManager
|
|
import App.Message.AuthenticationDaemon as AuthD
|
|
|
|
import App.Log as AppLog
|
|
import App.WS as WS
|
|
|
|
import Scroll (scrollToTop)
|
|
|
|
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.Migration as MigrationInterface
|
|
import App.Page.Navigation as NavigationInterface
|
|
|
|
import App.Text.Explanations as Explanations
|
|
|
|
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
|
|
|
|
newtype RawHTML = RawHTML String
|
|
|
|
-- | Since Halogen doesn't have a function to put raw HTML into a page, we have to improvise.
|
|
-- | This foreign function adds raw HTML into a page, given a parent node reference.
|
|
foreign import unsafeSetInnerHTML :: HTMLElement -> RawHTML -> Effect Unit
|
|
|
|
-- | A keepalive message is sent every 30 seconds to keep the connection open.
|
|
-- | `max_keepalive` represents the maximum number of keepalive messages
|
|
-- | before closing the connections due to inactivity.
|
|
-- | Current limit is 30 minutes (`max_keepalive` = 60, 60 * 30 seconds = 30 minutes).
|
|
max_keepalive = 60 :: Int
|
|
|
|
data Action
|
|
= Initialize
|
|
|
|
-- | 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
|
|
|
|
-- | Handle events from `MigrationInterface`.
|
|
| MigrationInterfaceEvent MigrationInterface.Output
|
|
|
|
-- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
|
|
-- | then return to the home page.
|
|
| Disconnection
|
|
|
|
-- | 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
|
|
|
|
-- | `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)
|
|
|
|
-- | Add a main notification, at the top of the page.
|
|
| AddNotif Notification
|
|
|
|
-- | Close the main notification, at the top of the page.
|
|
| CloseNotif
|
|
|
|
-- | In order to keep the websocket overhead to a minimum, unused connections are
|
|
-- | closed automatically by the client. In practice, this is handled by a simple counter
|
|
-- | incremented each time a KeepAlive message is sent.
|
|
| ResetKeepAliveCounter
|
|
|
|
data Notification = NoNotification | GoodNotification String | BadNotification String
|
|
|
|
-- | 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
|
|
, user_data :: Maybe (Tuple (Maybe Email.Email) (Maybe Email.Email))
|
|
, current_page :: Page
|
|
, store_DomainListInterface_state :: Maybe DomainListInterface.State
|
|
, store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State
|
|
, notif :: Notification
|
|
, login :: Maybe String
|
|
, keepalive_counter :: Int
|
|
, are_we_connected_to_authd :: Boolean
|
|
, are_we_connected_to_dnsmanagerd :: Boolean
|
|
}
|
|
|
|
-- | 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
|
|
, mi :: MigrationInterface.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
|
|
_mi = Proxy :: Proxy "mi" -- Migration 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 { initialize = Just Initialize
|
|
, 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
|
|
, user_data: Nothing
|
|
, current_page: Home
|
|
, store_DomainListInterface_state: Nothing
|
|
, store_AuthenticationDaemonAdmin_state: Nothing
|
|
, notif: NoNotification
|
|
, login: Nothing
|
|
, keepalive_counter: 0
|
|
, are_we_connected_to_authd: false
|
|
, are_we_connected_to_dnsmanagerd: false
|
|
}
|
|
|
|
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
|
render state
|
|
= HH.div_ $
|
|
[ render_header
|
|
, render_nav
|
|
, reconnection_bar
|
|
, render_notifications
|
|
, migration_warning_on_email_address
|
|
, 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
|
|
Migration -> render_migration
|
|
LegalNotice -> render_legal_notice
|
|
-- 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_ [ Bulma.level
|
|
[ render_auth_WS
|
|
, render_dnsmanager_WS
|
|
, legal_notice_btn
|
|
, paypal_btn
|
|
] [] ]
|
|
]
|
|
]
|
|
where
|
|
|
|
paypal_btn :: forall w i. HH.HTML w i
|
|
paypal_btn = HH.div [ HP.ref ref_paypal_div ] []
|
|
|
|
migration_warning_on_email_address :: forall w. HH.HTML w Action
|
|
migration_warning_on_email_address =
|
|
case state.user_data of
|
|
Just (Tuple Nothing _) ->
|
|
HH.div [HP.classes [C.notification, C.is_warning]]
|
|
[ Bulma.p """
|
|
⚠️ MIGRATION (FR): veuillez indiquer une adresse email pour votre compte.
|
|
Tout compte sans adresse email sera supprimé sous 6 mois.
|
|
"""
|
|
, Bulma.p """
|
|
⚠️ MIGRATION (EN): please associate an email address to your account.
|
|
Accounts without a validated email address will be discarded within 6 months.
|
|
"""
|
|
]
|
|
_ -> HH.text ""
|
|
|
|
legal_notice_btn = Bulma.btn_ [] "Legal notice" (Routing LegalNotice)
|
|
reconnection_bar :: forall w. HH.HTML w Action
|
|
reconnection_bar =
|
|
if (state.are_we_connected_to_authd && state.are_we_connected_to_dnsmanagerd)
|
|
then HH.div_ []
|
|
else Bulma.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 "wss://beta.netlib.re/ws/authd" "authd") AuthenticationDaemonEvent
|
|
|
|
render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component (Tuple "wss://beta.netlib.re/ws/dnsmanagerd" "dnsmanagerd") DNSManagerDaemonEvent
|
|
|
|
render_notifications =
|
|
case state.notif of
|
|
NoNotification -> HH.div_ []
|
|
GoodNotification v -> Bulma.box [Bulma.notification_success v CloseNotif]
|
|
BadNotification v -> Bulma.box [Bulma.notification_danger v CloseNotif]
|
|
|
|
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.user_data of
|
|
Just user_data -> HH.slot _setupi unit SetupInterface.component user_data SetupInterfaceEvent
|
|
Nothing -> Bulma.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 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_migration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
render_migration = HH.slot _mi unit MigrationInterface.component unit MigrationInterfaceEvent
|
|
|
|
render_legal_notice :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
render_legal_notice
|
|
= Bulma.section_small [ Explanations.legal_notice
|
|
, Bulma.btn_ [C.is_large, C.margin_top 3, C.is_info] "Home page" (Routing Home)
|
|
]
|
|
|
|
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 ]
|
|
|
|
ref_paypal_div :: H.RefLabel
|
|
ref_paypal_div = H.RefLabel "paypal-div"
|
|
|
|
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
|
|
handleAction = case _ of
|
|
Initialize -> do
|
|
handleAction $ Log $ SystemLog "Hello, welcome to this application. 🥳"
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
|
case token of
|
|
Nothing -> revert_old_page
|
|
Just _ -> pure unit -- Authentication will happen when web sockets are up!
|
|
|
|
login_name <- H.liftEffect $ Storage.getItem "user-login" sessionstorage
|
|
case login_name of
|
|
Nothing -> pure unit
|
|
Just name -> do H.modify_ _ { login = Just name }
|
|
H.tell _nav unit $ NavigationInterface.TellLogin (Just name)
|
|
|
|
-- Render the paypal button.
|
|
-- How it works: it takes all nodes in the DOM with the reference `ref_paypal_div` ("paypal-div")
|
|
-- then it replaces the inner HTML by the provided code.
|
|
parentElem <- H.getHTMLElementRef ref_paypal_div
|
|
for_ parentElem \el -> do
|
|
H.liftEffect $ unsafeSetInnerHTML el (RawHTML """
|
|
<form action="https://www.paypal.com/donate" method="post" target="_blank">
|
|
<input type="hidden" name="business" value="YBYNZTGHQK5VA" />
|
|
<input type="hidden" name="no_recurring" value="0" />
|
|
<input type="hidden" name="currency_code" value="EUR" />
|
|
<input type="image" src="/paypal.gif" border="0" name="submit"
|
|
title="PayPal - The safer, easier way to pay online!" alt="Donate with PayPal button" />
|
|
</form>
|
|
""")
|
|
-- The following line was replaced, the image is now hosted on our server, don't let Paypal track our users.
|
|
-- <input type="image" src="https://www.paypalobjects.com/en_US/i/btn/btn_donate_LG.gif" border="0" name="submit" title="PayPal - The safer, easier way to pay online!" alt="Donate with PayPal button" />
|
|
-- Last line was removed since it's just a way for Paypal to track users for stats. We don't need that.
|
|
-- <img alt="" border="0" src="https://www.paypal.com/en_FR/i/scr/pixel.gif" width="1" height="1" />
|
|
|
|
Routing page -> do
|
|
-- Each time the user change load a new page, the counter gets reset
|
|
-- since it proves they are still active.
|
|
H.modify_ _ { keepalive_counter = 0 }
|
|
H.liftEffect scrollToTop
|
|
-- Store the current page we are on and restore it when we reload.
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
H.liftEffect $ Storage.setItem "current-page" (case page of
|
|
Zone _ -> "Zone"
|
|
_ -> show page) sessionstorage
|
|
|
|
_ <- case page of
|
|
Zone zone -> H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
|
|
_ -> pure unit
|
|
|
|
H.modify_ _ { current_page = page }
|
|
|
|
-- Finally, when changing page, the notification should be discarded.
|
|
handleAction CloseNotif
|
|
|
|
Log message -> do
|
|
_ <- case message of
|
|
UnableToSend err -> handleAction $ AddNotif $ BadNotification err
|
|
ErrorLog err -> handleAction $ AddNotif $ BadNotification err
|
|
_ -> pure unit
|
|
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
|
|
|
|
ResetKeepAliveCounter -> H.modify_ _ { keepalive_counter = 0 }
|
|
KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of
|
|
Left _ -> do
|
|
state <- H.get
|
|
if state.are_we_connected_to_authd
|
|
then if (state.keepalive_counter + 1) > max_keepalive
|
|
then do handleAction $ Log $ SystemLog "Closing the websockets due to inactivity."
|
|
H.tell _ws_auth unit (WS.CloseConnection)
|
|
H.tell _ws_dns unit (WS.CloseConnection)
|
|
H.modify_ _ { are_we_connected_to_authd = false
|
|
, are_we_connected_to_dnsmanagerd = false
|
|
--, are_we_closed_due_to_inactiviy = true
|
|
}
|
|
else do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {}
|
|
H.tell _ws_auth unit (WS.ToSendKeepAlive message)
|
|
H.modify_ _ { keepalive_counter = state.keepalive_counter + 1 }
|
|
else do -- handleAction $ Log $ SystemLog "KeepAlive message from WS while connection was closed."
|
|
pure unit
|
|
|
|
Right _ -> do
|
|
state <- H.get
|
|
if state.are_we_connected_to_dnsmanagerd
|
|
then do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkKeepAlive {}
|
|
H.tell _ws_dns unit (WS.ToSendKeepAlive message)
|
|
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)
|
|
|
|
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 -> pure unit
|
|
Just t -> do
|
|
H.modify_ _ { token = Just t }
|
|
handleAction AuthenticateToDNSManager
|
|
|
|
NavigationInterfaceEvent ev -> case ev of
|
|
NavigationInterface.Log message -> handleAction $ 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 -> handleAction $ Log message
|
|
AI.UserLogin login -> do
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
_ <- H.liftEffect $ Storage.setItem "user-login" login sessionstorage
|
|
H.modify_ _ { login = Just login }
|
|
H.tell _nav unit $ NavigationInterface.TellLogin (Just login)
|
|
|
|
RegistrationInterfaceEvent ev -> case ev of
|
|
RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
|
RI.Log message -> handleAction $ Log message
|
|
|
|
MailValidationInterfaceEvent ev -> case ev of
|
|
MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
|
MVI.Log message -> handleAction $ 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.ChangeEmailAddress -> handleAction $ Routing Migration
|
|
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 -> handleAction $ Log message
|
|
|
|
AdministrationEvent ev -> case ev of
|
|
AdminInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
|
AdminInterface.Log message -> handleAction $ 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 -> handleAction $ Log message
|
|
ZoneInterface.ToDomainList -> handleAction $ Routing DomainList
|
|
|
|
DomainListComponentEvent ev -> case ev of
|
|
DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
|
DomainListInterface.Log message -> handleAction $ 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) -> handleAction $ DecodeAuthMessage message
|
|
|
|
WS.WSJustConnected -> do
|
|
H.modify_ _ { are_we_connected_to_authd = true }
|
|
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
|
|
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
|
handleAction $ AuthenticateToAuthd (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
|
|
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
|
|
let successlog = """
|
|
You are now registered. Please verify your email address with the token we have sent you.
|
|
"""
|
|
handleAction $ Log $ SuccessLog successlog
|
|
handleAction $ AddNotif $ GoodNotification successlog
|
|
handleAction $ Routing MailValidation
|
|
_ -> handleAction $ DispatchAuthDaemonMessage m
|
|
(AuthD.GotUserEdited u) -> do
|
|
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified."
|
|
handleAction $ AddNotif $ GoodNotification "Modification done."
|
|
(AuthD.GotUserValidated _) -> do
|
|
handleAction $ Log $ SuccessLog "User got validated. You can now log in."
|
|
handleAction $ Routing Authentication
|
|
handleAction $ AddNotif $ GoodNotification "User got validated. You can now log in."
|
|
(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.GotErrorEmailAddressNotValidated _) -> do
|
|
handleAction $ Log $ ErrorLog """
|
|
Cannot authenticate: your email address hasn't been validated.
|
|
Please check your email inbox.
|
|
"""
|
|
m@(AuthD.GotPasswordRecovered _) -> do
|
|
handleAction $ Log $ SuccessLog "your new password is now valid."
|
|
handleAction $ DispatchAuthDaemonMessage 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
|
|
_ -> 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
|
|
_ -> pure unit
|
|
(AuthD.GotNewEmailTokenSent _) -> do
|
|
handleAction $ Log $ SuccessLog "New email address is pending. Please enter validation token."
|
|
(AuthD.GotNewEmailAddressValidated msg) -> do
|
|
handleAction $ Log $ SuccessLog "New email address has been validated."
|
|
handleAction $ AddNotif $ GoodNotification "Your new email address is now valid."
|
|
H.modify_ _ { user_data = Just (Tuple (Just msg.email) Nothing) }
|
|
handleAction $ Routing DomainList
|
|
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
|
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
|
|
handleAction $ AddNotif $ BadNotification "Sorry, you must be authenticated to perform this action."
|
|
(AuthD.GotErrorAlreadyUsedLogin _) -> do
|
|
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
|
|
handleAction $ AddNotif $ BadNotification "Sorry, this login is already used."
|
|
H.liftEffect scrollToTop
|
|
(AuthD.GotErrorEmailAddressAlreadyUsed _) -> do
|
|
handleAction $ Log $ ErrorLog "received a GotErrorEmailAddressAlreadyUsed message."
|
|
handleAction $ AddNotif $ BadNotification "Sorry, this email address is already used."
|
|
H.liftEffect scrollToTop
|
|
(AuthD.GotErrorUserNotFound _) -> do
|
|
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
|
|
handleAction $ AddNotif $ BadNotification "User hasn't been found."
|
|
|
|
-- The authentication failed.
|
|
(AuthD.GotError errmsg) -> do
|
|
handleAction $ Log $ ErrorLog $ " generic error message: "
|
|
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
|
handleAction $ AddNotif $ BadNotification $ "Sorry, authd sent an error message. "
|
|
<> maybe "The server didn't tell why." (\v -> "Message was: " <> v) errmsg.reason
|
|
m@(AuthD.GotPasswordRecoverySent _) -> do
|
|
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
|
|
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
|
|
handleAction $ DispatchAuthDaemonMessage m
|
|
(AuthD.GotErrorPasswordTooShort _) -> do
|
|
handleAction $ Log $ ErrorLog "Password too short."
|
|
handleAction $ AddNotif $ BadNotification "Your password is too short."
|
|
(AuthD.GotErrorMailRequired _) -> do
|
|
handleAction $ Log $ ErrorLog "Email required."
|
|
handleAction $ AddNotif $ BadNotification "An email is required."
|
|
(AuthD.GotErrorInvalidCredentials _) -> do
|
|
handleAction $ Log $ ErrorLog "Invalid credentials."
|
|
handleAction $ ToggleAuthenticated Nothing
|
|
handleAction $ AddNotif $ BadNotification "Invalid credentials."
|
|
(AuthD.GotErrorRegistrationsClosed _) -> do
|
|
handleAction $ Log $ ErrorLog "Registration closed. Try another time or contact an administrator."
|
|
handleAction $ AddNotif $ BadNotification "Registration are closed at the moment."
|
|
(AuthD.GotErrorInvalidLoginFormat _) -> do
|
|
handleAction $ Log $ ErrorLog "Invalid login format."
|
|
handleAction $ AddNotif $ BadNotification "Invalid login format."
|
|
(AuthD.GotErrorInvalidEmailFormat _) -> do
|
|
handleAction $ Log $ ErrorLog "Invalid email format."
|
|
handleAction $ AddNotif $ BadNotification "Invalid email format."
|
|
(AuthD.GotErrorAlreadyUsersInDB _) -> do
|
|
handleAction $ Log $ ErrorLog "Login already taken."
|
|
handleAction $ AddNotif $ BadNotification "Login already taken."
|
|
(AuthD.GotErrorReadOnlyProfileKeys _) -> do
|
|
handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys."
|
|
handleAction $ AddNotif $ BadNotification "Trying to add a profile with some invalid (read-only) keys."
|
|
(AuthD.GotErrorInvalidActivationKey _) -> do
|
|
handleAction $ Log $ ErrorLog "Invalid activation key."
|
|
handleAction $ AddNotif $ BadNotification "Invalid activation key."
|
|
(AuthD.GotErrorUserAlreadyValidated _) -> do
|
|
handleAction $ Log $ ErrorLog "User already validated."
|
|
handleAction $ AddNotif $ BadNotification "User already validated."
|
|
(AuthD.GotErrorCannotContactUser _) -> do
|
|
handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
|
|
handleAction $ AddNotif $ BadNotification "User cannot be contacted. Email address may be invalid."
|
|
(AuthD.GotErrorInvalidRenewKey _) -> do
|
|
handleAction $ Log $ ErrorLog "Invalid renew key."
|
|
handleAction $ AddNotif $ BadNotification "Invalid renew key."
|
|
(AuthD.GotErrorPasswordTooLong _) -> do
|
|
handleAction $ Log $ ErrorLog "Password too long."
|
|
handleAction $ AddNotif $ BadNotification "Password too long."
|
|
-- The authentication was a success!
|
|
(AuthD.GotToken msg) -> do
|
|
handleAction $ Log $ SuccessLog $ "Authenticated to authd."
|
|
H.modify_ _ { token = Just msg.token
|
|
, user_data = Just (Tuple msg.current_email msg.pending_email)
|
|
}
|
|
handleAction $ ToggleAuthenticated (Just msg.token)
|
|
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
|
|
|
handleAction AuthenticateToDNSManager
|
|
|
|
-- 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.
|
|
case msg.current_email of
|
|
Nothing -> handleAction $ Routing Migration
|
|
_ -> pure unit
|
|
|
|
(AuthD.GotKeepAlive _) -> pure unit
|
|
pure unit
|
|
|
|
-- TODO
|
|
MigrationInterfaceEvent ev -> case ev of
|
|
MigrationInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
|
MigrationInterface.Log message -> handleAction $ Log message
|
|
|
|
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
|
DispatchAuthDaemonMessage message -> do
|
|
{ current_page } <- H.get
|
|
case current_page of
|
|
Authentication -> H.tell _ai unit (AI.MessageReceived message)
|
|
Administration -> H.tell _admini unit (AdminInterface.MessageReceived message)
|
|
_ -> 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.
|
|
DNSManagerDaemonEvent 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
|
|
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"
|
|
handleAction $ AddNotif $ BadNotification $ "The domain doesn't exist."
|
|
(DNSManager.MkRRNotFound _) -> do
|
|
handleAction $ Log $ ErrorLog $ "RRNotFound"
|
|
handleAction $ AddNotif $ BadNotification $ "The resource record doesn't exist."
|
|
(DNSManager.MkInvalidZone _) -> do
|
|
handleAction $ Log $ ErrorLog $ "InvalidZone"
|
|
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
|
|
(DNSManager.MkUnknownZone _) -> do
|
|
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
|
handleAction $ AddNotif $ BadNotification $ "The domain zone is unknown."
|
|
(DNSManager.MkDomainList _) -> do
|
|
handleAction $ Log $ ErrorLog $ "MkDomainList"
|
|
(DNSManager.MkUnknownUser _) -> do
|
|
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
|
|
(DNSManager.MkNoOwnership _) -> do
|
|
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
|
|
handleAction $ AddNotif $ BadNotification $ "You don't own this domain."
|
|
(DNSManager.MkInsufficientRights _) -> do
|
|
handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
|
|
handleAction $ AddNotif $ BadNotification $ "You do not have sufficient rights."
|
|
-- The authentication failed.
|
|
(DNSManager.MkError errmsg) -> do
|
|
handleAction $ Log $ ErrorLog 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."
|
|
handleAction $ AddNotif $ BadNotification $ "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 logged_message) -> do
|
|
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd."
|
|
H.tell _nav unit $ NavigationInterface.ToggleAdmin logged_message.admin
|
|
handleAction $ AddNotif $ GoodNotification "You are now authenticated."
|
|
handleAction $ DispatchDNSMessage 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
|
|
(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."
|
|
handleAction $ AddNotif $ BadNotification $ "Invalid domain name."
|
|
m@(DNSManager.MkDomainDeleted response) -> do
|
|
let successlog = "The domain \"" <> response.domain <> "\" has been deleted."
|
|
handleAction $ Log $ SuccessLog successlog
|
|
handleAction $ AddNotif $ GoodNotification successlog
|
|
handleAction $ DispatchDNSMessage m
|
|
m@(DNSManager.MkRRDeleted response) -> do
|
|
handleAction $ Log $ SuccessLog $ "Resource record (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
|
|
let errorlog = "Invalid resource record: " <> A.intercalate ", " response.errors
|
|
handleAction $ Log $ ErrorLog errorlog
|
|
handleAction $ AddNotif $ BadNotification errorlog
|
|
(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 "LegalNotice" -> handleAction $ Routing LegalNotice
|
|
Just "Migration" -> handleAction $ Routing Migration
|
|
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
|