Section 5: Capabilities complete

2 files changed, 92 insertions, 0 deletions

diff --git a/src/Endpoints/CapabilitiesEndpoint.hs b/src/Endpoints/CapabilitiesEndpoint.hs
new file mode 100644
index 0000000..92fefba
--- /dev/null
+++ b/src/Endpoints/CapabilitiesEndpoint.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Endpoints.CapabilitiesEndpoint (CapabilitiesAPI, capabilitiesServer) where
+
+import Servant
+import qualified Data.Map as Map
+
+import Model.Capabilities
+
+----------------------------------------------------------------------------------------------------
+type CapabilitiesAPI = GetCapabilities
+
+capabilitiesServer :: Server CapabilitiesAPI
+capabilitiesServer = handleCapabilitiesGet
+
+--- GET /_matrix/client/v3/capabilities ------------------------------------------------------------
+type GetCapabilities = "_matrix" :> "client" :> "v3" :> "capabilities"
+                 :> Get '[JSON] CapabilitiesResponse
+
+handleCapabilitiesGet :: Handler CapabilitiesResponse
+handleCapabilitiesGet = return $ CapabilitiesResponse
+  { pid_changes = BooleanCapability False
+  , change_password = BooleanCapability False
+  , get_login_token = BooleanCapability False
+  , profile_fields = ProfileFieldsCapability False Nothing Nothing
+  , room_versions = RoomVersionsCapability "12" $ Map.singleton "12" "stable"
+  , set_avatar_url = BooleanCapability False
+  , set_display_name = BooleanCapability False
+  }
diff --git a/src/Model/Capabilities.hs b/src/Model/Capabilities.hs
new file mode 100644
index 0000000..f6ab372
--- /dev/null
+++ b/src/Model/Capabilities.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Model.Capabilities (CapabilitiesResponse (..)
+                          , BooleanCapability (..)
+                          , ProfileFieldsCapability (..)
+                          , RoomVersionsCapability (..)
+                          ) where
+
+import Data.Aeson
+import GHC.Generics (Generic)
+import Data.Text (Text)
+import Data.Map
+
+import Util (Normalisable(..))
+
+----------------------------------------------------------------------------------------------------
+data BooleanCapability = BooleanCapability
+  { enabled :: Bool
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON BooleanCapability
+
+data ProfileFieldsCapability = ProfileFieldsCapability
+  { enabled :: Bool
+  , allowed :: Maybe [Text]
+  , disallowed :: Maybe [Text]
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON ProfileFieldsCapability
+
+data RoomVersionsCapability = RoomVersionsCapability
+  { default' :: Text
+  , available :: Map Text Text
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON RoomVersionsCapability where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = normaliseVariant }
+
+data CapabilitiesResponse = CapabilitiesResponse
+  { pid_changes :: BooleanCapability
+  , change_password :: BooleanCapability
+  , get_login_token :: BooleanCapability
+  , profile_fields :: ProfileFieldsCapability
+  , room_versions :: RoomVersionsCapability
+  , set_avatar_url :: BooleanCapability
+  , set_display_name :: BooleanCapability
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON CapabilitiesResponse where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = \name ->
+      case name of
+        "pid_changes" -> "m.3pid_changes"
+        "change_password" -> "m.change_password"
+        "get_login_token" -> "m.get_login_token"
+        "profile_fields" -> "m.profile_fields"
+        "room_versions" -> "m.room_versions"
+        "set_avatar_url" -> "m.set_avatar_url"
+        "set_display_name" -> "m.set_displayname"
+        other -> other
+    }