diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Cors.hs | 25 | ||||
| -rw-r--r-- | src/Data/ContactData.hs | 22 | ||||
| -rw-r--r-- | src/Data/StandardErrorResponseData.hs | 18 | ||||
| -rw-r--r-- | src/Data/VersionsData.hs | 17 | ||||
| -rw-r--r-- | src/Data/WellKnownClientData.hs | 34 | ||||
| -rw-r--r-- | src/Data/WellKnownSupportData.hs | 21 | ||||
| -rw-r--r-- | src/Endpoints/APILib.hs | 11 | ||||
| -rw-r--r-- | src/Endpoints/ServerLib.hs | 12 | ||||
| -rw-r--r-- | src/Endpoints/VersionsEndpoint.hs | 12 | ||||
| -rw-r--r-- | src/Endpoints/WellKnownClientEndpoint.hs | 12 | ||||
| -rw-r--r-- | src/Endpoints/WellKnownSupportEndpoint.hs | 18 | ||||
| -rw-r--r-- | src/Lib.hs | 305 | ||||
| -rw-r--r-- | src/Lib_old.hs | 325 |
13 files changed, 535 insertions, 297 deletions
diff --git a/src/Cors.hs b/src/Cors.hs new file mode 100644 index 0000000..ccfcec5 --- /dev/null +++ b/src/Cors.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cors (corsMiddleware) where + +import Network.Wai.Middleware.Cors + ( simpleCorsResourcePolicy + , cors + , CorsResourcePolicy(..) + ) +import Network.Wai (Middleware) +import Data.ByteString (ByteString) + +matrixCorsPolicy :: CorsResourcePolicy +matrixCorsPolicy = simpleCorsResourcePolicy + { corsOrigins = Just ([], True) -- Access-Control-Allow-Origin: * + , corsMethods = [ "GET", "POST", "PUT", "DELETE", "OPTIONS" ] + , corsRequestHeaders = + [ "X-Requested-With" + , "Content-Type" + , "Authorization" + ] + } + +corsMiddleware :: Middleware +corsMiddleware = cors (const $ Just matrixCorsPolicy) diff --git a/src/Data/ContactData.hs b/src/Data/ContactData.hs new file mode 100644 index 0000000..397c465 --- /dev/null +++ b/src/Data/ContactData.hs @@ -0,0 +1,22 @@ +{-# 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 new file mode 100644 index 0000000..f6fda87 --- /dev/null +++ b/src/Data/StandardErrorResponseData.hs @@ -0,0 +1,18 @@ +{-# 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/VersionsData.hs b/src/Data/VersionsData.hs new file mode 100644 index 0000000..fe41763 --- /dev/null +++ b/src/Data/VersionsData.hs @@ -0,0 +1,17 @@ +{-# 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 new file mode 100644 index 0000000..310002d --- /dev/null +++ b/src/Data/WellKnownClientData.hs @@ -0,0 +1,34 @@ +{-# 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 new file mode 100644 index 0000000..94e434c --- /dev/null +++ b/src/Data/WellKnownSupportData.hs @@ -0,0 +1,21 @@ +{-# 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/Endpoints/APILib.hs b/src/Endpoints/APILib.hs new file mode 100644 index 0000000..9c89492 --- /dev/null +++ b/src/Endpoints/APILib.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module Endpoints.APILib (API) where + +import Servant +import Endpoints.WellKnownClientEndpoint +import Endpoints.WellKnownSupportEndpoint +import Endpoints.VersionsEndpoint + +type API = WellKnownClientAPI :<|> WellKnownSupportAPI :<|> VersionsAPI diff --git a/src/Endpoints/ServerLib.hs b/src/Endpoints/ServerLib.hs new file mode 100644 index 0000000..cae6928 --- /dev/null +++ b/src/Endpoints/ServerLib.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeOperators #-} + +module Endpoints.ServerLib (server) where + +import Endpoints.WellKnownClientEndpoint +import Endpoints.WellKnownSupportEndpoint +import Endpoints.APILib +import Endpoints.VersionsEndpoint +import Servant + +server :: Server API +server = handleWellKnownClient :<|> handleWellKnownSupport :<|> handleVersions diff --git a/src/Endpoints/VersionsEndpoint.hs b/src/Endpoints/VersionsEndpoint.hs new file mode 100644 index 0000000..79fd3ea --- /dev/null +++ b/src/Endpoints/VersionsEndpoint.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Endpoints.VersionsEndpoint (VersionsAPI, handleVersions) where + +import Servant +import Data.VersionsData + +type VersionsAPI = "_matrix" :> "client" :> "versions" :> Get '[JSON] Versions + +handleVersions :: Handler Versions +handleVersions = return (makeVersions ["1.12"]) diff --git a/src/Endpoints/WellKnownClientEndpoint.hs b/src/Endpoints/WellKnownClientEndpoint.hs new file mode 100644 index 0000000..d091b1d --- /dev/null +++ b/src/Endpoints/WellKnownClientEndpoint.hs @@ -0,0 +1,12 @@ +{-# 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/WellKnownSupportEndpoint.hs b/src/Endpoints/WellKnownSupportEndpoint.hs new file mode 100644 index 0000000..b6104ae --- /dev/null +++ b/src/Endpoints/WellKnownSupportEndpoint.hs @@ -0,0 +1,18 @@ +{-# 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" + ) @@ -2,6 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DuplicateRecordFields #-} module Lib ( startApp @@ -10,314 +11,24 @@ module Lib , type (:<|>) ) where -import Data.Aeson -import Data.Aeson.TH +-- Servant 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 +-- Utils +import Cors -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 +-- Endpoints +import Endpoints.APILib +import Endpoints.ServerLib startApp :: IO () startApp = run 8080 (logStdoutDev app) app :: Application -app = serve api server +app = corsMiddleware $ 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/Lib_old.hs b/src/Lib_old.hs new file mode 100644 index 0000000..7dd1d1c --- /dev/null +++ b/src/Lib_old.hs @@ -0,0 +1,325 @@ +{-# 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") |