diff --git a/spago.dhall b/spago.dhall index 2afdc15..74eb1a7 100644 --- a/spago.dhall +++ b/spago.dhall @@ -9,7 +9,6 @@ , "bifunctors" , "codec-argonaut" , "console" - , "const" , "control" , "dom-indexed" , "effect" @@ -28,6 +27,7 @@ , "profunctor" , "strings" , "stringutils" + , "tailrec" , "transformers" , "tuples" , "uint" diff --git a/src/App/Container.purs b/src/App/Container.purs index 9f1a0b0..c5a10f0 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -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. diff --git a/src/App/Messages/AuthenticationDaemon.purs b/src/App/Messages/AuthenticationDaemon.purs index dffff2e..999a734 100644 --- a/src/App/Messages/AuthenticationDaemon.purs +++ b/src/App/Messages/AuthenticationDaemon.purs @@ -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. diff --git a/src/App/Messages/DNSManagerDaemon.purs b/src/App/Messages/DNSManagerDaemon.purs index 21c5764..f2c35f4 100644 --- a/src/App/Messages/DNSManagerDaemon.purs +++ b/src/App/Messages/DNSManagerDaemon.purs @@ -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. diff --git a/src/App/WS.purs b/src/App/WS.purs index fbee3b4..312062e 100644 --- a/src/App/WS.purs +++ b/src/App/WS.purs @@ -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."