From 6fb46022fe73f11b541236ecd1f36b3b17c64875 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Fri, 16 Jun 2023 18:54:07 +0200 Subject: [PATCH] DNSManager network: WIP --- src/App/Messages/DNSManagerDaemon.purs | 489 +++++++++++++++++++++++++ 1 file changed, 489 insertions(+) create mode 100644 src/App/Messages/DNSManagerDaemon.purs diff --git a/src/App/Messages/DNSManagerDaemon.purs b/src/App/Messages/DNSManagerDaemon.purs new file mode 100644 index 0000000..7226b9b --- /dev/null +++ b/src/App/Messages/DNSManagerDaemon.purs @@ -0,0 +1,489 @@ +module App.Messages.DNSManagerDaemon where + +import Prelude (bind, pure, show, ($)) + +import Effect (Effect) + +import Data.Argonaut.Core as J +import Data.Codec.Argonaut as CA +import Data.Maybe (Maybe) +import Data.Either (Either(..)) +import Data.Codec.Argonaut.Record as CAR +import Data.UInt (fromInt, toInt, UInt) + +import Data.Tuple (Tuple(..)) +import Data.ArrayBuffer.Types (ArrayBuffer) + +-- import App.PermissionLevel as PermissionLevel + +import Effect.Class (liftEffect) +import Data.Argonaut.Parser as JSONParser +import Data.Bifunctor (lmap) + +import App.IPC as IPC + +type Password = String + +{- UserID should be in a separate module with a dedicated codec. -} +type UserID = Int -- UserID is either a login or an uid number + + +{- 7 -} +-- data MaintenanceSubject = Verbosity +-- type Maintenance = { subject :: MaintenanceSubject, value :: Maybe Int } +-- codecMaintenance = CA.object "Maintenance" (CAR.record { subject: CA.string, value: CA.int }) + +{- 0 -} +type Login = { token :: String } +codecLogin = CA.object "Login" (CAR.record { token: CA.string }) + +{- 10 -} +-- type AddOrUpdateZone = { zone :: DNSManager::Storage::Zone } + +{- 11 -} +type DeleteZone = { domain :: String } +codecDeleteZone = CA.object "DeleteZone" (CAR.record { domain: CA.string }) + +{- 12 -} +type GetZone = { domain :: String } +codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string }) + +{- 13 -} +type UserDomains = {} +codecUserDomains = CA.object "UserDomains" (CAR.record {}) + +{- 14 -} +-- type AddRR = { domain :: String, rr :: DNSManager::Storage::Zone::ResourceRecord } +-- codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) + +{- 15 -} +-- type UpdateRR = { domain :: String, rr :: DNSManager::Storage::Zone::ResourceRecord } +-- codecUpdateRR = CA.object "UpdateRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) + +{- 16 -} +type DeleteRR = { domain :: String, rrid :: Int } +codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int }) + + + + +{- 0 -} +type Login = { login :: String, password :: String } +codecLogin ∷ CA.JsonCodec Login +codecLogin = CA.object "Login" (CAR.record { login: CA.string, password: CA.string }) + +{- 1 -} +type Register = { login :: String + , password :: Password + , email :: Maybe Email.Email + {-, profile :: Maybe Hash(String, JSON::Any) -} } +codecRegister ∷ CA.JsonCodec Register +codecRegister + = CA.object "Register" (CAR.record + { login: CA.string + , password: CA.string + , email: CAR.optional Email.codec }) + +{- 2 -} +type ValidateUser = { user :: UserID, activation_key :: String } +codecValidateUser ∷ CA.JsonCodec ValidateUser +codecValidateUser + = CA.object "ValidateUser" (CAR.record + { user: CA.int + , activation_key: CA.string }) + +{- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID, + but they'll be used as login since the user has to type it. -} +{- 3 -} +type AskPasswordRecovery = { user :: String } +codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery +codecAskPasswordRecovery = CA.object "AskPasswordRecovery" (CAR.record { user: CA.string }) + +{- 4 -} +type PasswordRecovery = { user :: String + , password_renew_key :: String + , new_password :: Password } +codecPasswordRecovery ∷ CA.JsonCodec PasswordRecovery +codecPasswordRecovery + = CA.object "PasswordRecovery" (CAR.record + { user: CA.string + , password_renew_key: CA.string + , new_password: CA.string }) + +{- 5 -} +-- I'll split a message in two: either get a user by UID or by name. +-- TODO: change it for an Either Int String type. +type GetUserByUID = { user :: Int } +type GetUserByName = { user :: String } +codecGetUserByUID ∷ CA.JsonCodec GetUserByUID +codecGetUserByUID = CA.object "GetUserByUID" (CAR.record { user: CA.int }) +codecGetUserByName ∷ CA.JsonCodec GetUserByName +codecGetUserByName = CA.object "GetUserByName" (CAR.record { user: CA.string }) + +{- 6 -} +type ModUser = { user :: Maybe UserID + , admin :: Maybe Boolean + , password :: Maybe Password + , email :: Maybe Email.Email } +codecModUser ∷ CA.JsonCodec ModUser +codecModUser + = CA.object "ModUser" (CAR.record + { user: CAR.optional CA.int + , admin: CAR.optional CA.boolean + , password: CAR.optional CA.string + , email: CAR.optional Email.codec }) + +{- 7 -} +{- type EditProfileEntries = { user :: Maybe UserID + , new_profile_entries :: Hash(String, JSON::Any) } -} + +{- 8 -} +type DeleteUser = { user :: Maybe UserID } +codecDeleteUser ∷ CA.JsonCodec DeleteUser +codecDeleteUser = CA.object "DeleteUser" (CAR.record { user: CAR.optional CA.int }) + +{- 9 -} +type AddUser = { login :: String + , password :: Password + , admin :: Boolean + , email :: Maybe Email.Email + {-, profile :: Maybe Hash(String, JSON::Any) -} } +codecAddUser ∷ CA.JsonCodec AddUser +codecAddUser + = CA.object "AddUser" (CAR.record + { login: CA.string + , password: CA.string + , admin: CA.boolean + , email: CAR.optional Email.codec + {-, profile :: Maybe Hash(String, JSON::Any) -} }) + +{- 10 -} +type CheckPermission = { user :: Maybe UserID, service :: String, resource :: String } +codecCheckPermission ∷ CA.JsonCodec CheckPermission +codecCheckPermission + = CA.object "CheckPermission" (CAR.record + { user: CAR.optional CA.int + , service: CA.string + , resource: CA.string }) + +{- 11 -} +type SetPermission = { user :: UserID + , service :: String + , resource :: String + , permission :: PermissionLevel.PermissionLevel } +codecSetPermission ∷ CA.JsonCodec SetPermission +codecSetPermission + = CA.object "SetPermission" (CAR.record + { user: CA.int + , service: CA.string + , resource: CA.string + , permission: PermissionLevel.codec }) + +{- 12 -} +type SearchUser = { regex :: Maybe String, offset :: Maybe Int } +codecSearchUser ∷ CA.JsonCodec SearchUser +codecSearchUser + = CA.object "SearchUser" (CAR.record + { regex: CAR.optional CA.string + , offset: CAR.optional CA.int }) + + +{- + RESPONSES +-} + +-- TODO: note to myself: messages seem chaotic. Could be simpler. Should be simpler. +{- 0 -} +type Error = { reason :: Maybe String } +codecGotError ∷ CA.JsonCodec Error +codecGotError = CA.object "Error" (CAR.record { reason: CAR.optional CA.string }) + +{- 1 -} +type Logged = { uid :: Int, token :: String } +codecGotToken ∷ CA.JsonCodec Logged +codecGotToken = CA.object "Logged" (CAR.record { "uid": CA.int, "token": CA.string }) + +{- 2 -} +type User = { user :: UserPublic.UserPublic } +codecGotUser ∷ CA.JsonCodec User +codecGotUser = CA.object "User" (CAR.record { user: UserPublic.codec }) + +{- 3 -} +type UserAdded = { user :: UserPublic.UserPublic } +codecGotUserAdded ∷ CA.JsonCodec UserAdded +codecGotUserAdded = CA.object "UserAdded" (CAR.record { user: UserPublic.codec }) + +{- 4 -} +type UserEdited = { uid :: Int } +codecGotUserEdited ∷ CA.JsonCodec UserEdited +codecGotUserEdited = CA.object "UserEdited" (CAR.record { "uid": CA.int }) + +{- 5 -} +type UserValidated = { user :: UserPublic.UserPublic } +codecGotUserValidated ∷ CA.JsonCodec UserValidated +codecGotUserValidated = CA.object "UserValidated" (CAR.record { user: UserPublic.codec }) + +{- 6 -} +type UsersList = { users :: Array UserPublic.UserPublic } +codecGotUsersList ∷ CA.JsonCodec UsersList +codecGotUsersList = CA.object "UsersList" (CAR.record { users: CA.array UserPublic.codec }) + +{- 7 -} +type PermissionCheck + = { user :: Int + , service :: String + , resource :: String + , permission :: PermissionLevel.PermissionLevel } +codecGotPermissionCheck :: CA.JsonCodec PermissionCheck +codecGotPermissionCheck + = CA.object "PermissionCheck" (CAR.record + { user: CA.int + , service: CA.string + , resource: CA.string + , permission: PermissionLevel.codec }) + +{- 8 -} +type PermissionSet + = { user :: Int + , service :: String + , resource :: String + , permission :: PermissionLevel.PermissionLevel } +codecGotPermissionSet :: CA.JsonCodec PermissionSet +codecGotPermissionSet + = CA.object "PermissionSet" (CAR.record + { user: CA.int + , service: CA.string + , resource: CA.string + , permission: PermissionLevel.codec }) + +{- 9 -} +type PasswordRecoverySent = { user :: UserPublic.UserPublic } +codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent +codecGotPasswordRecoverySent + = CA.object "PasswordRecoverySent" (CAR.record { user: UserPublic.codec }) + +{- 10 -} +type PasswordRecovered = { } +codecGotPasswordRecovered ∷ CA.JsonCodec PasswordRecovered +codecGotPasswordRecovered = CA.object "PasswordRecovered" (CAR.record { }) + +{- 11 -} +type MatchingUsers = { users :: Array UserPublic.UserPublic } +codecGotMatchingUsers ∷ CA.JsonCodec MatchingUsers +codecGotMatchingUsers = CA.object "MatchingUsers" (CAR.record { users: CA.array UserPublic.codec }) + +{- 12 -} +type UserDeleted = { uid :: Int } +codecGotUserDeleted ∷ CA.JsonCodec UserDeleted +codecGotUserDeleted = CA.object "UserDeleted" (CAR.record { uid: CA.int }) + +{- 20 -} +type ErrorMustBeAuthenticated = {} +codecGotErrorMustBeAuthenticated :: CA.JsonCodec ErrorMustBeAuthenticated +codecGotErrorMustBeAuthenticated = CA.object "ErrorMustBeAuthenticated" (CAR.record {}) + +{- 21 -} +type ErrorAlreadyUsedLogin = {} +codecGotErrorAlreadyUsedLogin :: CA.JsonCodec ErrorAlreadyUsedLogin +codecGotErrorAlreadyUsedLogin = CA.object "ErrorAlreadyUsedLogin" (CAR.record {}) + +{- 22 -} +type ErrorMailRequired = {} +codecGotErrorMailRequired :: CA.JsonCodec ErrorMailRequired +codecGotErrorMailRequired = CA.object "ErrorMailRequired" (CAR.record {}) + +{- 23 -} +type ErrorUserNotFound = {} +codecGotErrorUserNotFound :: CA.JsonCodec ErrorUserNotFound +codecGotErrorUserNotFound = CA.object "ErrorUserNotFound" (CAR.record {}) + +{- 24 -} +type ErrorPasswordTooShort = {} +codecGotErrorPasswordTooShort :: CA.JsonCodec ErrorPasswordTooShort +codecGotErrorPasswordTooShort = CA.object "ErrorPasswordTooShort" (CAR.record {}) + +{- 25 -} +type ErrorInvalidCredentials = {} +codecGotErrorInvalidCredentials :: CA.JsonCodec ErrorInvalidCredentials +codecGotErrorInvalidCredentials = CA.object "ErrorInvalidCredentials" (CAR.record {}) + +{- 26 -} +type ErrorRegistrationsClosed = {} +codecGotErrorRegistrationsClosed :: CA.JsonCodec ErrorRegistrationsClosed +codecGotErrorRegistrationsClosed = CA.object "ErrorRegistrationsClosed" (CAR.record {}) + +{- 27 -} +type ErrorInvalidLoginFormat = {} +codecGotErrorInvalidLoginFormat :: CA.JsonCodec ErrorInvalidLoginFormat +codecGotErrorInvalidLoginFormat = CA.object "ErrorInvalidLoginFormat" (CAR.record {}) + +{- 28 -} +type ErrorInvalidEmailFormat = {} +codecGotErrorInvalidEmailFormat :: CA.JsonCodec ErrorInvalidEmailFormat +codecGotErrorInvalidEmailFormat = CA.object "ErrorInvalidEmailFormat" (CAR.record {}) + +{- 29 -} +type ErrorAlreadyUsersInDB = {} +codecGotErrorAlreadyUsersInDB :: CA.JsonCodec ErrorAlreadyUsersInDB +codecGotErrorAlreadyUsersInDB = CA.object "ErrorAlreadyUsersInDB" (CAR.record {}) + +{- 30 -} +type ErrorReadOnlyProfileKeys = { read_only_keys :: Array String } +codecGotErrorReadOnlyProfileKeys :: CA.JsonCodec ErrorReadOnlyProfileKeys +codecGotErrorReadOnlyProfileKeys + = CA.object "ErrorReadOnlyProfileKeys" (CAR.record { read_only_keys: CA.array CA.string }) + +{- 31 -} +type ErrorInvalidActivationKey = {} +codecGotErrorInvalidActivationKey :: CA.JsonCodec ErrorInvalidActivationKey +codecGotErrorInvalidActivationKey = CA.object "ErrorInvalidActivationKey" (CAR.record {}) + +{- 32 -} +type ErrorUserAlreadyValidated = {} +codecGotErrorUserAlreadyValidated :: CA.JsonCodec ErrorUserAlreadyValidated +codecGotErrorUserAlreadyValidated = CA.object "ErrorUserAlreadyValidated" (CAR.record {}) + +{- 33 -} +type ErrorCannotContactUser = {} +codecGotErrorCannotContactUser :: CA.JsonCodec ErrorCannotContactUser +codecGotErrorCannotContactUser = CA.object "ErrorCannotContactUser" (CAR.record {}) + +{- 34 -} +type ErrorInvalidRenewKey = {} +codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey +codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {}) + +-- All possible requests. +data RequestMessage + = MkLogin Login -- 0 + | MkRegister Register -- 1 + | MkValidateUser ValidateUser -- 2 + | MkAskPasswordRecovery AskPasswordRecovery -- 3 + | MkPasswordRecovery PasswordRecovery -- 4 + | MkGetUserByUID GetUserByUID -- 5 + | MkGetUserByName GetUserByName -- 5 (bis) + | MkModUser ModUser -- 6 + --| MkEditProfileContent EditProfileContent -- 7 + | MkDeleteUser DeleteUser -- 8 + | MkAddUser AddUser -- 9 + | MkCheckPermission CheckPermission -- 10 + | MkSetPermission SetPermission -- 11 + | MkSearchUser SearchUser -- 12 + +-- All possible answers from the authentication daemon (authd). +data AnswerMessage + = GotError Error -- 0 + | GotToken Logged -- 1 + | GotUser User -- 2 + | GotUserAdded UserAdded -- 3 + | GotUserEdited UserEdited -- 4 + | GotUserValidated UserValidated -- 5 + | GotUsersList UsersList -- 6 + | GotPermissionCheck PermissionCheck -- 7 + | GotPermissionSet PermissionSet -- 8 + | GotPasswordRecoverySent PasswordRecoverySent -- 9 + | GotPasswordRecovered PasswordRecovered -- 10 + | GotMatchingUsers MatchingUsers -- 11 + | GotUserDeleted UserDeleted -- 12 + | GotErrorMustBeAuthenticated ErrorMustBeAuthenticated -- 20 + | GotErrorAlreadyUsedLogin ErrorAlreadyUsedLogin -- 21 + | GotErrorMailRequired ErrorMailRequired -- 22 + | GotErrorUserNotFound ErrorUserNotFound -- 23 + | GotErrorPasswordTooShort ErrorPasswordTooShort -- 24 + | GotErrorInvalidCredentials ErrorInvalidCredentials -- 25 + | GotErrorRegistrationsClosed ErrorRegistrationsClosed -- 26 + | GotErrorInvalidLoginFormat ErrorInvalidLoginFormat -- 27 + | GotErrorInvalidEmailFormat ErrorInvalidEmailFormat -- 28 + | GotErrorAlreadyUsersInDB ErrorAlreadyUsersInDB -- 29 + | GotErrorReadOnlyProfileKeys ErrorReadOnlyProfileKeys -- 30 + | GotErrorInvalidActivationKey ErrorInvalidActivationKey -- 31 + | GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32 + | GotErrorCannotContactUser ErrorCannotContactUser -- 33 + | GotErrorInvalidRenewKey ErrorInvalidRenewKey -- 34 + +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 + (MkAskPasswordRecovery request) -> get_tuple 3 codecAskPasswordRecovery 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 + (MkGetUserByName request) -> get_tuple 5 codecGetUserByName 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 + 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) + +data DecodeError + = JSONERROR String + | UnknownError String + | UnknownNumber + +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 + _ -> Left UnknownNumber + where + -- Signature is required since the compiler's guess is wrong. + error_management :: forall a. CA.JsonCodec a -> (a -> AnswerMessage) -> Either DecodeError AnswerMessage + error_management codec f + = case (parseDecodeJSON codec string) of + (Left err) -> Left (JSONERROR err) + (Right v) -> Right (f v) + +parseDecodeJSON :: forall a. CA.JsonCodec a -> String -> Either String a +parseDecodeJSON codec str = do + json <- JSONParser.jsonParser str + lmap CA.printJsonDecodeError (CA.decode codec json) + +serialize :: RequestMessage -> Effect ArrayBuffer +serialize request + = case (encode request) of + (Tuple messageTypeNumber string) -> IPC.toTypedIPC messageTypeNumber string + +deserialize :: ArrayBuffer -> Effect (Either DecodeError AnswerMessage) +deserialize arraybuffer + = do + value <- liftEffect $ IPC.fromTypedIPC arraybuffer + pure $ case (value) of + Left err -> Left (UnknownError $ show err) + Right (Tuple messageTypeNumber string) -> case (decode (toInt messageTypeNumber) string) of + Left parsingError -> Left parsingError + Right answerMessage -> Right answerMessage