blob: 35cbf23efd29deb3ddc691127e81ca58ee0f26ae (
plain)
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
50
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Authentication (User, queryUser, isAuthenticated) where
import Data.Aeson
import Data.Maybe
import Data.Either.Extra
import GHC.Generics
import Network.HTTP.Conduit
import Data.ByteString.Lazy.Char8 (unpack)
import Control.Exception
import Control.Monad.Trans
import Control.Monad.Trans.Either
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Control.Concurrent.MVar
makeUrl = ("https://www.googleapis.com/oauth2/v3/tokeninfo?id_token="++)
type Token = String
data User = User
{ email :: String
, name :: String
, aud :: String
} deriving (Eq, Show, Generic)
instance FromJSON User
queryUser :: Token -> IO (Maybe User)
queryUser token = runEitherT (lift queryUser') >>= \case
Left e -> print (e :: HttpException) >> return Nothing
Right response -> return response
where queryUser' = decode <$> simpleHttp (makeUrl token)
isAuthenticated :: [String] -> [String] -> MVar [Token] -> Token -> IO Bool
isAuthenticated clientIds allowedUsers tokenCache token = do
ts <- readMVar tokenCache
if token `elem` ts
then return True
else isJust <$> isValidUser
where isValidUser = runMaybeT $ do
Just user <- lift $ queryUser token
True <- return $ email user `elem` allowedUsers
True <- return $ aud user `elem` clientIds
tokens <- lift $ takeMVar tokenCache
lift $ putMVar tokenCache (token:tokens)
return ()
|
