Protecting CapabilitiesEndpoint via Auth

1 files changed, 35 insertions, 0 deletions

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