blob: eea220bc2afb2ba466a83c9ff4144c24cd63ff5b (
plain) (
blame)
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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides authentication utilities for the Jamaa server.
module Auth (authHandler, UserAuth) where
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 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 Model.AuthenticationHolder (AuthenticationHolder (..), server_password)
----------------------------------------------------------------------------------------------------
type UserAuth = AuthProtect "user-auth"
type instance AuthServerData UserAuth = User
authHandler :: AuthHandler Request User
authHandler =
mkAuthHandler $ \req -> case lookup "Authorization" (requestHeaders req) of
Just header ->
case B.stripPrefix "Bearer " header of
Just token -> do
let either_auth_holder = hmacDecode server_password token
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
|