src/Auth.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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