halogen-websocket-ipc-playzone/src/App/Messages/AuthenticationDaemon.purs

465 lines
19 KiB
Plaintext

module App.Messages.AuthenticationDaemon 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.Email as Email
import App.UserPublic as UserPublic
import App.PermissionLevel as PermissionLevel
import Effect.Class (liftEffect)
import Data.Argonaut.Parser as JSONParser
import Data.Bifunctor (lmap)
import App.IPC as IPC
{- TODO:
For a few messages, user can be designated by a string (login) or a number (its UID).
This was simplified by using the uid for each.
Maybe this could be changed in the future to match the actual possibilities of the API.
-}
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
{-
REQUESTS
General notes:
- when the "UserID" is optional, the server will work on the requesting user
-}
{- 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