1062 lines
53 KiB
Text
1062 lines
53 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
|
|
module App.Container where
|
|
|
|
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure, (+), (&&), (>), (<<<))
|
|
|
|
import Web as Web
|
|
|
|
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 App.Notification as Notification
|
|
import App.Type.Notification (Notification (..))
|
|
|
|
import Scroll (scrollToTop)
|
|
|
|
import App.Page.Authentication as PageAuthentication
|
|
import App.Page.Registration as PageRegistration
|
|
import App.Page.MailValidation as PageMailValidation
|
|
import App.Page.Administration as PageAdministration
|
|
import App.Page.Setup as PageSetup
|
|
import App.Page.DomainList as PageDomainList
|
|
import App.Page.Zone as PageZone
|
|
import App.Page.Home as PageHome
|
|
import App.Page.Migration as PageMigration
|
|
import App.Page.Navigation as PageNavigation
|
|
|
|
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
|
|
|
|
wsURLauthd = "wss://www.netlib.re/ws/authd" :: String
|
|
wsURLdnsmanagerd = "wss://www.netlib.re/ws/dnsmanagerd" :: String
|
|
|
|
data PageEvent
|
|
= EventPageAuthentication PageAuthentication.Output
|
|
| EventPageRegistration PageRegistration.Output
|
|
| EventPageMailValidation PageMailValidation.Output
|
|
| EventPageSetup PageSetup.Output
|
|
| EventPageNavigation PageNavigation.Output
|
|
| EventPageAdministration PageAdministration.Output
|
|
| EventPageDomainList PageDomainList.Output
|
|
| EventPageZone PageZone.Output
|
|
| EventPageMigration PageMigration.Output
|
|
|
|
| EventPageNotification Notification.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
|
|
|
|
-- | Reconnection to both `authd` and `dnsmanagerd`.
|
|
| Reconnection
|
|
|
|
-- | Change the displayed page.
|
|
| Routing Page
|
|
|
|
-- | 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)
|
|
|
|
-- | 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
|
|
|
|
-- | Add a main notification, at the top of the page.
|
|
| AddNotif Notification
|
|
|
|
-- | The component's state is composed of:
|
|
-- | a potential authentication token,
|
|
-- | the current page,
|
|
-- | the states of both `PageDomainList` 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
|
|
, childstates :: ChildStates
|
|
, 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,
|
|
-- | PageHome, PageDomainList, PageZone and AdministrationInterface).
|
|
type ChildSlots =
|
|
( log :: AppLog.Slot Unit
|
|
, ho :: PageHome.Slot Unit
|
|
, ws_auth :: WS.Slot Unit
|
|
, ws_dns :: WS.Slot Unit
|
|
, nav :: PageNavigation.Slot Unit
|
|
, ai :: PageAuthentication.Slot Unit
|
|
, ri :: PageRegistration.Slot Unit
|
|
, mvi :: PageMailValidation.Slot Unit
|
|
, admini :: PageAdministration.Slot Unit
|
|
, setupi :: PageSetup.Slot Unit
|
|
, dli :: PageDomainList.Slot Unit
|
|
, zi :: PageZone.Slot Unit
|
|
, mi :: PageMigration.Slot Unit
|
|
|
|
, notificationinterface :: Notification.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
|
|
_notificationinterface = Proxy :: Proxy "notificationinterface" -- Setup 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
|
|
}
|
|
}
|
|
|
|
type ChildStates =
|
|
{ domainlist :: Maybe PageDomainList.State
|
|
, administration :: Maybe PageAdministration.State
|
|
}
|
|
|
|
-- | 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
|
|
, childstates:
|
|
{ domainlist: Nothing
|
|
, administration: Nothing
|
|
}
|
|
, 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_ $
|
|
[ website_hero
|
|
, 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.
|
|
, Web.hr
|
|
, Web.columns_ [ Web.column_ [ Web.h3 "Logs (watch this if something fails 😅)", render_logs ]
|
|
, Web.column_ [ Web.level
|
|
[ render_auth_WS
|
|
, render_dnsmanager_WS
|
|
, legal_notice_btn
|
|
, paypal_btn
|
|
] [] ]
|
|
]
|
|
]
|
|
where
|
|
website_hero :: forall w i. HH.HTML w i
|
|
website_hero =
|
|
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 2013!"
|
|
]
|
|
]
|
|
]
|
|
]
|
|
|
|
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 _) ->
|
|
Web.big_website_warning
|
|
[ Web.p """
|
|
⚠️ MIGRATION (FR): veuillez indiquer une adresse email pour votre compte.
|
|
Tout compte sans adresse email sera supprimé sous 6 mois.
|
|
"""
|
|
, Web.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 = Web.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 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") (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") (EventOnNetwork <<< EventWSDNSmanagerd)
|
|
|
|
notification_duration = 3000 :: Int -- in ms
|
|
render_notifications = HH.slot _notificationinterface unit Notification.component notification_duration (EventOnPage <<< EventPageNotification)
|
|
|
|
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 (EventOnPage <<< EventPageDomainList)
|
|
render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
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 (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 (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 (EventOnPage <<< EventPageMailValidation)
|
|
render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
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 (EventOnPage <<< EventPageAdministration)
|
|
|
|
render_migration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
|
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
|
|
= Web.section_small [ Explanations.legal_notice
|
|
, Web.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 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 ]
|
|
|
|
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 $ PageNavigation.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 $ AddNotif NoNotification
|
|
|
|
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 $ PageNavigation.ToggleLogged false
|
|
Just _ -> H.tell _nav unit $ PageNavigation.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
|
|
|
|
EventOnPage page_event -> act_on_page_event page_event
|
|
EventOnNetwork network_event -> act_on_network_event network_event
|
|
|
|
AddNotif n -> H.tell _notificationinterface unit (Notification.Set n)
|
|
|
|
Reconnection -> do
|
|
H.tell _ws_auth unit WS.Connect
|
|
H.tell _ws_dns unit WS.Connect
|
|
handleAction $ AddNotif 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
|
|
|
|
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
|
|
PageNavigation.Disconnection -> handleAction $ Disconnection
|
|
|
|
EventPageAuthentication ev -> case ev of
|
|
PageAuthentication.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)
|
|
PageAuthentication.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)
|
|
|
|
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
|
|
_ <- H.liftEffect $ Storage.setItem "user-login" login sessionstorage
|
|
H.modify_ _ { login = Just login }
|
|
H.tell _nav unit $ PageNavigation.TellLogin (Just login)
|
|
|
|
EventPageRegistration ev -> case ev of
|
|
PageRegistration.AskRegister login email password -> do
|
|
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkRegister { login, email, password }
|
|
H.tell _ws_auth unit (WS.ToSend message)
|
|
PageRegistration.Log message -> handleAction $ Log message
|
|
|
|
EventPageMailValidation ev -> case ev of
|
|
PageMailValidation.AskValidateUser user activation_key -> do
|
|
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user, activation_key }
|
|
H.tell _ws_auth unit (WS.ToSend message)
|
|
PageMailValidation.Log message -> handleAction $ Log message
|
|
|
|
EventPageSetup ev -> case ev of
|
|
PageSetup.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
|
|
|
|
PageSetup.ChangeEmailAddress -> handleAction $ Routing Migration
|
|
PageSetup.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)
|
|
PageSetup.Log message -> handleAction $ Log message
|
|
|
|
EventPageAdministration ev -> case ev of
|
|
PageAdministration.DeleteDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageAdministration.SearchDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkSearchDomain { domain, offset: Just 0 }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageAdministration.ShowZone domain -> handleAction $ Routing $ Zone domain
|
|
PageAdministration.Log message -> handleAction $ Log message
|
|
PageAdministration.StoreState s -> H.modify_ _ { childstates { administration = Just s } }
|
|
PageAdministration.AskState -> do
|
|
state <- H.get
|
|
H.tell _admini unit (PageAdministration.ProvideState state.childstates.administration)
|
|
PageAdministration.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)
|
|
PageAdministration.AddUser login admin email password -> do
|
|
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAddUser { login, admin, email, password }
|
|
H.tell _ws_auth unit (WS.ToSend message)
|
|
PageAdministration.SearchUser regex offset -> do
|
|
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkSearchUser { regex, offset }
|
|
H.tell _ws_auth unit (WS.ToSend message)
|
|
PageAdministration.GetOrphanDomains -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetOrphanDomains {}
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
|
|
EventPageZone ev -> case ev of
|
|
PageZone.Log message -> handleAction $ Log message
|
|
PageZone.ToDomainList -> handleAction $ Routing DomainList
|
|
PageZone.AskZoneFile domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskGeneratedZoneFile { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageZone.AskNewToken domain rrid -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkNewToken { domain, rrid }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageZone.AskDeleteRR domain rrid -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteRR { domain, rrid }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageZone.AskSaveRR domain rr -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkUpdateRR { domain, rr }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageZone.AskAddRR domain rr -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAddRR { domain, rr }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageZone.AskGetZone domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
|
|
EventPageDomainList ev -> case ev of
|
|
PageDomainList.AskShareToken domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskShareToken { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.AskTransferToken domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskTransferToken { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.AskUnShareDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskUnShareDomain { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.AskDeleteDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.AskNewDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkNewDomain { domain }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.AskGainOwnership uuid -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGainOwnership { uuid }
|
|
H.tell _ws_dns unit (WS.ToSend message)
|
|
PageDomainList.Log message -> handleAction $ Log message
|
|
PageDomainList.StoreState s -> H.modify_ _ { childstates { domainlist = Just s } }
|
|
PageDomainList.ChangePageZoneInterface domain -> do
|
|
handleAction $ Routing $ Zone domain
|
|
|
|
PageDomainList.AskState -> do
|
|
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
|
|
|
|
EventPageNotification _ -> handleAction $ Log $ SystemLog "Weird, just received a notification from the notification component."
|
|
|
|
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) -> decode_message_from_authd 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"
|
|
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
|
|
|
|
-- | `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
|
|
-- 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
|
|
_ -> forward 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."
|
|
forward m
|
|
handleAction $ AddNotif $ GoodNotification "Your new password is now valid."
|
|
m@(AuthD.GotMatchingUsers _) -> do
|
|
{ current_page } <- H.get
|
|
case current_page of
|
|
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 -> forward 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."
|
|
forward 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
|
|
|
|
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.
|
|
case msg.current_email of
|
|
Nothing -> handleAction $ Routing Migration
|
|
_ -> pure unit
|
|
|
|
(AuthD.GotKeepAlive _) -> pure unit
|
|
pure unit
|
|
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)
|
|
Administration -> H.tell _admini unit (PageAdministration.MessageReceived message)
|
|
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
|
pure unit
|
|
|
|
-- | 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
|
|
-- 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."
|
|
forward 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..."
|
|
authenticate_to_dnsmanagerd
|
|
(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)."
|
|
forward m
|
|
m@(DNSManager.MkAcceptedDomains _) -> do
|
|
handleAction $ Log $ SuccessLog $ "Received the list of accepted domains."
|
|
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."
|
|
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)."
|
|
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."
|
|
forward m
|
|
m@(DNSManager.MkRRAdded response) -> do
|
|
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
|
|
forward m
|
|
m@(DNSManager.MkGeneratedZoneFile response) -> do
|
|
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
|
|
forward 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
|
|
forward m
|
|
m@(DNSManager.MkRRDeleted response) -> do
|
|
handleAction $ Log $ SuccessLog $ "Resource record (rrid: \"" <> show response.rrid <> "\") has been deleted."
|
|
forward m
|
|
m@(DNSManager.MkZone _) -> do
|
|
handleAction $ Log $ SuccessLog $ "Zone received."
|
|
forward 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 (PageAdministration.GotOrphanDomainList response.domains)
|
|
DNSManager.MkFoundDomains response -> do
|
|
handleAction $ Log $ SuccessLog "Received found domain list."
|
|
H.tell _admini unit (PageAdministration.GotFoundDomains response.domains)
|
|
(DNSManager.GotKeepAlive _) -> do
|
|
-- handleAction $ Log $ SystemLog $ "KeepAlive."
|
|
pure unit
|
|
pure unit
|
|
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.
|
|
-- 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 (PageDomainList.MessageReceived message)
|
|
Zone _ , _ -> H.tell _zi unit (PageZone.MessageReceived message)
|
|
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
|
pure unit
|
|
|
|
update_domain_list state m = do
|
|
case state.childstates.domainlist of
|
|
Nothing -> do
|
|
let new_value = PageDomainList.page_reload (PageDomainList.initialState unit) m
|
|
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
|
|
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
|
|
|
|
-- | 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
|
|
|
|
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)
|