{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}

module Server.Authentication.Google
( handleRoot
, handleLogout
, readUserIdentityFromCookies
) where

import Server.Authentication.Utils (getCallbackUri, redirectToCurrentRefererIfAllowed, saveReferer, redirectToSavedRefererIfAllowed)
import GHC.Generics
import Server.Core
import Happstack.Server
import System.Environment (getEnv)
import Data.Either.Combinators (rightToMaybe)
import Control.Monad (msum)
import Control.Monad.Extra (liftMaybe)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.Except (runExceptT)
import URI.ByteString (URI, parseURI, strictURIParserOptions, serializeURIRef')
import URI.ByteString.QQ (uri)
import qualified Network.HTTP.Client as HC
import qualified Data.ByteString.Lazy.Char8 as BS8
import qualified Data.ByteString.Char8 as BSS8
import qualified Jose.Jwk as JWK
import qualified Jose.Jwt as JWT
import qualified Web.OIDC.Client as OIDC
import qualified Network.OAuth.OAuth2 as OA2
import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Base64 as B64

data Claims = Claims
    { Claims -> Text
email :: T.Text
    , Claims -> Text
sub :: T.Text
    , Claims -> Bool
email_verified :: Bool
    } deriving ((forall x. Claims -> Rep Claims x)
-> (forall x. Rep Claims x -> Claims) -> Generic Claims
forall x. Rep Claims x -> Claims
forall x. Claims -> Rep Claims x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Claims -> Rep Claims x
from :: forall x. Claims -> Rep Claims x
$cto :: forall x. Rep Claims x -> Claims
to :: forall x. Rep Claims x -> Claims
Generic, Int -> Claims -> ShowS
[Claims] -> ShowS
Claims -> [Char]
(Int -> Claims -> ShowS)
-> (Claims -> [Char]) -> ([Claims] -> ShowS) -> Show Claims
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Claims -> ShowS
showsPrec :: Int -> Claims -> ShowS
$cshow :: Claims -> [Char]
show :: Claims -> [Char]
$cshowList :: [Claims] -> ShowS
showList :: [Claims] -> ShowS
Show)

instance A.FromJSON Claims where
    parseJSON :: Value -> Parser Claims
parseJSON = Options -> Value -> Parser Claims
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
A.genericParseJSON Options
A.defaultOptions

data UserInfo = UserInfo
    { UserInfo -> Text
name :: T.Text
    , UserInfo -> Text
picture :: T.Text
    } deriving ((forall x. UserInfo -> Rep UserInfo x)
-> (forall x. Rep UserInfo x -> UserInfo) -> Generic UserInfo
forall x. Rep UserInfo x -> UserInfo
forall x. UserInfo -> Rep UserInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserInfo -> Rep UserInfo x
from :: forall x. UserInfo -> Rep UserInfo x
$cto :: forall x. Rep UserInfo x -> UserInfo
to :: forall x. Rep UserInfo x -> UserInfo
Generic, Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> [Char]
(Int -> UserInfo -> ShowS)
-> (UserInfo -> [Char]) -> ([UserInfo] -> ShowS) -> Show UserInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserInfo -> ShowS
showsPrec :: Int -> UserInfo -> ShowS
$cshow :: UserInfo -> [Char]
show :: UserInfo -> [Char]
$cshowList :: [UserInfo] -> ShowS
showList :: [UserInfo] -> ShowS
Show)

instance A.FromJSON UserInfo where
    parseJSON :: Value -> Parser UserInfo
parseJSON = Options -> Value -> Parser UserInfo
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
A.genericParseJSON Options
A.defaultOptions

refererCookieName :: T.Text
refererCookieName :: Text
refererCookieName = Text
"google_referer"

identityTokenCookieName :: String
identityTokenCookieName :: [Char]
identityTokenCookieName = [Char]
"google_identityToken"

userInfoCookieName :: String
userInfoCookieName :: [Char]
userInfoCookieName = [Char]
"google_userInfo"

-- The cookie for user info needs to be encoded as it contains the character ";", which causes issues in some browsers
encodeUserInfoText :: T.Text -> T.Text
encodeUserInfoText :: Text -> Text
encodeUserInfoText = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8

decodeUserInfoText :: T.Text -> Maybe T.Text
decodeUserInfoText :: Text -> Maybe Text
decodeUserInfoText = Either [Char] Text -> Maybe Text
forall a b. Either a b -> Maybe b
rightToMaybe (Either [Char] Text -> Maybe Text)
-> (Text -> Either [Char] Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text)
-> Either [Char] ByteString -> Either [Char] Text
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 (Either [Char] ByteString -> Either [Char] Text)
-> (Text -> Either [Char] ByteString) -> Text -> Either [Char] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
B64.decode (ByteString -> Either [Char] ByteString)
-> (Text -> ByteString) -> Text -> Either [Char] ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8

readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies :: ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources = MaybeT (ServerPartT IO) UserIdentity
-> ServerPart (Maybe UserIdentity)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ServerPartT IO) UserIdentity
 -> ServerPart (Maybe UserIdentity))
-> MaybeT (ServerPartT IO) UserIdentity
-> ServerPart (Maybe UserIdentity)
forall a b. (a -> b) -> a -> b
$ do
    -- Fetch cookie values
    Text
identityTokenText <- ServerPartT IO Text -> MaybeT (ServerPartT IO) Text
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPartT IO Text -> MaybeT (ServerPartT IO) Text)
-> ServerPartT IO Text -> MaybeT (ServerPartT IO) Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> ServerPartT IO [Char] -> ServerPartT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ServerPartT IO [Char]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
lookCookieValue [Char]
identityTokenCookieName
    Text
userInfoText <- ServerPartT IO (Maybe Text) -> MaybeT (ServerPartT IO) Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ServerPartT IO (Maybe Text) -> MaybeT (ServerPartT IO) Text)
-> ServerPartT IO (Maybe Text) -> MaybeT (ServerPartT IO) Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
decodeUserInfoText (Text -> Maybe Text) -> ([Char] -> Text) -> [Char] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Maybe Text)
-> ServerPartT IO [Char] -> ServerPartT IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ServerPartT IO [Char]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
lookCookieValue [Char]
userInfoCookieName
    -- Extract claims
    Claims
claims <- ServerPartT IO (Maybe Claims) -> MaybeT (ServerPartT IO) Claims
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ServerPartT IO (Maybe Claims) -> MaybeT (ServerPartT IO) Claims)
-> (MaybeT IO Claims -> ServerPartT IO (Maybe Claims))
-> MaybeT IO Claims
-> MaybeT (ServerPartT IO) Claims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe Claims) -> ServerPartT IO (Maybe Claims)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Claims) -> ServerPartT IO (Maybe Claims))
-> (MaybeT IO Claims -> IO (Maybe Claims))
-> MaybeT IO Claims
-> ServerPartT IO (Maybe Claims)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO Claims -> IO (Maybe Claims)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Claims -> MaybeT (ServerPartT IO) Claims)
-> MaybeT IO Claims -> MaybeT (ServerPartT IO) Claims
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> Text -> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources Text
identityTokenText
    -- Decode user info
    UserInfo
userInfo :: UserInfo <- Maybe UserInfo -> MaybeT (ServerPartT IO) UserInfo
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe (Maybe UserInfo -> MaybeT (ServerPartT IO) UserInfo)
-> Maybe UserInfo -> MaybeT (ServerPartT IO) UserInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe UserInfo
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict (Text -> ByteString
TE.encodeUtf8 Text
userInfoText)
    -- Build response
    let userIdentifier :: UserIdentifier
userIdentifier = Text -> Text -> UserIdentifier
UserIdentifier Text
"google" (Claims -> Text
sub Claims
claims)
    let userPictureUrl :: Text
userPictureUrl = UserInfo -> Text
picture UserInfo
userInfo
    let userName :: Text
userName = UserInfo -> Text
name UserInfo
userInfo
    UserIdentity -> MaybeT (ServerPartT IO) UserIdentity
forall a. a -> MaybeT (ServerPartT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UserIdentity -> MaybeT (ServerPartT IO) UserIdentity)
-> UserIdentity -> MaybeT (ServerPartT IO) UserIdentity
forall a b. (a -> b) -> a -> b
$ UserIdentifier -> Text -> Text -> UserIdentity
UserIdentity UserIdentifier
userIdentifier Text
userPictureUrl Text
userName

extractClaims :: ServerConfiguration -> ServerResources -> T.Text -> MaybeT IO Claims
extractClaims :: ServerConfiguration -> ServerResources -> Text -> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources Text
identityTokenText = do
    -- Decode jwt token
    [Jwk]
googlePublicKeys <- IO [Jwk] -> MaybeT IO [Jwk]
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Jwk] -> MaybeT IO [Jwk]) -> IO [Jwk] -> MaybeT IO [Jwk]
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> IO [Jwk]
getGooglePublicKeys ServerConfiguration
serverConfiguration ServerResources
serverResources
    Either JwtError JwtContent
jwtTokenEither <- IO (Either JwtError JwtContent)
-> MaybeT IO (Either JwtError JwtContent)
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either JwtError JwtContent)
 -> MaybeT IO (Either JwtError JwtContent))
-> IO (Either JwtError JwtContent)
-> MaybeT IO (Either JwtError JwtContent)
forall a b. (a -> b) -> a -> b
$ [Jwk]
-> Maybe JwtEncoding
-> ByteString
-> IO (Either JwtError JwtContent)
forall (m :: * -> *).
MonadRandom m =>
[Jwk]
-> Maybe JwtEncoding
-> ByteString
-> m (Either JwtError JwtContent)
JWT.decode [Jwk]
googlePublicKeys Maybe JwtEncoding
forall a. Maybe a
Nothing (Text -> ByteString
TE.encodeUtf8 Text
identityTokenText)
    JwtContent
jwtToken <- Maybe JwtContent -> MaybeT IO JwtContent
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe (Maybe JwtContent -> MaybeT IO JwtContent)
-> Maybe JwtContent -> MaybeT IO JwtContent
forall a b. (a -> b) -> a -> b
$ Either JwtError JwtContent -> Maybe JwtContent
forall a b. Either a b -> Maybe b
rightToMaybe Either JwtError JwtContent
jwtTokenEither
    ByteString
jwsPayload <- Maybe ByteString -> MaybeT IO ByteString
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe (Maybe ByteString -> MaybeT IO ByteString)
-> Maybe ByteString -> MaybeT IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        case JwtContent
jwtToken of
            JWT.Jws (JwsHeader
jwsHeader, ByteString
jwsPayload) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
jwsPayload
            JwtContent
_ -> Maybe ByteString
forall a. Maybe a
Nothing
    -- Extract claims
    Claims
claims <- Maybe Claims -> MaybeT IO Claims
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe (Maybe Claims -> MaybeT IO Claims)
-> Maybe Claims -> MaybeT IO Claims
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Claims
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict ByteString
jwsPayload
    -- Validate claims
    if (Claims -> Bool
email_verified Claims
claims)
        then Claims -> MaybeT IO Claims
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Claims
claims
        else Maybe Claims -> MaybeT IO Claims
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe Maybe Claims
forall a. Maybe a
Nothing

handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ [Char] -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
[Char] -> m a -> m a
dir [Char]
"login" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerPart Response
handleLogin
    , [Char] -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
[Char] -> m a -> m a
dir [Char]
"callback" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPart Response
handleCallback ServerConfiguration
serverConfiguration ServerResources
serverResources
    ]

handleLogin :: ServerPart Response
handleLogin :: ServerPart Response
handleLogin = do
    Text -> ServerPart ()
saveReferer Text
refererCookieName
    Text
authorizationUrl <- ServerPartT IO Text
getAuthorizationUrl
    Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect Text
authorizationUrl (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"" :: T.Text)

handleLogout :: ServerConfiguration -> ServerResources -> ServerPart ()
handleLogout :: ServerConfiguration -> ServerResources -> ServerPart ()
handleLogout ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    [Char] -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[Char] -> m ()
expireCookie [Char]
identityTokenCookieName
    [Char] -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[Char] -> m ()
expireCookie [Char]
userInfoCookieName
    [Char] -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[Char] -> m ()
expireCookie (Text -> [Char]
T.unpack Text
refererCookieName)

handleCallback :: ServerConfiguration -> ServerResources -> ServerPart Response
handleCallback :: ServerConfiguration -> ServerResources -> ServerPart Response
handleCallback ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    -- Retrieve exchange token from querystring
    -- TODO: also handle the 'state' parameter
    Text
code <- [Char] -> ServerPartT IO Text
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m Text
lookText' [Char]
"code"
    let exchangeToken :: ExchangeToken
exchangeToken = Text -> ExchangeToken
OA2.ExchangeToken Text
code
    -- Acquire oauth2 token from Google
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    OAuth2
oauth2Config <- ServerPart OAuth2
getOAuth2Config
    Either TokenRequestError OAuth2Token
oauth2TokenEither <- ExceptT TokenRequestError (ServerPartT IO) OAuth2Token
-> ServerPartT IO (Either TokenRequestError OAuth2Token)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TokenRequestError (ServerPartT IO) OAuth2Token
 -> ServerPartT IO (Either TokenRequestError OAuth2Token))
-> ExceptT TokenRequestError (ServerPartT IO) OAuth2Token
-> ServerPartT IO (Either TokenRequestError OAuth2Token)
forall a b. (a -> b) -> a -> b
$ Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenRequestError (ServerPartT IO) OAuth2Token
forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenRequestError m OAuth2Token
OA2.fetchAccessToken Manager
tlsManager OAuth2
oauth2Config ExchangeToken
exchangeToken
    case Either TokenRequestError OAuth2Token
oauth2TokenEither of
        Left TokenRequestError
_ -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"Acquisition of oauth2 token failed." :: T.Text)
        Right OAuth2Token
oauth2Token -> do
            -- Extract access token
            let accessToken :: AccessToken
accessToken = OAuth2Token -> AccessToken
OA2.accessToken OAuth2Token
oauth2Token
            -- Extract identity token
            case  IdToken -> Text
OA2.idtoken (IdToken -> Text) -> Maybe IdToken -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OAuth2Token -> Maybe IdToken
OA2.idToken OAuth2Token
oauth2Token) of
                Maybe Text
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"Acquisition of identity token failed." :: T.Text)
                Just Text
identityTokenText -> do
                    -- Extract claims
                    Maybe Claims
claimsMaybe <- IO (Maybe Claims) -> ServerPartT IO (Maybe Claims)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Claims) -> ServerPartT IO (Maybe Claims))
-> IO (Maybe Claims) -> ServerPartT IO (Maybe Claims)
forall a b. (a -> b) -> a -> b
$ MaybeT IO Claims -> IO (Maybe Claims)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Claims -> IO (Maybe Claims))
-> MaybeT IO Claims -> IO (Maybe Claims)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> Text -> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources Text
identityTokenText
                    case Maybe Claims
claimsMaybe of
                        Maybe Claims
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"Decoding of identity token failed." :: T.Text)
                        Just Claims
claims -> do
                            -- Fetch user info
                            Text
userInfoText <- IO Text -> ServerPartT IO Text
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ServerPartT IO Text) -> IO Text -> ServerPartT IO Text
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> AccessToken -> IO Text
fetchUserInfo ServerConfiguration
serverConfiguration ServerResources
serverResources AccessToken
accessToken
                            -- Validate user info
                            let userInfoMaybe :: Maybe UserInfo
userInfoMaybe = ByteString -> Maybe UserInfo
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict (Text -> ByteString
TE.encodeUtf8 Text
userInfoText) :: Maybe UserInfo
                            case Maybe UserInfo
userInfoMaybe of
                                Maybe UserInfo
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse ([Text] -> Text
T.concat [(Text
"Decoding of user info failed." :: T.Text), Text
userInfoText])
                                Just UserInfo
userInfo -> do
                                    -- Save identity token and user info to cookies
                                    let cookieDuration :: CookieLife
cookieDuration = (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
86400)
                                    [(CookieLife, Cookie)] -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[(CookieLife, Cookie)] -> m ()
addCookies ([(CookieLife, Cookie)] -> ServerPart ())
-> [(CookieLife, Cookie)] -> ServerPart ()
forall a b. (a -> b) -> a -> b
$ (CookieLife
cookieDuration,) (Cookie -> (CookieLife, Cookie))
-> [Cookie] -> [(CookieLife, Cookie)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                        [ [Char] -> [Char] -> Cookie
mkCookie [Char]
identityTokenCookieName ([Char] -> Cookie) -> [Char] -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
identityTokenText
                                        , [Char] -> [Char] -> Cookie
mkCookie [Char]
userInfoCookieName ([Char] -> Cookie) -> [Char] -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
encodeUserInfoText (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
userInfoText
                                        ]
                                    -- Redirect user back to referer
                                    Text -> ServerPart Response
redirectToSavedRefererIfAllowed Text
refererCookieName

fetchUserInfo :: ServerConfiguration -> ServerResources -> OA2.AccessToken -> IO T.Text
fetchUserInfo :: ServerConfiguration -> ServerResources -> AccessToken -> IO Text
fetchUserInfo ServerConfiguration
serverConfiguration ServerResources
serverResources AccessToken
accessToken = do
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    let accessTokenString :: [Char]
accessTokenString = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ AccessToken -> Text
OA2.atoken AccessToken
accessToken
    Request
request <- [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
HC.parseRequest ([Char] -> IO Request) -> [Char] -> IO Request
forall a b. (a -> b) -> a -> b
$ [Char]
"https://www.googleapis.com/oauth2/v3/userinfo?access_token=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
accessTokenString
    Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HC.httpLbs Request
request Manager
tlsManager
    Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS8.toStrict (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HC.responseBody Response ByteString
response

getGooglePublicKeys :: ServerConfiguration -> ServerResources -> IO [JWK.Jwk]
getGooglePublicKeys :: ServerConfiguration -> ServerResources -> IO [Jwk]
getGooglePublicKeys ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    Provider
provider <- Text -> Manager -> IO Provider
OIDC.discover Text
"https://accounts.google.com" Manager
tlsManager
    [Jwk] -> IO [Jwk]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Jwk] -> IO [Jwk]) -> [Jwk] -> IO [Jwk]
forall a b. (a -> b) -> a -> b
$ Provider -> [Jwk]
OIDC.jwkSet Provider
provider

getOAuth2Config :: ServerPart OA2.OAuth2
getOAuth2Config :: ServerPart OAuth2
getOAuth2Config = do
    [Char]
clientId <- IO [Char] -> ServerPartT IO [Char]
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> ServerPartT IO [Char])
-> IO [Char] -> ServerPartT IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getEnv [Char]
"LOJBANIOS_OAUTH2_GOOGLE_CLIENT_ID"
    [Char]
clientSecret <- IO [Char] -> ServerPartT IO [Char]
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> ServerPartT IO [Char])
-> IO [Char] -> ServerPartT IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getEnv [Char]
"LOJBANIOS_OAUTH2_GOOGLE_CLIENT_SECRET"
    let defaultCallbackUri :: URIRef Absolute
defaultCallbackUri = [uri|https://lojban.io/oauth2/google/callback|]
    URIRef Absolute
callbackUri <- [ServerPartT IO (URIRef Absolute)]
-> ServerPartT IO (URIRef Absolute)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ Text -> ServerPartT IO (URIRef Absolute)
getCallbackUri Text
"/oauth2/google/callback", URIRef Absolute -> ServerPartT IO (URIRef Absolute)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return URIRef Absolute
defaultCallbackUri ]
    OAuth2 -> ServerPart OAuth2
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OAuth2 -> ServerPart OAuth2) -> OAuth2 -> ServerPart OAuth2
forall a b. (a -> b) -> a -> b
$ OA2.OAuth2
        { oauth2ClientId :: Text
OA2.oauth2ClientId = [Char] -> Text
T.pack [Char]
clientId
        , oauth2ClientSecret :: Text
OA2.oauth2ClientSecret = [Char] -> Text
T.pack [Char]
clientSecret
        , oauth2RedirectUri :: URIRef Absolute
OA2.oauth2RedirectUri = URIRef Absolute
callbackUri
        , oauth2AuthorizeEndpoint :: URIRef Absolute
OA2.oauth2AuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]
        , oauth2TokenEndpoint :: URIRef Absolute
OA2.oauth2TokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]
        }

getAuthorizationUrl :: ServerPart T.Text
getAuthorizationUrl :: ServerPartT IO Text
getAuthorizationUrl = do
    OAuth2
oauth2Config <- ServerPart OAuth2
getOAuth2Config
    let params :: [(ByteString, ByteString)]
params = [ (ByteString
"scope", ByteString
"email profile") ]
    let url :: URIRef Absolute
url = [(ByteString, ByteString)] -> URIRef Absolute -> URIRef Absolute
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
OA2.appendQueryParams [(ByteString, ByteString)]
params (URIRef Absolute -> URIRef Absolute)
-> URIRef Absolute -> URIRef Absolute
forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
OA2.authorizationUrl OAuth2
oauth2Config
    Text -> ServerPartT IO Text
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ServerPartT IO Text) -> Text -> ServerPartT IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ URIRef Absolute -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URIRef Absolute
url