Implement Keep Alive messages.

beta
Philippe Pittoli 2024-02-20 17:15:01 +01:00
parent b6b6a6be77
commit 07135d2ea3
5 changed files with 154 additions and 107 deletions

View File

@ -9,7 +9,6 @@
, "bifunctors"
, "codec-argonaut"
, "console"
, "const"
, "control"
, "dom-indexed"
, "effect"
@ -28,6 +27,7 @@
, "profunctor"
, "strings"
, "stringutils"
, "tailrec"
, "transformers"
, "tuples"
, "uint"

View File

@ -145,6 +145,9 @@ data Action
-- | Log message (through the Log component).
| Log LogMessage
-- | `KeepAlive` send a keepalive message to either `authd` or `dnsmanagerd`.
| KeepAlive (Either Unit Unit)
-- | The component's state is composed of:
-- | a potential authentication token,
-- | the current page,
@ -282,6 +285,14 @@ handleAction = case _ of
Log message -> H.tell _log unit $ AppLog.Log message
KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of
Left _ -> do
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {}
H.tell _ws_auth unit (WS.ToSend message)
Right _ -> do
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkKeepAlive {}
H.tell _ws_dns unit (WS.ToSend message)
AuthenticateToAuthd v -> case v of
Left token -> do
handleAction $ Log $ SimpleLog "[] authenticate to authd with a token!"
@ -361,6 +372,7 @@ handleAction = case _ of
H.tell _ai unit AI.ConnectionIsDown
H.tell _aai unit AAI.ConnectionIsDown
WS.Log message -> H.tell _log unit (AppLog.Log message)
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
DecodeAuthMessage message -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize message
@ -460,6 +472,8 @@ handleAction = case _ of
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
handleAction AuthenticateToDNSManager
(AuthD.GotKeepAlive _) -> do
handleAction $ Log $ SimpleLog $ "[] KeepAlive!"
pure unit
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
@ -487,6 +501,7 @@ handleAction = case _ of
H.tell _dli unit DomainListInterface.ConnectionIsUp
WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
WS.Log message -> H.tell _log unit (AppLog.Log message)
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
-- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`.
DecodeDNSMessage message -> do
@ -571,6 +586,8 @@ handleAction = case _ of
handleAction $ Log $ SimpleLog $ "[] Invalid resource record: " <> A.intercalate ", " response.errors
(DNSManager.MkSuccess _) -> do
handleAction $ Log $ SimpleLog $ "[] Success!"
(DNSManager.GotKeepAlive _) -> do
handleAction $ Log $ SimpleLog $ "[] KeepAlive!"
pure unit
-- | Send a received DNS manager message to a component.

View File

@ -170,6 +170,11 @@ type AuthByToken = { token :: String }
codecAuthByToken CA.JsonCodec AuthByToken
codecAuthByToken = CA.object "AuthByToken" (CAR.record { token: CA.string })
{- 250 -}
type KeepAlive = { }
codecKeepAlive CA.JsonCodec KeepAlive
codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
{-
RESPONSES
-}
@ -334,6 +339,11 @@ type ErrorInvalidRenewKey = {}
codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey
codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {})
{- 250 -}
-- type KeepAlive = { }
codecGotKeepAlive CA.JsonCodec KeepAlive
codecGotKeepAlive = CA.object "KeepAlive" (CAR.record { })
-- All possible requests.
data RequestMessage
= MkLogin Login -- 0
@ -351,6 +361,7 @@ data RequestMessage
| MkSetPermission SetPermission -- 11
| MkSearchUser SearchUser -- 12
| MkAuthByToken AuthByToken -- 15
| MkKeepAlive KeepAlive -- 250
-- All possible answers from the authentication daemon (authd).
data AnswerMessage
@ -382,26 +393,28 @@ data AnswerMessage
| GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32
| GotErrorCannotContactUser ErrorCannotContactUser -- 33
| GotErrorInvalidRenewKey ErrorInvalidRenewKey -- 34
| GotKeepAlive KeepAlive -- 250
encode RequestMessage -> Tuple UInt String
encode m = case m of
(MkLogin request) -> get_tuple 0 codecLogin request
(MkRegister request) -> get_tuple 1 codecRegister request
(MkValidateUser request) -> get_tuple 2 codecValidateUser request
(MkLogin request) -> get_tuple 0 codecLogin request
(MkRegister request) -> get_tuple 1 codecRegister request
(MkValidateUser request) -> get_tuple 2 codecValidateUser request
(MkAskPasswordRecovery request) -> get_tuple 3 codecAskPasswordRecovery request
(MkPasswordRecovery request) -> get_tuple 4 codecPasswordRecovery request
(MkPasswordRecovery request) -> get_tuple 4 codecPasswordRecovery request
-- Both messages are actually a single message type, so they have the same number.
-- TODO: change the message codec for an Either Int String.
(MkGetUserByUID request) -> get_tuple 5 codecGetUserByUID request
(MkGetUserByUID request) -> get_tuple 5 codecGetUserByUID request
(MkGetUserByName request) -> get_tuple 5 codecGetUserByName request
(MkModUser request) -> get_tuple 6 codecModUser request
(MkModUser request) -> get_tuple 6 codecModUser request
-- 7 MkEditProfileContent
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
(MkAddUser request) -> get_tuple 9 codecAddUser request
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
(MkAddUser request) -> get_tuple 9 codecAddUser request
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
where
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
@ -414,34 +427,35 @@ data DecodeError
decode :: Int -> String -> Either DecodeError AnswerMessage
decode number string
= case number of
0 -> error_management codecGotError GotError
1 -> error_management codecGotToken GotToken
2 -> error_management codecGotUser GotUser
3 -> error_management codecGotUserAdded GotUserAdded
4 -> error_management codecGotUserEdited GotUserEdited
5 -> error_management codecGotUserValidated GotUserValidated
6 -> error_management codecGotUsersList GotUsersList
7 -> error_management codecGotPermissionCheck GotPermissionCheck
8 -> error_management codecGotPermissionSet GotPermissionSet
9 -> error_management codecGotPasswordRecoverySent GotPasswordRecoverySent
10 -> error_management codecGotPasswordRecovered GotPasswordRecovered
11 -> error_management codecGotMatchingUsers GotMatchingUsers
12 -> error_management codecGotUserDeleted GotUserDeleted
20 -> error_management codecGotErrorMustBeAuthenticated GotErrorMustBeAuthenticated
21 -> error_management codecGotErrorAlreadyUsedLogin GotErrorAlreadyUsedLogin
22 -> error_management codecGotErrorMailRequired GotErrorMailRequired
23 -> error_management codecGotErrorUserNotFound GotErrorUserNotFound
24 -> error_management codecGotErrorPasswordTooShort GotErrorPasswordTooShort
25 -> error_management codecGotErrorInvalidCredentials GotErrorInvalidCredentials
26 -> error_management codecGotErrorRegistrationsClosed GotErrorRegistrationsClosed
27 -> error_management codecGotErrorInvalidLoginFormat GotErrorInvalidLoginFormat
28 -> error_management codecGotErrorInvalidEmailFormat GotErrorInvalidEmailFormat
29 -> error_management codecGotErrorAlreadyUsersInDB GotErrorAlreadyUsersInDB
30 -> error_management codecGotErrorReadOnlyProfileKeys GotErrorReadOnlyProfileKeys
31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
33 -> error_management codecGotErrorCannotContactUser GotErrorCannotContactUser
34 -> error_management codecGotErrorInvalidRenewKey GotErrorInvalidRenewKey
0 -> error_management codecGotError GotError
1 -> error_management codecGotToken GotToken
2 -> error_management codecGotUser GotUser
3 -> error_management codecGotUserAdded GotUserAdded
4 -> error_management codecGotUserEdited GotUserEdited
5 -> error_management codecGotUserValidated GotUserValidated
6 -> error_management codecGotUsersList GotUsersList
7 -> error_management codecGotPermissionCheck GotPermissionCheck
8 -> error_management codecGotPermissionSet GotPermissionSet
9 -> error_management codecGotPasswordRecoverySent GotPasswordRecoverySent
10 -> error_management codecGotPasswordRecovered GotPasswordRecovered
11 -> error_management codecGotMatchingUsers GotMatchingUsers
12 -> error_management codecGotUserDeleted GotUserDeleted
20 -> error_management codecGotErrorMustBeAuthenticated GotErrorMustBeAuthenticated
21 -> error_management codecGotErrorAlreadyUsedLogin GotErrorAlreadyUsedLogin
22 -> error_management codecGotErrorMailRequired GotErrorMailRequired
23 -> error_management codecGotErrorUserNotFound GotErrorUserNotFound
24 -> error_management codecGotErrorPasswordTooShort GotErrorPasswordTooShort
25 -> error_management codecGotErrorInvalidCredentials GotErrorInvalidCredentials
26 -> error_management codecGotErrorRegistrationsClosed GotErrorRegistrationsClosed
27 -> error_management codecGotErrorInvalidLoginFormat GotErrorInvalidLoginFormat
28 -> error_management codecGotErrorInvalidEmailFormat GotErrorInvalidEmailFormat
29 -> error_management codecGotErrorAlreadyUsersInDB GotErrorAlreadyUsersInDB
30 -> error_management codecGotErrorReadOnlyProfileKeys GotErrorReadOnlyProfileKeys
31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
33 -> error_management codecGotErrorCannotContactUser GotErrorCannotContactUser
34 -> error_management codecGotErrorInvalidRenewKey GotErrorInvalidRenewKey
250 -> error_management codecGotKeepAlive GotKeepAlive
_ -> Left UnknownNumber
where
-- Signature is required since the compiler's guess is wrong.

View File

@ -79,6 +79,11 @@ type DeleteRR = { domain :: String, rrid :: Int }
codecDeleteRR CA.JsonCodec DeleteRR
codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int })
{- 250 -}
type KeepAlive = { }
codecKeepAlive CA.JsonCodec KeepAlive
codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
{-
RESPONSES
-}
@ -214,6 +219,11 @@ type NoOwnership = { }
codecNoOwnership CA.JsonCodec NoOwnership
codecNoOwnership = CA.object "NoOwnership" (CAR.record { })
{- 250 -}
--type KeepAlive = { }
--codecKeepAlive CA.JsonCodec KeepAlive
--codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
-- All possible requests.
data RequestMessage
@ -227,48 +237,50 @@ data RequestMessage
| MkAddRR AddRR -- 14
| MkUpdateRR UpdateRR -- 15
| MkDeleteRR DeleteRR -- 16
| MkKeepAlive KeepAlive -- 250
-- All possible answers from the authentication daemon (authd).
data AnswerMessage
= MkError Error -- 0
| MkSuccess Success -- 1
| MkErrorInvalidToken ErrorInvalidToken -- 2
| MkDomainAlreadyExists DomainAlreadyExists -- 3
| MkErrorUserNotLogged ErrorUserNotLogged -- 4
| MkDomainNotFound DomainNotFound -- 5
| MkRRNotFound RRNotFound -- 6
| MkUnacceptableDomain UnacceptableDomain -- 7
| MkInvalidDomainName InvalidDomainName -- 8
| MkDomainDeleted DomainDeleted -- 9
| MkInvalidZone InvalidZone -- 10
| MkDomainChanged DomainChanged -- 11
| MkZone Zone -- 12
| MkUnknownZone UnknownZone -- 13
| MkDomainList DomainList -- 14
| MkAcceptedDomains AcceptedDomains -- 15
| MkLogged Logged -- 16
| MkDomainAdded DomainAdded -- 17
| MkRRDeleted RRDeleted -- 18
| MkRRAdded RRAdded -- 19
| MkInvalidRR InvalidRR -- 20
| MkRRUpdated RRUpdated -- 21
| MkRRReadOnly RRReadOnly -- 22
| MkUnknownUser UnknownUser -- 50
| MkNoOwnership NoOwnership -- 51
= MkError Error -- 0
| MkSuccess Success -- 1
| MkErrorInvalidToken ErrorInvalidToken -- 2
| MkDomainAlreadyExists DomainAlreadyExists -- 3
| MkErrorUserNotLogged ErrorUserNotLogged -- 4
| MkDomainNotFound DomainNotFound -- 5
| MkRRNotFound RRNotFound -- 6
| MkUnacceptableDomain UnacceptableDomain -- 7
| MkInvalidDomainName InvalidDomainName -- 8
| MkDomainDeleted DomainDeleted -- 9
| MkInvalidZone InvalidZone -- 10
| MkDomainChanged DomainChanged -- 11
| MkZone Zone -- 12
| MkUnknownZone UnknownZone -- 13
| MkDomainList DomainList -- 14
| MkAcceptedDomains AcceptedDomains -- 15
| MkLogged Logged -- 16
| MkDomainAdded DomainAdded -- 17
| MkRRDeleted RRDeleted -- 18
| MkRRAdded RRAdded -- 19
| MkInvalidRR InvalidRR -- 20
| MkRRUpdated RRUpdated -- 21
| MkRRReadOnly RRReadOnly -- 22
| MkUnknownUser UnknownUser -- 50
| MkNoOwnership NoOwnership -- 51
| GotKeepAlive KeepAlive -- 250
encode RequestMessage -> Tuple UInt String
encode m = case m of
(MkLogin request) -> get_tuple 0 codecLogin request
(MkMaintenance request) -> get_tuple 7 codecMaintenance request
(MkNewDomain request) -> get_tuple 9 codecNewDomain request
(MkDeleteDomain request) -> get_tuple 10 codecDeleteDomain request
(MkAddOrUpdateZone request) -> get_tuple 11 codecAddOrUpdateZone request
(MkGetZone request) -> get_tuple 12 codecGetZone request
(MkUserDomains request) -> get_tuple 13 codecUserDomains request
(MkAddRR request) -> get_tuple 14 codecAddRR request
(MkUpdateRR request) -> get_tuple 15 codecUpdateRR request
(MkDeleteRR request) -> get_tuple 16 codecDeleteRR request
(MkLogin request) -> get_tuple 0 codecLogin request
(MkMaintenance request) -> get_tuple 7 codecMaintenance request
(MkNewDomain request) -> get_tuple 9 codecNewDomain request
(MkDeleteDomain request) -> get_tuple 10 codecDeleteDomain request
(MkAddOrUpdateZone request) -> get_tuple 11 codecAddOrUpdateZone request
(MkGetZone request) -> get_tuple 12 codecGetZone request
(MkUserDomains request) -> get_tuple 13 codecUserDomains request
(MkAddRR request) -> get_tuple 14 codecAddRR request
(MkUpdateRR request) -> get_tuple 15 codecUpdateRR request
(MkDeleteRR request) -> get_tuple 16 codecDeleteRR request
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
where
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
@ -281,31 +293,32 @@ data DecodeError
decode :: Int -> String -> Either DecodeError AnswerMessage
decode number string
= case number of
0 -> error_management codecError MkError
1 -> error_management codecSuccess MkSuccess
2 -> error_management codecErrorInvalidToken MkErrorInvalidToken
3 -> error_management codecDomainAlreadyExists MkDomainAlreadyExists
4 -> error_management codecErrorUserNotLogged MkErrorUserNotLogged
5 -> error_management codecDomainNotFound MkDomainNotFound
6 -> error_management codecRRNotFound MkRRNotFound
7 -> error_management codecUnacceptableDomain MkUnacceptableDomain
8 -> error_management codecInvalidDomainName MkInvalidDomainName
9 -> error_management codecDomainDeleted MkDomainDeleted
10 -> error_management codecInvalidZone MkInvalidZone
11 -> error_management codecDomainChanged MkDomainChanged
12 -> error_management codecZone MkZone
13 -> error_management codecUnknownZone MkUnknownZone
14 -> error_management codecDomainList MkDomainList
15 -> error_management codecAcceptedDomains MkAcceptedDomains
16 -> error_management codecLogged MkLogged
17 -> error_management codecDomainAdded MkDomainAdded
18 -> error_management codecRRDeleted MkRRDeleted
19 -> error_management codecRRAdded MkRRAdded
20 -> error_management codecInvalidRR MkInvalidRR
21 -> error_management codecRRUpdated MkRRUpdated
22 -> error_management codecRRReadOnly MkRRReadOnly
50 -> error_management codecUnknownUser MkUnknownUser
51 -> error_management codecNoOwnership MkNoOwnership
0 -> error_management codecError MkError
1 -> error_management codecSuccess MkSuccess
2 -> error_management codecErrorInvalidToken MkErrorInvalidToken
3 -> error_management codecDomainAlreadyExists MkDomainAlreadyExists
4 -> error_management codecErrorUserNotLogged MkErrorUserNotLogged
5 -> error_management codecDomainNotFound MkDomainNotFound
6 -> error_management codecRRNotFound MkRRNotFound
7 -> error_management codecUnacceptableDomain MkUnacceptableDomain
8 -> error_management codecInvalidDomainName MkInvalidDomainName
9 -> error_management codecDomainDeleted MkDomainDeleted
10 -> error_management codecInvalidZone MkInvalidZone
11 -> error_management codecDomainChanged MkDomainChanged
12 -> error_management codecZone MkZone
13 -> error_management codecUnknownZone MkUnknownZone
14 -> error_management codecDomainList MkDomainList
15 -> error_management codecAcceptedDomains MkAcceptedDomains
16 -> error_management codecLogged MkLogged
17 -> error_management codecDomainAdded MkDomainAdded
18 -> error_management codecRRDeleted MkRRDeleted
19 -> error_management codecRRAdded MkRRAdded
20 -> error_management codecInvalidRR MkInvalidRR
21 -> error_management codecRRUpdated MkRRUpdated
22 -> error_management codecRRReadOnly MkRRReadOnly
50 -> error_management codecUnknownUser MkUnknownUser
51 -> error_management codecNoOwnership MkNoOwnership
250 -> error_management codecKeepAlive GotKeepAlive
_ -> Left UnknownNumber
where
-- Signature is required since the compiler's guess is wrong.

View File

@ -47,6 +47,7 @@ data Output
| WSJustConnected -- Inform the parent the connection is up.
| WSJustClosed -- Inform the parent the connection is down.
| Log LogMessage
| KeepAlive -- Ask the parent to handle a keep-alive message.
-- | The component can receive a single action from other components: sending a message throught the websocket.
data Query a = ToSend ArrayBuffer a
@ -79,6 +80,7 @@ data Action
-- | `Finalize` is the action performed once the component is destroyed, ending the connection.
| Finalize
-- | Tick: keep alive WS connections.
| Tick
-- | Every received websocket message and notification is handled in `HandleWebSocket`.
@ -162,9 +164,8 @@ handleAction action = do
Tick -> do
H.modify_ \state -> state { seconds = state.seconds + keepalive }
-- TODO: create a message only for applicative keepalive.
-- message
-- send_message message
-- Applicative KeepAlive. The same message type works for both `authd` and `dnsmanagerd`.
H.raise KeepAlive
Finalize -> do
-- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
@ -226,10 +227,12 @@ handleAction action = do
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
ToSend message a -> send_message message
ToSend message a -> do
send_message message
pure Nothing
send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
send_message message =
send_message message = do
{ wsInfo } <- H.get
case wsInfo.connection of
Nothing -> H.raise $ Log $ UnableToSend "Not connected to server."