Protecting CapabilitiesEndpoint via Auth

4 files changed, 49 insertions, 7 deletions

diff --git a/package.yaml b/package.yaml
index 82d8a40..2b15d7c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,6 +23,7 @@ dependencies:
   - base >= 4.7 && < 5
   - aeson
   - servant-server
+  - servant-auth-server
   - wai
   - warp
   - wai-extra
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