280 lines
16 KiB
Plaintext
280 lines
16 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.Phone as Phone
|
|
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 login for each.
|
|
Maybe this could be changed in the future to match the actual possibilities of the API.
|
|
|
|
Possible requests:
|
|
- 14 type EditProfile = { token :: String, new_profile :: Hash(String, JSON::Any) }
|
|
- 15 type EditProfileContent = { token :: Maybe String, shared_key :: Maybe String, user :: Int | String | Nil, new_profile :: Hash(String, JSON::Any) }
|
|
|
|
-- Deletion can be triggered by either an admin or the user.
|
|
-}
|
|
|
|
-- Basic message types.
|
|
-- TODO: note to myself: messages seem chaotic. Could be simpler. Should be simpler.
|
|
type Error = { reason :: Maybe String }
|
|
type Token = { uid :: Int, token :: String }
|
|
type User = { user :: UserPublic.UserPublic }
|
|
type UserAdded = { user :: UserPublic.UserPublic }
|
|
type UserEdited = { uid :: Int }
|
|
type UserValidated = { user :: UserPublic.UserPublic }
|
|
type UsersList = { users :: Array UserPublic.UserPublic }
|
|
type PermissionCheck = { user :: Int, service :: String, resource :: String, permission :: PermissionLevel.PermissionLevel }
|
|
type PermissionSet = { user :: Int, service :: String, resource :: String, permission :: PermissionLevel.PermissionLevel }
|
|
type PasswordRecoverySent = { user :: UserPublic.UserPublic }
|
|
type PasswordRecovered = { user :: UserPublic.UserPublic }
|
|
type Contacts = { user :: Int, email :: Maybe Email.Email, phone :: Maybe Phone.Phone }
|
|
type MatchingUsers = { users :: Array UserPublic.UserPublic }
|
|
|
|
type Password = String
|
|
type GetToken = { login :: String, password :: String }
|
|
type AddUser = { shared_key :: String, login :: String, password :: String, email :: Maybe Email.Email, phone :: Maybe Phone.Phone } -- profile :: Maybe Hash(String, JSON::Any)
|
|
type ValidateUser = { login :: String, activation_key :: String }
|
|
-- 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 }
|
|
type GetUserByCredentials = { login :: String, password :: String }
|
|
type Register = { login :: String, password :: String, email :: Maybe Email.Email, phone :: Maybe Phone.Phone } -- profile :: Maybe Hash(String, JSON::Any)
|
|
type UpdatePassword = { login :: String, old_password :: String, new_password :: String }
|
|
type ListUsers = { token :: Maybe String, key :: Maybe String }
|
|
type CheckPermission = { shared_key :: Maybe String, token :: Maybe String, user :: String, service :: String, resource :: String }
|
|
type SetPermission = { shared_key :: String, user :: String, service :: String, resource :: String, permission :: PermissionLevel.PermissionLevel }
|
|
type PasswordRecovery = { user :: String, password_renew_key :: String, new_password :: String }
|
|
type AskPasswordRecovery = { user :: String, email :: Email.Email }
|
|
type SearchUser = { user :: String }
|
|
type EditContacts = { token :: String, email :: Maybe Email.Email, phone :: Maybe Phone.Phone }
|
|
type Delete = { shared_key :: Maybe String, login :: Maybe String, password :: Maybe String, user :: String }
|
|
type GetContacts = { token :: String }
|
|
|
|
-- Related JSON codecs.
|
|
codecGetToken ∷ CA.JsonCodec GetToken
|
|
codecGetToken = CA.object "GetToken" (CAR.record { login: CA.string, password: CA.string })
|
|
codecAddUser ∷ CA.JsonCodec AddUser
|
|
codecAddUser = CA.object "AddUser" (CAR.record { shared_key: CA.string
|
|
, login: CA.string
|
|
, password: CA.string
|
|
, email: CAR.optional Email.codec
|
|
, phone: CAR.optional Phone.codec })
|
|
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
|
codecValidateUser = CA.object "ValidateUser" (CAR.record { login: CA.string, activation_key: CA.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 })
|
|
codecGetUserByCredentials ∷ CA.JsonCodec GetUserByCredentials
|
|
codecGetUserByCredentials = CA.object "GetUserByCredentials" (CAR.record { login: CA.string, password: CA.string })
|
|
codecRegister ∷ CA.JsonCodec Register
|
|
codecRegister = CA.object "Register" (CAR.record { login: CA.string
|
|
, password: CA.string
|
|
, email: CAR.optional Email.codec
|
|
, phone: CAR.optional Phone.codec })
|
|
codecUpdatePassword ∷ CA.JsonCodec UpdatePassword
|
|
codecUpdatePassword = CA.object "UpdatePassword" (CAR.record { login: CA.string
|
|
, old_password: CA.string
|
|
, new_password: CA.string })
|
|
codecListUsers ∷ CA.JsonCodec ListUsers
|
|
codecListUsers = CA.object "ListUsers" (CAR.record { token: CAR.optional CA.string, key: CAR.optional CA.string })
|
|
codecCheckPermission ∷ CA.JsonCodec CheckPermission
|
|
codecCheckPermission = CA.object "CheckPermission" (CAR.record { shared_key: CAR.optional CA.string
|
|
, token: CAR.optional CA.string
|
|
, user: CA.string
|
|
, service: CA.string
|
|
, resource: CA.string })
|
|
codecSetPermission ∷ CA.JsonCodec SetPermission
|
|
codecSetPermission = CA.object "SetPermission" (CAR.record { shared_key: CA.string
|
|
, user: CA.string
|
|
, service: CA.string
|
|
, resource: CA.string
|
|
, permission: PermissionLevel.codec })
|
|
codecPasswordRecovery ∷ CA.JsonCodec PasswordRecovery
|
|
codecPasswordRecovery = CA.object "PasswordRecovery" (CAR.record { user: CA.string, password_renew_key: CA.string, new_password: CA.string })
|
|
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
|
codecAskPasswordRecovery = CA.object "AskPasswordRecovery" (CAR.record { user: CA.string, email: Email.codec })
|
|
codecSearchUser ∷ CA.JsonCodec SearchUser
|
|
codecSearchUser = CA.object "SearchUser" (CAR.record { user: CA.string })
|
|
codecEditContacts ∷ CA.JsonCodec EditContacts
|
|
codecEditContacts = CA.object "EditContacts" (CAR.record { token: CA.string, email: CAR.optional Email.codec, phone: CAR.optional Phone.codec })
|
|
codecDelete ∷ CA.JsonCodec Delete
|
|
codecDelete = CA.object "Delete" (CAR.record { shared_key: CAR.optional CA.string, login: CAR.optional CA.string, password: CAR.optional CA.string, user: CA.string })
|
|
codecGetContacts ∷ CA.JsonCodec GetContacts
|
|
codecGetContacts = CA.object "GetContacts" (CAR.record { token: CA.string })
|
|
|
|
codecGotError ∷ CA.JsonCodec Error
|
|
codecGotError = CA.object "Error" (CAR.record { reason: CAR.optional CA.string })
|
|
codecGotToken ∷ CA.JsonCodec Token
|
|
codecGotToken = CA.object "Token" (CAR.record { "uid": CA.int, "token": CA.string })
|
|
codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent
|
|
codecGotPasswordRecoverySent = CA.object "PasswordRecoverySent" (CAR.record { user: UserPublic.codec })
|
|
codecGotUser ∷ CA.JsonCodec User
|
|
codecGotUser = CA.object "User" (CAR.record { user: UserPublic.codec })
|
|
codecGotUserAdded ∷ CA.JsonCodec UserAdded
|
|
codecGotUserAdded = CA.object "UserAdded" (CAR.record { user: UserPublic.codec })
|
|
codecGotUserEdited ∷ CA.JsonCodec UserEdited
|
|
codecGotUserEdited = CA.object "UserEdited" (CAR.record { "uid": CA.int })
|
|
codecGotUserValidated ∷ CA.JsonCodec UserValidated
|
|
codecGotUserValidated = CA.object "UserValidated" (CAR.record { user: UserPublic.codec })
|
|
codecGotPasswordRecovered ∷ CA.JsonCodec PasswordRecovered
|
|
codecGotPasswordRecovered = CA.object "PasswordRecovered" (CAR.record { user: UserPublic.codec })
|
|
codecGotUsersList ∷ CA.JsonCodec UsersList
|
|
codecGotUsersList = CA.object "UsersList" (CAR.record { users: CA.array UserPublic.codec })
|
|
codecGotPermissionCheck :: CA.JsonCodec PermissionCheck
|
|
codecGotPermissionCheck = CA.object "PermissionCheck" (CAR.record { user: CA.int
|
|
, service: CA.string
|
|
, resource: CA.string
|
|
, permission: PermissionLevel.codec })
|
|
codecGotPermissionSet :: CA.JsonCodec PermissionSet
|
|
codecGotPermissionSet = CA.object "PermissionSet" (CAR.record { user: CA.int
|
|
, service: CA.string
|
|
, resource: CA.string
|
|
, permission: PermissionLevel.codec })
|
|
codecGotContacts ∷ CA.JsonCodec Contacts
|
|
codecGotContacts = CA.object "Contacts" (CAR.record { user: CA.int
|
|
, email: CAR.optional Email.codec
|
|
, phone: CAR.optional Phone.codec })
|
|
codecGotMatchingUsers ∷ CA.JsonCodec MatchingUsers
|
|
codecGotMatchingUsers = CA.object "MatchingUsers" (CAR.record { users: CA.array UserPublic.codec })
|
|
|
|
-- All possible requests.
|
|
data RequestMessage
|
|
= MkGetToken GetToken -- 0
|
|
| MkAddUser AddUser -- 1
|
|
| MkValidateUser ValidateUser -- 2
|
|
| MkGetUserByUID GetUserByUID -- 3
|
|
| MkGetUserByName GetUserByName -- 3 (bis)
|
|
| MkGetUserByCredentials GetUserByCredentials -- 4
|
|
| MkRegister Register -- 6
|
|
| MkUpdatePassword UpdatePassword -- 7
|
|
| MkListUsers ListUsers -- 8
|
|
| MkCheckPermission CheckPermission -- 9
|
|
| MkSetPermission SetPermission -- 10
|
|
| MkPasswordRecovery PasswordRecovery -- 11
|
|
| MkAskPasswordRecovery AskPasswordRecovery -- 12
|
|
| MkSearchUser SearchUser -- 13
|
|
--| MkEditProfile EditProfile -- 14
|
|
--| MkEditProfileContent EditProfileContent -- 15
|
|
| MkEditContacts EditContacts -- 16
|
|
| MkDelete Delete -- 17
|
|
| MkGetContacts GetContacts -- 18
|
|
|
|
-- All possible answers from the authentication daemon (authd).
|
|
data AnswerMessage
|
|
= GotError Error -- 0
|
|
| GotToken Token -- 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
|
|
| GotContacts Contacts -- 12
|
|
|
|
encode ∷ RequestMessage -> Tuple UInt String
|
|
encode m = case m of
|
|
(MkGetToken request) -> get_tuple 0 codecGetToken request
|
|
(MkAddUser request) -> get_tuple 1 codecAddUser request
|
|
(MkValidateUser request) -> get_tuple 2 codecValidateUser 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 3 codecGetUserByUID request
|
|
(MkGetUserByName request) -> get_tuple 3 codecGetUserByName request
|
|
(MkGetUserByCredentials request) -> get_tuple 4 codecGetUserByCredentials request
|
|
(MkRegister request) -> get_tuple 6 codecRegister request
|
|
(MkUpdatePassword request) -> get_tuple 7 codecUpdatePassword request
|
|
(MkListUsers request) -> get_tuple 8 codecListUsers request
|
|
(MkCheckPermission request) -> get_tuple 9 codecCheckPermission request
|
|
(MkSetPermission request) -> get_tuple 10 codecSetPermission request
|
|
(MkPasswordRecovery request) -> get_tuple 11 codecPasswordRecovery request
|
|
(MkAskPasswordRecovery request) -> get_tuple 12 codecAskPasswordRecovery request
|
|
(MkSearchUser request) -> get_tuple 13 codecSearchUser request
|
|
-- 14 MkEditProfile
|
|
-- 15 MkEditProfileContent
|
|
(MkEditContacts request) -> get_tuple 16 codecEditContacts request
|
|
(MkDelete request) -> get_tuple 17 codecDelete request
|
|
(MkGetContacts request) -> get_tuple 18 codecGetContacts 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 codecGotContacts GotContacts
|
|
_ -> 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
|