path: root/src/Lib.hs

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