From 4da55d6434f6077f35466c9c0dfe3c29ee33f984 Mon Sep 17 00:00:00 2001
From: adambrangenberg <adabran06@gmail.com>
Date: Wed, 24 Dec 2025 07:18:04 +0100
Subject: Protecting CapabilitiesEndpoint via Auth

---
 src/Auth.hs                           | 35 +++++++++++++++++++++++++++++++++++
 src/Endpoints/CapabilitiesEndpoint.hs |  7 +++++--
 src/Lib.hs                            | 13 ++++++++-----
 3 files changed, 48 insertions(+), 7 deletions(-)
 create mode 100644 src/Auth.hs

(limited to 'src')

diff --git a/src/Auth.hs b/src/Auth.hs
new file mode 100644
index 0000000..68d1b6b
--- /dev/null
+++ b/src/Auth.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module provides authentication utilities for the Jamaa server.
+module Auth (AuthProtect, authHandler) where
+
+import Data.Text (Text, isPrefixOf, stripPrefix, pack)
+import Servant
+import Servant.Server.Experimental.Auth (AuthServerData, AuthHandler, mkAuthHandler)
+import Network.Wai (Request, requestHeaders)
+import Database.Persist
+import Database (runDb)
+import Control.Monad.IO.Class (liftIO)
+import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
+
+import Data.User (User(..), Unique(UniqueName))
+
+----------------------------------------------------------------------------------------------------
+type instance AuthServerData (AuthProtect "user-auth") = User
+
+authHandler :: AuthHandler Request User
+authHandler =
+  mkAuthHandler $ \req -> case lookup "Authorization" (requestHeaders req) of
+    Just token ->
+      case stripPrefix "Bearer dummy" (decodeUtf8 token) of
+        Just username -> do
+          maybe_user <- liftIO $ runDb $ getBy $ UniqueName username
+
+          case maybe_user of
+            Just (Entity _ db_user) -> return db_user
+            _ -> throwError err401
+        _ -> throwError err401
+    _ -> throwError err401
diff --git a/src/Endpoints/CapabilitiesEndpoint.hs b/src/Endpoints/CapabilitiesEndpoint.hs
index 92fefba..5c1ffde 100644
--- a/src/Endpoints/CapabilitiesEndpoint.hs
+++ b/src/Endpoints/CapabilitiesEndpoint.hs
@@ -8,6 +8,8 @@ import Servant
 import qualified Data.Map as Map
 
 import Model.Capabilities
+import Auth (AuthProtect)
+import Data.User (User (..))
 
 ----------------------------------------------------------------------------------------------------
 type CapabilitiesAPI = GetCapabilities
@@ -17,10 +19,11 @@ capabilitiesServer = handleCapabilitiesGet
 
 --- GET /_matrix/client/v3/capabilities ------------------------------------------------------------
 type GetCapabilities = "_matrix" :> "client" :> "v3" :> "capabilities"
+                 :> AuthProtect "user-auth"
                  :> Get '[JSON] CapabilitiesResponse
 
-handleCapabilitiesGet :: Handler CapabilitiesResponse
-handleCapabilitiesGet = return $ CapabilitiesResponse
+handleCapabilitiesGet :: User -> Handler CapabilitiesResponse
+handleCapabilitiesGet _ = return $ CapabilitiesResponse
   { pid_changes = BooleanCapability False
   , change_password = BooleanCapability False
   , get_login_token = BooleanCapability False
diff --git a/src/Lib.hs b/src/Lib.hs
index d430d9c..a0900ad 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeOperators   #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Lib
     ( startApp
@@ -11,24 +12,26 @@ module Lib
     , type (:<|>)
     ) where
 
--- Servant
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
 import Servant
+import Servant.Server.Experimental.Auth (AuthHandler)
 
--- Utils
+import Auth (authHandler)
 import Cors
-
--- Endpoints
 import Endpoints.APILib
 import Endpoints.ServerLib
+import Data.User (User (..))
 
 startApp :: IO ()
 startApp = run 8080 (logStdoutDev app)
 
 app :: Application
-app = corsMiddleware $ serve api server
+app = corsMiddleware $ serveWithContext api authContext server
+
+authContext :: Context '[AuthHandler Request User]
+authContext = authHandler :. EmptyContext
 
 api :: Proxy API
 api = Proxy
-- 
cgit v1.2.3