{-# 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