{-# 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")