aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Lib.hs323
-rw-r--r--src/PostLoginsResponseLib.hs10
-rw-r--r--src/QueryUserLib.hs11
-rw-r--r--src/RenameUtils.hs19
4 files changed, 363 insertions, 0 deletions
diff --git a/src/Lib.hs b/src/Lib.hs
new file mode 100644
index 0000000..ed1d92d
--- /dev/null
+++ b/src/Lib.hs
@@ -0,0 +1,323 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedLabels #-}
+
+module Lib
+ ( 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) -- ⚠️ This is the key import!
+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)
+
+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/PostLoginsResponseLib.hs b/src/PostLoginsResponseLib.hs
new file mode 100644
index 0000000..51617b1
--- /dev/null
+++ b/src/PostLoginsResponseLib.hs
@@ -0,0 +1,10 @@
+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
new file mode 100644
index 0000000..5677ac5
--- /dev/null
+++ b/src/QueryUserLib.hs
@@ -0,0 +1,11 @@
+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
new file mode 100644
index 0000000..cdf36d2
--- /dev/null
+++ b/src/RenameUtils.hs
@@ -0,0 +1,19 @@
+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
generated by cgit v1.2.3 (git 2.39.1) at 2026-02-15 19:06:29 +0000