1 files changed, 25 insertions, 11 deletions
diff --git a/src/Auth.hs b/src/Auth.hs
index 68d1b6b..eea220b 100644
--- a/src/Auth.hs
+++ b/src/Auth.hs
@@ -4,32 +4,46 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | This module provides authentication utilities for the Jamaa server.
-module Auth (AuthProtect, authHandler) where
+module Auth (authHandler, UserAuth) 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 Jose.Jws (hmacDecode)
+import Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString as B
 
-import Data.User (User(..), Unique(UniqueName))
+import Data.User (User (..), Unique (UniqueName))
+import Model.AuthenticationHolder (AuthenticationHolder (..), server_password)
 
 ----------------------------------------------------------------------------------------------------
-type instance AuthServerData (AuthProtect "user-auth") = User
+type UserAuth = AuthProtect "user-auth"
+type instance AuthServerData UserAuth = 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
+    Just header ->
+      case B.stripPrefix "Bearer " header of
+        Just token -> do
+          let either_auth_holder = hmacDecode server_password token
 
-          case maybe_user of
-            Just (Entity _ db_user) -> return db_user
+          case either_auth_holder of
+            Right (_, auth_holder_body) -> do
+              let maybe_auth_holder = A.decode $ BL.fromStrict $ auth_holder_body :: Maybe AuthenticationHolder
+
+              case maybe_auth_holder of
+                Just auth_holder -> do
+                  maybe_user <- liftIO $ runDb $ getBy $ UniqueName $ username $ auth_holder
+
+                  case maybe_user of
+                    Just (Entity _ db_user) -> return db_user
+                    _ -> throwError err401
+                _ -> throwError err401
             _ -> throwError err401
         _ -> throwError err401
     _ -> throwError err401