diff options
Diffstat (limited to 'src')
27 files changed, 432 insertions, 521 deletions
diff --git a/src/Cors.hs b/src/Cors.hs index ccfcec5..906c7cc 100644 --- a/src/Cors.hs +++ b/src/Cors.hs @@ -8,16 +8,16 @@ import Network.Wai.Middleware.Cors , CorsResourcePolicy(..) ) import Network.Wai (Middleware) -import Data.ByteString (ByteString) matrixCorsPolicy :: CorsResourcePolicy matrixCorsPolicy = simpleCorsResourcePolicy - { corsOrigins = Just ([], True) -- Access-Control-Allow-Origin: * + { corsOrigins = Nothing -- Access-Control-Allow-Origin: * , corsMethods = [ "GET", "POST", "PUT", "DELETE", "OPTIONS" ] , corsRequestHeaders = [ "X-Requested-With" , "Content-Type" , "Authorization" + , "Date" ] } diff --git a/src/Data/ContactData.hs b/src/Data/ContactData.hs deleted file mode 100644 index 397c465..0000000 --- a/src/Data/ContactData.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Data.ContactData (Contact, makeContact) where - -import Data.Aeson -import Data.Aeson.TH -import GHC.Generics (Generic) - -type EMail = String -type MXID = String - -data Contact = Contact - { email_address :: EMail - , matrix_id :: MXID - , role :: String -- Enum? [m.role.admin, m.role.security] - } deriving (Eq, Show, Generic) - -instance FromJSON Contact where -instance ToJSON Contact where - -makeContact :: String -> String -> String -> Contact -makeContact = Contact diff --git a/src/Data/StandardErrorResponseData.hs b/src/Data/StandardErrorResponseData.hs deleted file mode 100644 index f6fda87..0000000 --- a/src/Data/StandardErrorResponseData.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Data.StandardErrorResponseData (StandardErrorResponse, makeStandardErrorResponse) where - -import Data.Aeson -import Data.Aeson.TH -import GHC.Generics (Generic) - -data StandardErrorResponse = StandardErrorResponse - { errcode :: String -- TODO: Enum? - , error :: String - } deriving (Eq, Show, Generic) - -instance FromJSON StandardErrorResponse where -instance ToJSON StandardErrorResponse where - -makeStandardErrorResponse :: String -> String -> StandardErrorResponse -makeStandardErrorResponse = StandardErrorResponse diff --git a/src/Data/User.hs b/src/Data/User.hs new file mode 100644 index 0000000..9064d36 --- /dev/null +++ b/src/Data/User.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + + +module Data.User where + +import Database.Persist.TH +import Data.Text + +---------------------------------------------------------------------------------------------------- +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| +User + ident Text + password Text + displayName Text Maybe -- Figure snake_case out + avatarUrl Text Maybe -- Figure snake_case out + UniqueName ident + deriving Show +|] diff --git a/src/Data/VersionsData.hs b/src/Data/VersionsData.hs deleted file mode 100644 index fe41763..0000000 --- a/src/Data/VersionsData.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Data.VersionsData (Versions, makeVersions) where - -import Data.Aeson -import Data.Aeson.TH -import GHC.Generics (Generic) - -data Versions = Versions -- unstable_features missing - { versions :: [String] - } deriving (Eq, Show, Generic) - -instance FromJSON Versions where -instance ToJSON Versions where - -makeVersions :: [String] -> Versions -makeVersions = Versions diff --git a/src/Data/WellKnownClientData.hs b/src/Data/WellKnownClientData.hs deleted file mode 100644 index 310002d..0000000 --- a/src/Data/WellKnownClientData.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Data.WellKnownClientData (WellKnownClient, makeWellKnownClient) where - -import Data.Aeson -import Data.Aeson.TH -import GHC.Generics (Generic) - -data BaseUrlHolder = BaseUrlHolder - { base_url :: String - } deriving (Eq, Show, Generic) - -instance FromJSON BaseUrlHolder where -instance ToJSON BaseUrlHolder where - -data WellKnownClient = WellKnownClient - { homeserver :: BaseUrlHolder - , identity_server :: BaseUrlHolder - } deriving (Eq, Show, Generic) - -fieldMapping :: String -> String -fieldMapping "homeserver" = "m.homeserver" -fieldMapping "identity_server" = "m.identity_server" -fieldMapping name = name - -instance FromJSON WellKnownClient where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fieldMapping } - -instance ToJSON WellKnownClient where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = fieldMapping } - -makeWellKnownClient :: String -> String -> WellKnownClient -makeWellKnownClient homeserver identity_server = - WellKnownClient (BaseUrlHolder homeserver) (BaseUrlHolder identity_server) diff --git a/src/Data/WellKnownSupportData.hs b/src/Data/WellKnownSupportData.hs deleted file mode 100644 index 94e434c..0000000 --- a/src/Data/WellKnownSupportData.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Data.WellKnownSupportData (WellKnownSupport, makeWellKnownSupport) where - -import Data.Aeson -import Data.Aeson.TH -import GHC.Generics (Generic) -import Data.ContactData - -type URI = String - -data WellKnownSupport = WellKnownSupport - { contacts :: [Contact] - , support_page :: URI - } deriving (Eq, Show, Generic) - -instance FromJSON WellKnownSupport where -instance ToJSON WellKnownSupport where - -makeWellKnownSupport :: [Contact] -> URI -> WellKnownSupport -makeWellKnownSupport = WellKnownSupport diff --git a/src/Database.hs b/src/Database.hs new file mode 100644 index 0000000..1bc7a6b --- /dev/null +++ b/src/Database.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database (runDb, runMigrations) where + +import Control.Monad.Logger (runStderrLoggingT, LoggingT) +import Database.Persist.Sqlite (createSqlitePool, SqlBackend, runSqlPool, runMigration) +import Control.Monad.Reader (ReaderT) +import Data.User (migrateAll) + +-- | Run a database query in the IO monad. +runDb :: ReaderT SqlBackend (LoggingT IO) a -> IO a +runDb query = runStderrLoggingT $ do + pool <- createSqlitePool "jamaa.db" 10 + runSqlPool query pool + +-- | Run database migrations. +runMigrations :: IO () +runMigrations = runDb $ runMigration migrateAll diff --git a/src/Endpoints/APILib.hs b/src/Endpoints/APILib.hs index 9c89492..1db3f47 100644 --- a/src/Endpoints/APILib.hs +++ b/src/Endpoints/APILib.hs @@ -4,8 +4,14 @@ module Endpoints.APILib (API) where import Servant -import Endpoints.WellKnownClientEndpoint -import Endpoints.WellKnownSupportEndpoint + +import Endpoints.WellKnownEndpoint import Endpoints.VersionsEndpoint +import Endpoints.LoginEndpoint +import Endpoints.ProfileEndpoint -type API = WellKnownClientAPI :<|> WellKnownSupportAPI :<|> VersionsAPI +---------------------------------------------------------------------------------------------------- +type API = WellKnownAPI + :<|> VersionsAPI + :<|> LoginAPI + :<|> ProfileAPI diff --git a/src/Endpoints/LoginEndpoint.hs b/src/Endpoints/LoginEndpoint.hs new file mode 100644 index 0000000..ad4a514 --- /dev/null +++ b/src/Endpoints/LoginEndpoint.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Endpoints.LoginEndpoint (LoginAPI, loginServer) where + +import Servant +import Data.Aeson +import Database (runDb) +import Database.Persist +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Crypto.BCrypt (validatePassword) +import qualified Data.ByteString.Base16 as Base16 + +import Model.Login +import Model.MatrixErrorResponse +import Data.User + +---------------------------------------------------------------------------------------------------- +type LoginAPI = GetLogin :<|> PostLogin + +loginServer :: Server LoginAPI +loginServer = handleLoginGet :<|> handleLoginPost + +--- GET /_matrix/client/v3/login ------------------------------------------------------------------- +type GetLogin = "_matrix" :> "client" :> "v3" :> "login" + :> Get '[JSON] LoginFlowsResponse + +handleLoginGet :: Handler LoginFlowsResponse +handleLoginGet = return $ LoginFlowsResponse [LoginFlow "m.login.password"] + +--- POST /_matrix/client/v3/login ------------------------------------------------------------------ +type PostLogin = "_matrix" :> "client" :> "v3" :> "login" :> ReqBody '[JSON] LoginRequest + :> Post '[JSON] LoginResponse + +handleLoginPost :: LoginRequest -> Handler LoginResponse +handleLoginPost req = do + let + input_password = password req + username = T.unpack $ user $ identifier req + + maybe_user <- liftIO $ runDb $ getBy $ UniqueName $ T.pack username + + case maybe_user of + Just (Entity _ db_user) -> do + case Base16.decode $ T.encodeUtf8 $ userPassword db_user of + Right hashedPasswordBytes -> + if validatePassword hashedPasswordBytes (T.encodeUtf8 input_password) + then return $ LoginResponse + { user_id = T.pack ("@" ++ username ++ ":localhost") + , access_token = T.pack ("dummy" ++ username) + , home_server = "localhost" + , device_id = "DUMMY" + } + else throwError $ err403 { errBody = encode invalid_credentials_error } + Left _ -> throwError $ err500 { errBody = encode password_decoding_error } + _ -> throwError $ err403 { errBody = encode invalid_username_error } + where + invalid_username_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username" + password_decoding_error = MatrixErrorResponse "M_UNKNOWN" "Password hash decoding failed" + invalid_credentials_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username or password"
\ No newline at end of file diff --git a/src/Endpoints/ProfileEndpoint.hs b/src/Endpoints/ProfileEndpoint.hs new file mode 100644 index 0000000..8aaaa52 --- /dev/null +++ b/src/Endpoints/ProfileEndpoint.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +module Endpoints.ProfileEndpoint (ProfileAPI, profileServer) where + +import Servant +import Data.Aeson +import Data.Text (Text, pack) +import qualified Data.Text as T +import Database.Persist +import Database (runDb) +import Control.Monad.IO.Class (liftIO) + +import Data.User (User(..), Unique(UniqueName)) +import Model.Profile +import Model.MatrixErrorResponse + +---------------------------------------------------------------------------------------------------- +type ProfileAPI = GetProfile + +profileServer :: Server ProfileAPI +profileServer = handleProfileGet + +--- GET /_matrix/client/v3/profile/{userId} -------------------------------------------------------- +type GetProfile = "_matrix" :> "client" :> "v3" :> "profile" :> Capture "userId" Text + :> Get '[JSON] ProfileResponse + +handleProfileGet :: Text -> Handler ProfileResponse +handleProfileGet user_id = do + let username = T.takeWhile (/= ':') $ T.drop 1 user_id + maybe_user <- liftIO $ runDb $ getBy $ UniqueName username + + case maybe_user of + Just (Entity _ db_user) -> + return $ ProfileResponse + { display_name = (userDisplayName db_user) <> (Just $ userIdent $ db_user) + , avatar_url = userAvatarUrl db_user + , tz = Nothing + } + Nothing -> + throwError err404 { errBody = encode user_not_found_error } + where + user_not_found_error = (MatrixErrorResponse (pack "M_NOT_FOUND") (pack "Profile not found"))
\ No newline at end of file diff --git a/src/Endpoints/ServerLib.hs b/src/Endpoints/ServerLib.hs index cae6928..7bcf72a 100644 --- a/src/Endpoints/ServerLib.hs +++ b/src/Endpoints/ServerLib.hs @@ -2,11 +2,17 @@ module Endpoints.ServerLib (server) where -import Endpoints.WellKnownClientEndpoint -import Endpoints.WellKnownSupportEndpoint +import Servant + +import Endpoints.WellKnownEndpoint import Endpoints.APILib import Endpoints.VersionsEndpoint -import Servant +import Endpoints.LoginEndpoint +import Endpoints.ProfileEndpoint +---------------------------------------------------------------------------------------------------- server :: Server API -server = handleWellKnownClient :<|> handleWellKnownSupport :<|> handleVersions +server = wellKnownServer + :<|> versionsServer + :<|> loginServer + :<|> profileServer diff --git a/src/Endpoints/VersionsEndpoint.hs b/src/Endpoints/VersionsEndpoint.hs index 79fd3ea..e5739cf 100644 --- a/src/Endpoints/VersionsEndpoint.hs +++ b/src/Endpoints/VersionsEndpoint.hs @@ -1,12 +1,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -module Endpoints.VersionsEndpoint (VersionsAPI, handleVersions) where +module Endpoints.VersionsEndpoint (VersionsAPI, versionsServer) where import Servant -import Data.VersionsData +import Data.Text (pack) -type VersionsAPI = "_matrix" :> "client" :> "versions" :> Get '[JSON] Versions +import Model.Versions -handleVersions :: Handler Versions -handleVersions = return (makeVersions ["1.12"]) +---------------------------------------------------------------------------------------------------- +type VersionsAPI = GetVersions + +versionsServer :: Server VersionsAPI +versionsServer = handleVersionsGet +-- http://localhost:8080 +--- GET /_matrix/client/versions ------------------------------------------------------------------- +type GetVersions = "_matrix" :> "client" :> "versions" + :> Get '[JSON] VersionsResponse + +handleVersionsGet :: Handler VersionsResponse +handleVersionsGet = return $ VersionsResponse [pack "v1.12"] diff --git a/src/Endpoints/WellKnownClientEndpoint.hs b/src/Endpoints/WellKnownClientEndpoint.hs deleted file mode 100644 index d091b1d..0000000 --- a/src/Endpoints/WellKnownClientEndpoint.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - -module Endpoints.WellKnownClientEndpoint (WellKnownClientAPI, handleWellKnownClient) where - -import Servant -import Data.WellKnownClientData - -type WellKnownClientAPI = ".well-known" :> "matrix" :> "client" :> Get '[JSON] WellKnownClient - -handleWellKnownClient :: Handler WellKnownClient -handleWellKnownClient = return (makeWellKnownClient "http://localhost:8080" "http://localhost:8080") diff --git a/src/Endpoints/WellKnownEndpoint.hs b/src/Endpoints/WellKnownEndpoint.hs new file mode 100644 index 0000000..c63c5e5 --- /dev/null +++ b/src/Endpoints/WellKnownEndpoint.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Endpoints.WellKnownEndpoint (WellKnownAPI, wellKnownServer) where + +import Servant +import Data.Text (pack) + +import Model.WellKnown + +---------------------------------------------------------------------------------------------------- + +type WellKnownAPI = GetWellKnownClient :<|> GetWellKnownSupport + +wellKnownServer :: Server WellKnownAPI +wellKnownServer = handleWellKnownClientGet :<|> handleWellKnownSupportGet +--- GET /.well-known/matrix/client ----------------------------------------------------------------- + +type GetWellKnownClient = ".well-known" :> "matrix" :> "client" + :> Get '[JSON] WellKnownClientResponse + +handleWellKnownClientGet :: Handler WellKnownClientResponse +handleWellKnownClientGet = return $ WellKnownClientResponse + { homeserver = BaseUrlHolder (pack "http://localhost:8080") + , identity_server = BaseUrlHolder (pack "https://vector.im") + } + +--- GET /.well-known/matrix/support ---------------------------------------------------------------- +type GetWellKnownSupport = ".well-known" :> "matrix" :> "support" + :> Get '[JSON] WellKnownSupportResponse + +handleWellKnownSupportGet :: Handler WellKnownSupportResponse +handleWellKnownSupportGet = return $ WellKnownSupportResponse + { contacts = [Contact (pack "email") (pack "mxid") (pack "m.role.admin")] + , support_page = pack "http://localhost:8080/support.html" + } + diff --git a/src/Endpoints/WellKnownSupportEndpoint.hs b/src/Endpoints/WellKnownSupportEndpoint.hs deleted file mode 100644 index b6104ae..0000000 --- a/src/Endpoints/WellKnownSupportEndpoint.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - -module Endpoints.WellKnownSupportEndpoint (WellKnownSupportAPI, handleWellKnownSupport) where - -import Servant -import Data.WellKnownSupportData -import Data.ContactData - -type WellKnownSupportAPI = ".well-known" :> "matrix" :> "support" :> Get '[JSON] WellKnownSupport - -handleWellKnownSupport :: Handler WellKnownSupport -handleWellKnownSupport = - return ( - makeWellKnownSupport - [makeContact "email" "mxid" "m.role.admin"] - "http://localhost:8080/support.html" - ) diff --git a/src/Lib_old.hs b/src/Lib_old.hs deleted file mode 100644 index 7dd1d1c..0000000 --- a/src/Lib_old.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Wno-all #-} - -module Lib_old - ( startApp - , app - , type (:>) -- Syntax for importing type operator - , type (:<|>) - ) where - -import Data.Aeson -import Data.Aeson.TH -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger (logStdoutDev) -import Servant -import RenameUtils (typeFieldModifier, dotFieldModifier, replaceUsername, replaceRoomId) -import QueryUserLib -import PostLoginsResponseLib - -type JURI = String - -data EmptyObj = EmptyObj {} deriving (Eq, Show) - -$(deriveJSON defaultOptions ''EmptyObj) - -data UserInfo = UserInfo - { displayname :: String - , avatar_url :: String - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''UserInfo) - -data OAuth2InfoHolder = OAuth2InfoHolder - { issuer :: String - , account :: String - } deriving (Eq, Show) - -data BaseURLHolder = BaseURLHolder - { base_url :: JURI - } deriving (Eq, Show) - -data WellKnown = WellKnown - { m__homeserver :: BaseURLHolder - , m__identity_server :: BaseURLHolder - , org__matrix__msc2965__authentication :: OAuth2InfoHolder - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''BaseURLHolder) -$(deriveJSON defaultOptions ''OAuth2InfoHolder) -$(deriveJSON defaultOptions { fieldLabelModifier = dotFieldModifier } ''WellKnown) - -data Versions = Versions - { versions :: [String] - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''Versions) - -data LoginFlow = LoginFlow - { type__ :: String - } deriving (Eq, Show) - -data GetLoginsResponse = GetLoginsResponse - { flows :: [LoginFlow] - } deriving (Eq, Show) - -$(deriveJSON defaultOptions {fieldLabelModifier = typeFieldModifier} ''LoginFlow) -$(deriveJSON defaultOptions ''GetLoginsResponse) - -$(deriveJSON defaultOptions ''PostLoginsResponse) - -type UserId = String - -data RegisterResponse = RegisterResponse - { user_id :: UserId - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''RegisterResponse) - -data MASAviableable = MASAviableable - { available :: Bool - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''MASAviableable) - -data Synced = Synced - { synced :: Bool - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''Synced) - -$(deriveJSON defaultOptions ''QueryUser) - -data Rooms = Rooms - { join :: JoinedRooms - } deriving (Eq, Show) - -data JoinedRooms = JoinedRooms - {slay :: JoinedRoom - } deriving (Eq, Show) - -data JoinedRoom = JoinedRoom - { timeline :: Timeline - } deriving (Eq, Show) - -data Timeline = Timeline - { events :: [Message] - } deriving (Eq, Show) - -data Message = Message - { content :: TextMessageContent - , event_id :: String - , origin_server_ts :: String - , sender :: String - , type___ :: String - , state_key :: String - } deriving (Eq, Show) - -data TextMessageContent = TextMessageContent - { body :: String - -- , msgtype :: String - , creator :: String - , membership :: String - , join_rule :: String - } deriving (Eq, Show) - -data Sync = Sync - { next_batch :: String - , rooms :: Rooms - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''TextMessageContent) -$(deriveJSON defaultOptions { fieldLabelModifier = typeFieldModifier} ''Message) -$(deriveJSON defaultOptions ''Timeline) -$(deriveJSON defaultOptions ''JoinedRoom) -$(deriveJSON defaultOptions { fieldLabelModifier = replaceRoomId } ''JoinedRooms) -$(deriveJSON defaultOptions ''Rooms) -$(deriveJSON defaultOptions ''Sync) - -data Keys = Keys - { one_time_key_counts :: EmptyObj - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''Keys) --- ⚠️ This is the key import! -data KeysHolder = KeysHolder - { username :: [String] - } deriving (Eq, Show) - -data KeysQuery = KeysQuery - { device_keys :: KeysHolder - , master_keys :: EmptyObj - , self_signing_keys :: EmptyObj - , user_signing_keys :: EmptyObj - } deriving (Eq, Show) - -$(deriveJSON defaultOptions { fieldLabelModifier = replaceUsername } ''KeysHolder) -$(deriveJSON defaultOptions ''KeysQuery) - -data RoomId = RoomId - {room_id :: String - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''RoomId) - -data GetRooms = GetRooms - { chunk :: [Message] - , end :: String - , start :: String - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GetRooms) - -type API = ".well-known" :> "matrix" :> "client" :> Get '[JSON] WellKnown - :<|> "_matrix" :> "client" :> "versions" :> Get '[JSON] Versions - :<|> "_matrix" :> "client" :> "v3" :> "login" :> Get '[JSON] GetLoginsResponse - :<|> "_matrix" :> "client" :> "r0" :> "login" :> Get '[JSON] GetLoginsResponse - :<|> "_matrix" :> "client" :> "v3" :> "login" :> Post '[JSON] PostLoginsResponse - :<|> "_matrix" :> "client" :> "r0" :> "login" :> Post '[JSON] PostLoginsResponse - :<|> "_matrix" :> "client" :> "v3" :> "register" :> Post '[JSON] RegisterResponse - :<|> "_synapse" :> "mas" :> "is_localpart_available" :> Get '[JSON] MASAviableable - :<|> "_synapse" :> "mas" :> "provision_user" :> Post '[JSON] RegisterResponse - :<|> "_synapse" :> "mas" :> "sync_devices" :> Post '[JSON] Synced - :<|> "_synapse" :> "mas" :> "query_user" :> Get '[JSON] QueryUser - :<|> "_matrix" :> "client" :> "v3" :> "profile" :> "@username:localhost:8080" :> Get '[JSON] UserInfo - :<|> "_matrix" :> "client" :> "r0" :> "profile" :> "@username:localhost:8080" :> Get '[JSON] UserInfo - :<|> "_matrix" :> "client" :> "v3" :> "sync" :> Get '[JSON] Sync - :<|> "_matrix" :> "client" :> "r0" :> "sync" :> Get '[JSON] Sync - :<|> "_matrix" :> "client" :> "v3" :> "keys" :> "query" :> Post '[JSON] Keys - :<|> "_matrix" :> "client" :> "r0" :> "keys" :> "query" :> Post '[JSON] Keys - :<|> "_matrix" :> "client" :> "v3" :> "keys" :> "upload" :> Post '[JSON] KeysQuery - :<|> "_matrix" :> "client" :> "r0" :> "keys" :> "upload" :> Post '[JSON] KeysQuery - :<|> "_matrix" :> "client" :> "v3" :> "createRoom" :> Post '[JSON] RoomId - :<|> "_matrix" :> "client" :> "r0" :> "createRoom" :> Post '[JSON] RoomId - :<|> "_matrix" :> "client" :> "v3" :> "rooms" :> "!slay:localhost:8080" :> "messages" :> Get '[JSON] GetRooms - :<|> "_matrix" :> "client" :> "r0" :> "rooms" :> "!slay:localhost:8080" :> "messages" :> Get '[JSON] GetRooms - :<|> "_matrix" :> "client" :> "v3" :> "rooms" :> "!slay:localhost:8080" :> "members" :> Get '[JSON] GetRooms - :<|> "_matrix" :> "client" :> "r0" :> "rooms" :> "!slay:localhost:8080" :> "members" :> Get '[JSON] GetRooms - -startApp :: IO () -startApp = run 8080 (logStdoutDev app) - -app :: Application -app = serve api server - -api :: Proxy API -api = Proxy - -server :: Server API -server = wellKnownSuccess - :<|> versionsSuccess - :<|> getLoginSuccess - :<|> getLoginSuccess - :<|> postLoginSuccess - :<|> postLoginSuccess - :<|> registerResponse - :<|> masLocalpartAviableable - :<|> masProvision - :<|> masSynced - :<|> masQueryUser - :<|> getProfile - :<|> getProfile - :<|> sync - :<|> sync - :<|> keys - :<|> keys - :<|> keysQuery - :<|> keysQuery - :<|> createRoom - :<|> createRoom - :<|> getRoomContent - :<|> getRoomContent - :<|> getRoomMembers - :<|> getRoomMembers - -wellKnownSuccess :: Handler WellKnown -wellKnownSuccess = return (WellKnown - (BaseURLHolder "http://localhost:8080") - (BaseURLHolder "https://vector.im") - (OAuth2InfoHolder "http://localhost:8000/" "http://localhost:8000/account/") - ) - -versionsSuccess :: Handler Versions -versionsSuccess = return (Versions ["1.10"]) - -getLoginSuccess :: Handler GetLoginsResponse -getLoginSuccess = return (GetLoginsResponse [LoginFlow "m.login.sso"]) - -postLoginSuccess :: Handler PostLoginsResponse -postLoginSuccess = return (makePostLoginsResponse "token" "tammy" "@username:localhost:8080") - -registerResponse :: Handler RegisterResponse -registerResponse = return (RegisterResponse "@username:localhost:8080") - -masLocalpartAviableable :: Handler MASAviableable -masLocalpartAviableable = return (MASAviableable True) - -masProvision :: Handler RegisterResponse -masProvision = return (RegisterResponse "@username:localhost:8080") - -masSynced :: Handler Synced -masSynced = return (Synced True) - -masQueryUser :: Handler QueryUser -masQueryUser = return (makeQueryUser "username" "@username:localhost:8080" "username" False) - -getProfile :: Handler UserInfo -getProfile = return (UserInfo "username" "mxc://matrix.org/SDGdghriugerRg") - -getMessageContentTempl :: String -> String -> String -> String -> Message -getMessageContentTempl msgtype eventId time state_key = (Message - ( - TextMessageContent - "Hiii" - -- "m.text" - "@username:localhost:8000" - "join" - "public" - ) - eventId - time - "@username:localhost:8000" - msgtype - state_key - ) - -messages :: [Message] -messages = [ - getMessageContentTempl "m.room.create" "$make" "1757771812" "", - -- getMessageContentTempl "m.room.join_rules", - getMessageContentTempl "m.room.member" "$join" "1757771814" "@username:localhost:8000" - -- getMessageContentTempl "m.room.message" "$msg" "1757771816" "" - ] - -sync :: Handler Sync -sync = return (Sync - "a" - (Rooms ( - JoinedRooms ( - JoinedRoom ( - Timeline messages - ) - ) - )) - ) - - -keys :: Handler Keys -keys = return (Keys EmptyObj) - -keysQuery :: Handler KeysQuery -keysQuery = return (KeysQuery (KeysHolder []) EmptyObj EmptyObj EmptyObj) - -createRoom :: Handler RoomId -createRoom = return (RoomId "!slay:localhost:8080") - -getRoomContent :: Handler GetRooms -getRoomContent = return (GetRooms messages "a" "a") - -getRoomMembers :: Handler GetRooms -getRoomMembers = return (GetRooms [getMessageContentTempl "m.room.member" "$join" "1757771814" "@username:localhost:8080"] "a" "a") diff --git a/src/Model/Authentication.hs b/src/Model/Authentication.hs new file mode 100644 index 0000000..be1337a --- /dev/null +++ b/src/Model/Authentication.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Authentication (AuthenticationResponse (..)) where + +import GHC.Generics +import Data.Text (Text) + +---------------------------------------------------------------------------------------------------- +data AuthenticationResponse = AuthenticationResponse -- delete? + { userId :: Text + } + deriving (Show, Eq, Generic) diff --git a/src/Model/Login.hs b/src/Model/Login.hs new file mode 100644 index 0000000..0fbb2fa --- /dev/null +++ b/src/Model/Login.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Model.Login (LoginRequest (..), LoginResponse (..), LoginFlowsResponse (..), LoginFlow (..), PasswordIdentifier (..)) where + +import Data.Aeson +import GHC.Generics +import Data.Text (Text) + +import Util (Normalisable(..)) + +type UserId = Text + +---------------------------------------------------------------------------------------------------- +data PasswordIdentifier = PasswordIdentifier + { user :: UserId + } + deriving (Show, Eq, Generic) + +instance FromJSON PasswordIdentifier + +data LoginRequest = LoginRequest + { identifier :: PasswordIdentifier + , password :: Text + , type' :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON LoginRequest where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = normaliseVariant } + +---------------------------------------------------------------------------------------------------- +data LoginResponse = LoginResponse + { user_id :: UserId + , access_token :: Text + , home_server :: Text + , device_id :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON LoginResponse + +---------------------------------------------------------------------------------------------------- +newtype LoginFlowsResponse = LoginFlowsResponse + { flows :: [LoginFlow] -- TODO: Enum? + } + deriving (Show, Eq, Generic) + +instance ToJSON LoginFlowsResponse + +newtype LoginFlow = LoginFlow -- TODO: Maybe type LoginFlow = ... easier? + { type' :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON LoginFlow where + toJSON (LoginFlow t) = object ["type" .= t] diff --git a/src/Model/MatrixErrorResponse.hs b/src/Model/MatrixErrorResponse.hs new file mode 100644 index 0000000..22f5ae5 --- /dev/null +++ b/src/Model/MatrixErrorResponse.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.MatrixErrorResponse (MatrixErrorResponse (..)) where + +import Data.Aeson +import GHC.Generics (Generic) +import Data.Text (Text) + +---------------------------------------------------------------------------------------------------- +data MatrixErrorResponse = MatrixErrorResponse + { error_code :: Text -- TODO: Enum? + , error :: Text + } deriving (Eq, Show, Generic) + +instance ToJSON MatrixErrorResponse where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = \name -> + case name of + "error_code" -> "errcode" + other -> other + } diff --git a/src/Model/Profile.hs b/src/Model/Profile.hs new file mode 100644 index 0000000..1a8f201 --- /dev/null +++ b/src/Model/Profile.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Model.Profile (ProfileResponse (..)) where + +import Data.Aeson +import GHC.Generics +import Data.Text (Text) + +---------------------------------------------------------------------------------------------------- +data ProfileResponse = ProfileResponse + { display_name :: Maybe Text + , avatar_url :: Maybe Text + , tz :: Maybe Text + -- TODO: <other properties> + } deriving (Show, Eq, Generic) + +instance ToJSON ProfileResponse where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = \name -> + case name of + "display_name" -> "displayname" + "tz" -> "m.tz" + other -> other + , omitNothingFields = True + } diff --git a/src/Model/Versions.hs b/src/Model/Versions.hs new file mode 100644 index 0000000..478d5f3 --- /dev/null +++ b/src/Model/Versions.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Versions (VersionsResponse (..)) where + +import Data.Aeson +import GHC.Generics (Generic) +import Data.Text (Text) + +---------------------------------------------------------------------------------------------------- + +data VersionsResponse = VersionsResponse -- TODO: <unstable features> + { versions :: [Text] + } deriving (Eq, Show, Generic) + +instance ToJSON VersionsResponse where diff --git a/src/Model/WellKnown.hs b/src/Model/WellKnown.hs new file mode 100644 index 0000000..066c9e3 --- /dev/null +++ b/src/Model/WellKnown.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.WellKnown (WellKnownClientResponse (..) + , BaseUrlHolder (..) + , WellKnownSupportResponse (..) + , Contact (..) + ) where + +import Data.Aeson +import GHC.Generics (Generic) +import Data.Text (Text) + +type URI = Text +type EMail = Text +type UserId = Text + +---------------------------------------------------------------------------------------------------- +data BaseUrlHolder = BaseUrlHolder + { base_url :: URI + } deriving (Eq, Show, Generic) + +instance ToJSON BaseUrlHolder where + +data WellKnownClientResponse = WellKnownClientResponse + { homeserver :: BaseUrlHolder + , identity_server :: BaseUrlHolder + } deriving (Eq, Show, Generic) + +instance ToJSON WellKnownClientResponse where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = \name -> + case name of + "homeserver" -> "m.homeserver" + "identity_server" -> "m.identity_server" + other -> other + } + +---------------------------------------------------------------------------------------------------- +data Contact = Contact + { email_address :: EMail + , matrix_id :: UserId + , role :: Text -- Enum? [m.role.admin, m.role.security] + } deriving (Eq, Show, Generic) + +instance ToJSON Contact where + +data WellKnownSupportResponse = WellKnownSupportResponse + { contacts :: [Contact] + , support_page :: URI + } deriving (Eq, Show, Generic) + +instance ToJSON WellKnownSupportResponse where
\ No newline at end of file diff --git a/src/PostLoginsResponseLib.hs b/src/PostLoginsResponseLib.hs deleted file mode 100644 index 51617b1..0000000 --- a/src/PostLoginsResponseLib.hs +++ /dev/null @@ -1,10 +0,0 @@ -module PostLoginsResponseLib (PostLoginsResponse, makePostLoginsResponse) where - -data PostLoginsResponse = PostLoginsResponse - { access_token :: String - , device_id :: String - , user_id :: String - } deriving (Eq, Show) - -makePostLoginsResponse :: String -> String -> String -> PostLoginsResponse -makePostLoginsResponse = PostLoginsResponse diff --git a/src/QueryUserLib.hs b/src/QueryUserLib.hs deleted file mode 100644 index 5677ac5..0000000 --- a/src/QueryUserLib.hs +++ /dev/null @@ -1,11 +0,0 @@ -module QueryUserLib (QueryUser, makeQueryUser) where - -data QueryUser = QueryUser - { localpart :: String - , user_id :: String - , display_name :: String - , is_guest :: Bool - } deriving (Eq, Show) - -makeQueryUser :: String -> String -> String -> Bool -> QueryUser -makeQueryUser = QueryUser diff --git a/src/RenameUtils.hs b/src/RenameUtils.hs deleted file mode 100644 index cdf36d2..0000000 --- a/src/RenameUtils.hs +++ /dev/null @@ -1,19 +0,0 @@ -module RenameUtils where - -import Data.List.Utils (startswith, replace) - -typeFieldModifier :: String -> String -typeFieldModifier "type__" = "type" -typeFieldModifier "type___" = "type" -typeFieldModifier name = name - -dotFieldModifier :: String -> String -dotFieldModifier = replace "__" "." - -replaceUsername :: String -> String -replaceUsername "username" = "@username:localhost:8080" -replaceUsername name = name - -replaceRoomId :: String -> String -replaceRoomId "slay" = "!slay:localhost:8080" -replaceRoomId name = name diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 0000000..e33e730 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Util (Normalisable(..)) where + +import Data.Maybe (fromMaybe) +import qualified Data.Text as T + +---------------------------------------------------------------------------------------------------- +class Normalisable a where + normaliseVariant :: a -> a + +instance Normalisable [Char] where + normaliseVariant = T.unpack . normaliseVariant . T.pack + +instance Normalisable T.Text where + normaliseVariant str = fromMaybe str (T.stripSuffix (T.pack "'") str) + |