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