From 7544cb90eef9d52aa34a7fee86b3fe44d7c9c203 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Wed, 7 Feb 2024 20:45:48 +0100 Subject: [PATCH] WIP: automatic re-authentication to `dnsmanagerd` on page reload. --- spago.dhall | 2 + src/App/AuthenticationForm.purs | 6 +- src/App/Container.purs | 145 +++++++++++++++++++++++--------- 3 files changed, 111 insertions(+), 42 deletions(-) diff --git a/spago.dhall b/spago.dhall index 4a31ca1..3fe85c7 100644 --- a/spago.dhall +++ b/spago.dhall @@ -35,7 +35,9 @@ , "validation" , "web-encoding" , "web-events" + , "web-html" , "web-socket" + , "web-storage" , "web-uievents" ] , packages = ./packages.dhall diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 9e6b191..5debfec 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -27,8 +27,11 @@ import App.Messages.AuthenticationDaemon as AuthD -- | dnsmanager daemon. -- | -- | Also, the component can send a message to a websocket and log messages. +-- | +-- | TODO: authentication is performed in `App.Container`. data Output = MessageToSend ArrayBuffer + | AuthenticateToAuthd (Tuple String String) -- Login Password | Log LogMessage -- | The component's parent provides received messages. @@ -204,8 +207,7 @@ handleAction = case _ of H.raise $ Log $ UnableToSend "Write your password!" login, pass -> do - message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass } - H.raise $ MessageToSend message + H.raise $ AuthenticateToAuthd (Tuple login pass) H.raise $ Log $ SimpleLog $ "[😇] Trying to authenticate (login: " <> login <> ")" RegisterAttempt ev -> do diff --git a/src/App/Container.purs b/src/App/Container.purs index f5f0e5f..e857ff2 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -1,6 +1,7 @@ +-- | `App.Container` is the parent of all other components of the application. module App.Container where -import Prelude (Unit, bind, discard, unit, ($), (<>), show, pure) +import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure) import Bulma as Bulma @@ -25,55 +26,87 @@ import Type.Proxy (Proxy(..)) import Effect.Aff.Class (class MonadAff) import Data.ArrayBuffer.Types (ArrayBuffer) +import Web.HTML (window) as HTML +import Web.HTML.Window (sessionStorage) as Window +import Web.Storage.Storage as Storage + import App.LogMessage (LogMessage(..)) +-- | List all pages the application has: +-- | Home, Login, Domain list, Zone, `authd` administration. +-- | This list will grows in a near future. data Page = Home | LoginRegister | DomainList | Zone String | AuthAdmin +type Token = String +type Login = String +type Password = String +type LogInfo = Tuple Login Password + data Action + -- | Handle events from `AuthenticationComponent`. = AuthenticationComponentEvent AF.Output + + -- | Handle events from `AuthenticationDaemonAdminComponent`. | AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd. + + -- | Handle events from `DomainListComponent`. | DomainListComponentEvent DomainListInterface.Output + + -- | Handle events from `AuthenticationDaemon`. | AuthenticationDaemonEvent WS.Output + + -- | Handle events from `DNSManagerDaemon`. | DNSManagerDaemonEvent WS.Output + + -- | Handle events from `ZoneInterface`. | ZoneInterfaceEvent ZoneInterface.Output - -- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets). + -- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets), + -- | then return to the home page. | Disconnection -- | Try to authenticate the user to `dnsmanagerd`. | AuthenticateToDNSManager + | AuthenticateToAuthd (Either Token LogInfo) + -- | Change the displayed page. | Routing Page - -- | DispatchDNSMessage: a DNS message (from `dnsmanagerd`) was received and decoded through the - -- | `DNSRawMessageReceived` action. - -- | The message is provided to the right component. + -- | `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 - -- | DNSRawMessageReceived is the action when receiving a message, which is decoded in the handler. - -- | Then, the message will be provided to the `DispatchDNSMessage` action. - | DNSRawMessageReceived ArrayBuffer - - -- | AuthDaemonRawMessageReceived is the action when receiving a message, which is decoded in the handler. - -- | Then, the message will be provided to the `DispatchAuthDaemonMessage` action. - | AuthDaemonRawMessageReceived ArrayBuffer + -- | `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 - -- | `AuthDaemonRawMessageReceived` action. + -- | `DecodeAuthMessage` action. -- | The message is provided to the right component. - -- | DispatchAuthDaemonMessage AuthD.AnswerMessage + | DispatchAuthDaemonMessage AuthD.AnswerMessage -- | Log message (through the Log component). | Log LogMessage +-- | 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 - , uid :: Maybe Int , current_page :: Page , store_DomainListInterface_state :: Maybe DomainListInterface.State , store_AuthenticationDaemonAdmin_state :: Maybe AAI.State } +-- | The list of child components: log, `WS` twice (once for each ws connection), +-- | then all the pages (AuthenticationForm, HomeInterface, DomainListInterface, ZoneInterface and +-- | AuthenticationDaemonAdminInterface). type ChildSlots = ( log :: AppLog.Slot Unit , ho :: HomeInterface.Slot Unit @@ -85,14 +118,14 @@ type ChildSlots = , zi :: ZoneInterface.Slot Unit ) -_ho = Proxy :: Proxy "ho" -_log = Proxy :: Proxy "log" -_ws_auth = Proxy :: Proxy "ws_auth" -_ws_dns = Proxy :: Proxy "ws_dns" -_af = Proxy :: Proxy "af" -_aai = Proxy :: Proxy "aai" -_dli = Proxy :: Proxy "dli" -_zi = Proxy :: Proxy "zi" +_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` +_af = Proxy :: Proxy "af" -- Authentication Form +_aai = Proxy :: Proxy "aai" -- Authd Administration Interface +_dli = Proxy :: Proxy "dli" -- Domain List +_zi = Proxy :: Proxy "zi" -- Zone Interface component :: forall q i o m. MonadAff m => H.Component q i o m component = @@ -102,9 +135,9 @@ component = , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } } +-- | Initial state is simple: the user is on the home page, nothing else is stored. initialState :: forall i. i -> State initialState _ = { token: Nothing - , uid: Nothing , current_page: Home , store_DomainListInterface_state: Nothing , store_AuthenticationDaemonAdmin_state: Nothing @@ -121,7 +154,9 @@ render state DomainList -> render_newdomain_interface Zone domain -> render_zone domain AuthAdmin -> render_authd_admin_interface - , Bulma.columns_ [ Bulma.column_ [ render_logs ], Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ] + -- The footer includes logs and both the WS child components. + , Bulma.columns_ [ Bulma.column_ [ render_logs ] + , Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ] ] where @@ -151,9 +186,7 @@ render state render_auth_WS = HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthenticationDaemonEvent render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad - render_dnsmanager_WS = case state.token of - Nothing -> render_nothing - Just _ -> HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDaemonEvent + render_dnsmanager_WS = HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDaemonEvent render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_form = case state.token of @@ -190,11 +223,19 @@ handleAction = case _ of message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token } H.tell _ws_dns unit (WS.ToSend message) Nothing -> do - H.tell _log unit (AppLog.Log $ SimpleLog "Trying to authenticate to dnsmanager without a token") + sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window + token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage + case token of + Nothing -> handleAction $ Log $ SimpleLog "no token!" + Just t -> do + H.modify_ _ { token = Just t } + handleAction $ Log $ SimpleLog $ "Let's start again to auth to dnsmanagerd with this token: " <> t + handleAction AuthenticateToDNSManager AuthenticationComponentEvent ev -> case ev of - AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) - AF.Log message -> H.tell _log unit (AppLog.Log message) + AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) + AF.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v) + AF.Log message -> H.tell _log unit (AppLog.Log message) AuthenticationDaemonAdminComponentEvent ev -> case ev of AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) @@ -222,16 +263,18 @@ handleAction = case _ of -- TODO: depending on the current page, we should provide the received message to different components. AuthenticationDaemonEvent ev -> case ev of WS.MessageReceived (Tuple _ message) -> do - handleAction $ AuthDaemonRawMessageReceived message + handleAction $ DecodeAuthMessage message + WS.WSJustConnected -> do H.tell _af unit AF.ConnectionIsUp H.tell _aai unit AAI.ConnectionIsUp + WS.WSJustClosed -> do H.tell _af unit AF.ConnectionIsDown H.tell _aai unit AAI.ConnectionIsDown WS.Log message -> H.tell _log unit (AppLog.Log message) - AuthDaemonRawMessageReceived message -> do + DecodeAuthMessage message -> do receivedMessage <- H.liftEffect $ AuthD.deserialize message case receivedMessage of -- Cases where we didn't understand the message. @@ -242,7 +285,8 @@ handleAction = case _ of -- print_json_string messageEvent.message handleAction $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr (AuthD.UnknownError unerr) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownError" <> (show unerr)) - (AuthD.UnknownNumber ) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownNumber") + (AuthD.UnknownNumber ) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownNumber") + -- Cases where we understood the message. Right response -> do case response of @@ -305,12 +349,28 @@ handleAction = case _ of -- The authentication was a success! (AuthD.GotToken msg) -> do handleAction $ Log $ SimpleLog $ "[🎉] Authenticated to authd!" - H.modify_ _ { uid = Just msg.uid, token = Just msg.token, current_page = DomainList } + H.modify_ _ { token = Just msg.token, current_page = DomainList } + + sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window + _ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage + handleAction AuthenticateToDNSManager pure unit - -- Send a received authentication daemon message to a component. - -- DispatchAuthDaemonMessage message -> do + AuthenticateToAuthd v -> case v of + Left token -> do + -- TODO: currently, there is no message to send to `authd` to authenticate a user only with a token. + handleAction $ Log $ SimpleLog $ "Trying to login with token: " <> token + Right (Tuple login password) -> do + message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password } + H.tell _ws_auth unit (WS.ToSend message) + + + -- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component. + -- | TODO: **CURRENTLY** this dispatch function is useless since no component require `authd` messages directly. + DispatchAuthDaemonMessage _ -> do + handleAction $ Log $ SimpleLog "[😈] DispatchAuthDaemonMessage action, called for no reason!" + pure unit -- { token } <- H.get -- case token of -- Nothing -> H.tell _af unit (AF.MessageReceived message) @@ -323,12 +383,14 @@ handleAction = case _ of Disconnection -> do H.put $ initialState unit + sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window + _ <- H.liftEffect $ Storage.removeItem "user-authd-token" sessionstorage handleAction $ Routing Home -- TODO: depending on the current page, we should provide the received message to different components. DNSManagerDaemonEvent ev -> case ev of WS.MessageReceived (Tuple _ message) -> do - handleAction $ DNSRawMessageReceived message + handleAction $ DecodeDNSMessage message WS.WSJustConnected -> do handleAction $ Log $ SimpleLog "Connection with dnsmanagerd was closed, let's re-authenticate" handleAction AuthenticateToDNSManager @@ -336,7 +398,8 @@ handleAction = case _ of WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown WS.Log message -> H.tell _log unit (AppLog.Log message) - DNSRawMessageReceived message -> do + -- | `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. @@ -420,7 +483,9 @@ handleAction = case _ of handleAction $ Log $ SimpleLog $ "[🎉] Success!" pure unit - -- Send a received DNS manager message to a component. + -- | 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 { current_page } <- H.get case current_page of