aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--jamaa.cabal18
-rw-r--r--make_data.sh18
-rw-r--r--make_endpoint.sh14
-rw-r--r--package.yaml2
-rw-r--r--src/Cors.hs25
-rw-r--r--src/Data/ContactData.hs22
-rw-r--r--src/Data/StandardErrorResponseData.hs18
-rw-r--r--src/Data/VersionsData.hs17
-rw-r--r--src/Data/WellKnownClientData.hs34
-rw-r--r--src/Data/WellKnownSupportData.hs21
-rw-r--r--src/Endpoints/APILib.hs11
-rw-r--r--src/Endpoints/ServerLib.hs12
-rw-r--r--src/Endpoints/VersionsEndpoint.hs12
-rw-r--r--src/Endpoints/WellKnownClientEndpoint.hs12
-rw-r--r--src/Endpoints/WellKnownSupportEndpoint.hs18
-rw-r--r--src/Lib.hs305
-rw-r--r--src/Lib_old.hs325
17 files changed, 587 insertions, 297 deletions
diff --git a/jamaa.cabal b/jamaa.cabal
index e7a274c..ea361bc 100644
--- a/jamaa.cabal
+++ b/jamaa.cabal
@@ -25,7 +25,19 @@ source-repository head
library
exposed-modules:
+ Cors
+ Data.ContactData
+ Data.StandardErrorResponseData
+ Data.VersionsData
+ Data.WellKnownClientData
+ Data.WellKnownSupportData
+ Endpoints.APILib
+ Endpoints.ServerLib
+ Endpoints.VersionsEndpoint
+ Endpoints.WellKnownClientEndpoint
+ Endpoints.WellKnownSupportEndpoint
Lib
+ Lib_old
PostLoginsResponseLib
QueryUserLib
RenameUtils
@@ -40,8 +52,10 @@ library
MissingH
, aeson
, base >=4.7 && <5
+ , bytestring
, servant-server
, wai
+ , wai-cors
, wai-extra
, warp
default-language: Haskell2010
@@ -59,9 +73,11 @@ executable jamaa-exe
MissingH
, aeson
, base
+ , bytestring
, jamaa
, servant-server
, wai
+ , wai-cors
, wai-extra
, warp
default-language: Haskell2010
@@ -80,12 +96,14 @@ test-suite jamaa-test
MissingH
, aeson
, base
+ , bytestring
, hspec
, hspec-wai
, hspec-wai-json
, jamaa
, servant-server
, wai
+ , wai-cors
, wai-extra
, warp
default-language: Haskell2010
diff --git a/make_data.sh b/make_data.sh
new file mode 100644
index 0000000..d35302c
--- /dev/null
+++ b/make_data.sh
@@ -0,0 +1,18 @@
+echo "{-# LANGUAGE DeriveGeneric #-}
+
+module Data.$1Data ($1, make$1) where
+
+import Data.Aeson
+import Data.Aeson.TH
+import GHC.Generics (Generic)
+
+data $1 = $1
+ {
+ } deriving (Eq, Show, Generic)
+
+instance FromJSON $1 where
+instance ToJSON $1 where
+
+make$1 :: -> $1
+make$1 = $1" > ./src/Data/$1Data.hs
+echo "Created $1Data.hs"
diff --git a/make_endpoint.sh b/make_endpoint.sh
new file mode 100644
index 0000000..15dbc17
--- /dev/null
+++ b/make_endpoint.sh
@@ -0,0 +1,14 @@
+touch ./src/Endpoints/$1Endpoint.hs
+echo "{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Endpoints.$1Endpoint ($1API, handle$1) where
+
+import Servant
+import Data.$1Data
+
+type $1API = \"\" :> ... '[JSON] $1
+
+handle$1 :: Handler $1
+handle$1 =" > ./src/Endpoints/$1Endpoint.hs
+echo "Created $1Endpoint.hs"
diff --git a/package.yaml b/package.yaml
index 265633c..2f352e7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,8 @@ dependencies:
- warp
- wai-extra
- MissingH
+ - bytestring
+ - wai-cors
ghc-options:
- -Wall
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"
+ )
diff --git a/src/Lib.hs b/src/Lib.hs
index bb2c104..d430d9c 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -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")
generated by cgit v1.2.3 (git 2.39.1) at 2026-02-15 17:42:24 +0000