karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP: automatic re-authentication to dnsmanagerd on page reload.

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-07 20:45:48 +01:00
parent c9c1b81912
commit 7544cb90ee
3 changed files with 111 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
spago.dhall
View File

@ -35,7 +35,9 @@
, "validation"
, "web-encoding"
, "web-events"
, "web-html"
, "web-socket"
, "web-storage"
, "web-uievents"
]
, packages = ./packages.dhall

6
src/App/AuthenticationForm.purs
View File

@ -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

145
src/App/Container.purs
View File

@ -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