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

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

import Server.Core
import Server.Authentication.Utils (getCallbackUri, redirectToCurrentRefererIfAllowed, saveReferer, redirectToSavedRefererIfAllowed)
import GHC.Generics
import Happstack.Server
import Data.Either.Combinators (rightToMaybe)
import Data.Maybe (catMaybes, listToMaybe)
import Control.Monad (msum, mzero, forM_)
import Control.Monad.Extra (liftMaybe)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, except, withExceptT)
import URI.ByteString (URI, parseURI, strictURIParserOptions, serializeURIRef')
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
import qualified Data.ByteString.Lazy.Char8 as BS8
import qualified Jose.Jwt as JWT
import qualified Web.OIDC.Client as OIDC
import qualified Web.OIDC.Client.Settings as OIDCS
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified Network.OAuth.OAuth2 as OA2

-- * Data types

data KnownOpenIdProvider = KnownOpenIdProvider
    { KnownOpenIdProvider -> Text
knownProviderIdentifier :: T.Text
    , KnownOpenIdProvider -> Text
knownProviderDiscoveryUrl :: T.Text
    , KnownOpenIdProvider -> Text
knownProviderClientId :: T.Text
    , KnownOpenIdProvider -> Text
knownProviderClientSecret :: T.Text
    , KnownOpenIdProvider -> [Text]
knownProviderExtraScopes :: [T.Text]
    }

data Claims = Claims
    { Claims -> Text
sub :: T.Text
    } 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 -> String
(Int -> Claims -> ShowS)
-> (Claims -> String) -> ([Claims] -> ShowS) -> Show Claims
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Claims -> ShowS
showsPrec :: Int -> Claims -> ShowS
$cshow :: Claims -> String
show :: Claims -> String
$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
    , UserInfo -> Text
email :: 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 -> String
(Int -> UserInfo -> ShowS)
-> (UserInfo -> String) -> ([UserInfo] -> ShowS) -> Show UserInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserInfo -> ShowS
showsPrec :: Int -> UserInfo -> ShowS
$cshow :: UserInfo -> String
show :: UserInfo -> String
$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

instance A.ToJSON UserInfo where
    toEncoding :: UserInfo -> Encoding
toEncoding = Options -> UserInfo -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
A.genericToEncoding Options
A.defaultOptions

-- * Known providers

knownProviders :: ServerConfiguration -> [KnownOpenIdProvider]
knownProviders :: ServerConfiguration -> [KnownOpenIdProvider]
knownProviders ServerConfiguration
serverConfiguration = [Maybe KnownOpenIdProvider] -> [KnownOpenIdProvider]
forall a. [Maybe a] -> [a]
catMaybes [Maybe KnownOpenIdProvider
maybeMicrosoft] where
    maybeMicrosoft :: Maybe KnownOpenIdProvider
    maybeMicrosoft :: Maybe KnownOpenIdProvider
maybeMicrosoft = (Text -> Text -> Text -> Text -> [Text] -> KnownOpenIdProvider
KnownOpenIdProvider Text
"microsoft" Text
discoveryUrl) (Text -> Text -> [Text] -> KnownOpenIdProvider)
-> Maybe Text -> Maybe (Text -> [Text] -> KnownOpenIdProvider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybeClientId Maybe (Text -> [Text] -> KnownOpenIdProvider)
-> Maybe Text -> Maybe ([Text] -> KnownOpenIdProvider)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
maybeClientSecret Maybe ([Text] -> KnownOpenIdProvider)
-> Maybe [Text] -> Maybe KnownOpenIdProvider
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
extraScopes) where
        discoveryUrl :: Text
discoveryUrl = Text
"https://login.microsoftonline.com/consumers/v2.0"
        maybeClientId :: Maybe T.Text
        maybeClientId :: Maybe Text
maybeClientId = (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerConfiguration -> Maybe String
serverConfigurationOpenIdMicrosoftClientId ServerConfiguration
serverConfiguration)
        maybeClientSecret :: Maybe T.Text
        maybeClientSecret :: Maybe Text
maybeClientSecret = (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerConfiguration -> Maybe String
serverConfigurationOpenIdMicrosoftClientSecret ServerConfiguration
serverConfiguration)
        extraScopes :: [Text]
extraScopes = [Text
"User.Read"]

-- * Handlers

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 ([ServerPart Response] -> ServerPart Response)
-> [ServerPart Response] -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (KnownOpenIdProvider -> ServerPart Response)
-> [KnownOpenIdProvider] -> [ServerPart Response]
forall a b. (a -> b) -> [a] -> [b]
map KnownOpenIdProvider -> ServerPart Response
applyProvider (ServerConfiguration -> [KnownOpenIdProvider]
knownProviders ServerConfiguration
serverConfiguration) where
    applyProvider :: KnownOpenIdProvider -> ServerPart Response
    applyProvider :: KnownOpenIdProvider -> ServerPart Response
applyProvider KnownOpenIdProvider
provider = String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
provider) (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart Response
handleRootForProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
provider

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

handleLogin :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> ServerPart Response
handleLogin :: ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart Response
handleLogin ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider = do
    Text -> ServerPart ()
saveReferer (KnownOpenIdProvider -> Text
providerRefererCookieName KnownOpenIdProvider
knownProvider)
    OIDC
discoveredProvider <- ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart OIDC
discoverProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider
    let scopes :: [Text]
scopes = [Text
OIDC.email, Text
OIDC.profile] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (KnownOpenIdProvider -> [Text]
knownProviderExtraScopes KnownOpenIdProvider
knownProvider)
    URI
authenticationUrl <- IO URI -> ServerPartT IO URI
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO URI -> ServerPartT IO URI) -> IO URI -> ServerPartT IO URI
forall a b. (a -> b) -> a -> b
$ OIDC -> [Text] -> Maybe State -> Parameters -> IO URI
forall (m :: * -> *).
(MonadThrow m, MonadCatch m) =>
OIDC -> [Text] -> Maybe State -> Parameters -> m URI
OIDC.getAuthenticationRequestUrl OIDC
discoveredProvider [Text]
scopes Maybe State
forall a. Maybe a
Nothing []
    URI -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect URI
authenticationUrl (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 = [KnownOpenIdProvider]
-> (KnownOpenIdProvider -> ServerPart ()) -> ServerPart ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ServerConfiguration -> [KnownOpenIdProvider]
knownProviders ServerConfiguration
serverConfiguration) (ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart ()
handleLogoutForProvider ServerConfiguration
serverConfiguration ServerResources
serverResources)

handleLogoutForProvider :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> ServerPart ()
handleLogoutForProvider :: ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart ()
handleLogoutForProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider = do
    String -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerIdentityTokenCookieName KnownOpenIdProvider
knownProvider)
    String -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerUserInfoCookieName KnownOpenIdProvider
knownProvider)
    String -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerRefererCookieName KnownOpenIdProvider
knownProvider)

-- TODO: simplify these pattern matches using ExceptionT
handleCallback :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> ServerPart Response
handleCallback :: ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart Response
handleCallback ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider = do
    -- Retrieve exchange token from querystring
    Text
code <- String -> ServerPartT IO Text
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText' String
"code"
    let exchangeToken :: ExchangeToken
exchangeToken = Text -> ExchangeToken
OA2.ExchangeToken Text
code
    -- Acquire oauth2 token
    OIDC
discoveredProvider <- ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart OIDC
discoverProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider
    Either String OAuth2
oauth2ConfigEither <- ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> OIDC
-> ServerPart (Either String OAuth2)
getProviderOAuth2Config ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider
    case Either String OAuth2
oauth2ConfigEither of
        Left String
_ -> 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 config failed." :: T.Text)
        Right OAuth2
oauth2Config -> do
            let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
            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
-> KnownOpenIdProvider
-> OIDC
-> Text
-> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider 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
                                    Maybe Text
originalUserInfoTextMaybe :: Maybe T.Text <- IO (Maybe Text) -> ServerPartT IO (Maybe Text)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ServerPartT IO (Maybe Text))
-> IO (Maybe Text) -> ServerPartT IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> OIDC
-> AccessToken
-> IO (Maybe Text)
fetchUserInfo ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider AccessToken
accessToken
                                    case Maybe Text
originalUserInfoTextMaybe 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
"Fetching of user info failed." :: T.Text)
                                        Just Text
originalUserInfoText -> do
                                            -- Validate user info
                                            let originalUserInfoMaybe :: Maybe UserInfo
originalUserInfoMaybe = (State -> Maybe UserInfo
forall a. FromJSON a => State -> Maybe a
A.decodeStrict (State -> Maybe UserInfo)
-> (Text -> State) -> Text -> Maybe UserInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> State
TE.encodeUtf8) Text
originalUserInfoText :: Maybe UserInfo
                                            case Maybe UserInfo
originalUserInfoMaybe 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
"Decoding of user info failed." :: T.Text)
                                                Just UserInfo
originalUserInfo -> do
                                                    -- Download profile picture
                                                    Either String Text
profilePictureBase64UrlMaybe <- IO (Either String Text) -> ServerPartT IO (Either String Text)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Text) -> ServerPartT IO (Either String Text))
-> IO (Either String Text) -> ServerPartT IO (Either String Text)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> AccessToken
-> Text
-> IO (Either String Text)
retrieveBase64PictureUrl ServerConfiguration
serverConfiguration ServerResources
serverResources AccessToken
accessToken (UserInfo -> Text
picture UserInfo
originalUserInfo)
                                                    case Either String Text
profilePictureBase64UrlMaybe of
                                                        Left String
msg -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"Unable to fetch profile picture: " Text -> Text -> Text
`T.append` (String -> Text
T.pack String
msg))
                                                        Right Text
profilePictureBase64Url -> do
                                                            let userInfo :: UserInfo
userInfo = UserInfo
originalUserInfo { picture :: Text
picture = Text
profilePictureBase64Url }
                                                            let userInfoText :: Text
userInfoText = State -> Text
TE.decodeUtf8 (State -> Text) -> (UserInfo -> State) -> UserInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> State
BS8.toStrict (ByteString -> State)
-> (UserInfo -> ByteString) -> UserInfo -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserInfo -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (UserInfo -> Text) -> UserInfo -> Text
forall a b. (a -> b) -> a -> b
$ UserInfo
userInfo
                                                            -- 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
<$>
                                                                [ String -> String -> Cookie
mkCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerIdentityTokenCookieName KnownOpenIdProvider
knownProvider) (String -> Cookie) -> String -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
identityTokenText
                                                                , String -> String -> Cookie
mkCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerUserInfoCookieName KnownOpenIdProvider
knownProvider) (String -> Cookie) -> String -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
encodeUserInfoText (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
userInfoText
                                                                ]
                                                            -- Redirect user back to eferer
                                                            Text -> ServerPart Response
redirectToSavedRefererIfAllowed (KnownOpenIdProvider -> Text
providerRefererCookieName KnownOpenIdProvider
knownProvider)

readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies :: ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    [Maybe UserIdentity]
resultsForEachProvider <- (KnownOpenIdProvider -> ServerPart (Maybe UserIdentity))
-> [KnownOpenIdProvider] -> ServerPartT IO [Maybe UserIdentity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookiesForProvider ServerConfiguration
serverConfiguration ServerResources
serverResources) (ServerConfiguration -> [KnownOpenIdProvider]
knownProviders ServerConfiguration
serverConfiguration)
    Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserIdentity -> ServerPart (Maybe UserIdentity))
-> ([Maybe UserIdentity] -> Maybe UserIdentity)
-> [Maybe UserIdentity]
-> ServerPart (Maybe UserIdentity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UserIdentity] -> Maybe UserIdentity
forall a. [a] -> Maybe a
listToMaybe ([UserIdentity] -> Maybe UserIdentity)
-> ([Maybe UserIdentity] -> [UserIdentity])
-> [Maybe UserIdentity]
-> Maybe UserIdentity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe UserIdentity] -> [UserIdentity]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UserIdentity] -> ServerPart (Maybe UserIdentity))
-> [Maybe UserIdentity] -> ServerPart (Maybe UserIdentity)
forall a b. (a -> b) -> a -> b
$ [Maybe UserIdentity]
resultsForEachProvider

readUserIdentityFromCookiesForProvider :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookiesForProvider :: ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookiesForProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider = 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
$ String -> Text
T.pack (String -> Text) -> ServerPartT IO String -> ServerPartT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ServerPartT IO String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerIdentityTokenCookieName KnownOpenIdProvider
knownProvider)
    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) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Maybe Text)
-> ServerPartT IO String -> ServerPartT IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ServerPartT IO String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ KnownOpenIdProvider -> Text
providerUserInfoCookieName KnownOpenIdProvider
knownProvider)
    -- Extract claims
    OIDC
discoveredProvider <- ServerPart OIDC -> MaybeT (ServerPartT IO) OIDC
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPart OIDC -> MaybeT (ServerPartT IO) OIDC)
-> ServerPart OIDC -> MaybeT (ServerPartT IO) OIDC
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart OIDC
discoverProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider
    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
-> KnownOpenIdProvider
-> OIDC
-> Text
-> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider 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
$ State -> Maybe UserInfo
forall a. FromJSON a => State -> Maybe a
A.decodeStrict (Text -> State
TE.encodeUtf8 Text
userInfoText)
    -- Build response
    let userIdentifier :: UserIdentifier
userIdentifier = Text -> Text -> UserIdentifier
UserIdentifier (Text
"openid_" Text -> Text -> Text
`T.append` (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider)) (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

-- * Helper functions
getProviderCallbackUri :: KnownOpenIdProvider -> ServerPart URI
getProviderCallbackUri :: KnownOpenIdProvider -> ServerPart (URIRef Absolute)
getProviderCallbackUri KnownOpenIdProvider
knownProvider = Text -> ServerPart (URIRef Absolute)
getCallbackUri (Text -> ServerPart (URIRef Absolute))
-> Text -> ServerPart (URIRef Absolute)
forall a b. (a -> b) -> a -> b
$ Text
"/authentication/openid/" Text -> Text -> Text
`T.append` (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` Text
"/callback/"

discoverProvider :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> ServerPart OIDC.OIDC
discoverProvider :: ServerConfiguration
-> ServerResources -> KnownOpenIdProvider -> ServerPart OIDC
discoverProvider ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider = do
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    Provider
provider <- IO Provider -> ServerPartT IO Provider
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Provider -> ServerPartT IO Provider)
-> IO Provider -> ServerPartT IO Provider
forall a b. (a -> b) -> a -> b
$ Text -> Manager -> IO Provider
OIDC.discover (KnownOpenIdProvider -> Text
knownProviderDiscoveryUrl KnownOpenIdProvider
knownProvider) Manager
tlsManager
    let clientId :: Text
clientId = KnownOpenIdProvider -> Text
knownProviderClientId KnownOpenIdProvider
knownProvider
    let clientSecret :: Text
clientSecret = KnownOpenIdProvider -> Text
knownProviderClientSecret KnownOpenIdProvider
knownProvider
    URIRef Absolute
callbackUri <- KnownOpenIdProvider -> ServerPart (URIRef Absolute)
getProviderCallbackUri KnownOpenIdProvider
knownProvider
    OIDC -> ServerPart OIDC
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OIDC -> ServerPart OIDC) -> OIDC -> ServerPart OIDC
forall a b. (a -> b) -> a -> b
$ State -> State -> State -> OIDC -> OIDC
OIDC.setCredentials (Text -> State
TE.encodeUtf8 Text
clientId) (Text -> State
TE.encodeUtf8 Text
clientSecret) (URIRef Absolute -> State
forall a. URIRef a -> State
serializeURIRef' URIRef Absolute
callbackUri) (OIDC -> OIDC) -> OIDC -> OIDC
forall a b. (a -> b) -> a -> b
$ Provider -> OIDC
OIDC.newOIDC Provider
provider

getProviderOAuth2Config :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> OIDC.OIDC -> ServerPart (Either String OA2.OAuth2)
getProviderOAuth2Config :: ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> OIDC
-> ServerPart (Either String OAuth2)
getProviderOAuth2Config ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider = do
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    let clientId :: Text
clientId = KnownOpenIdProvider -> Text
knownProviderClientId KnownOpenIdProvider
knownProvider
    let clientSecret :: Text
clientSecret = KnownOpenIdProvider -> Text
knownProviderClientSecret KnownOpenIdProvider
knownProvider
    URIRef Absolute
callbackUri <- KnownOpenIdProvider -> ServerPart (URIRef Absolute)
getProviderCallbackUri KnownOpenIdProvider
knownProvider
    ExceptT String (ServerPartT IO) OAuth2
-> ServerPart (Either String OAuth2)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (ServerPartT IO) OAuth2
 -> ServerPart (Either String OAuth2))
-> ExceptT String (ServerPartT IO) OAuth2
-> ServerPart (Either String OAuth2)
forall a b. (a -> b) -> a -> b
$ do
        URIRef Absolute
authorizeEndpoint <- (URIParseError -> String)
-> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> URIParseError -> String
forall a b. a -> b -> a
const String
"Failed to parse OAuth2 authorization server url.") (ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
 -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> (Either URIParseError (URIRef Absolute)
    -> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute))
-> Either URIParseError (URIRef Absolute)
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either URIParseError (URIRef Absolute)
-> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either URIParseError (URIRef Absolute)
 -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> (Text -> Either URIParseError (URIRef Absolute))
-> Text
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URIParserOptions -> State -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
strictURIParserOptions (State -> Either URIParseError (URIRef Absolute))
-> (Text -> State)
-> Text
-> Either URIParseError (URIRef Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> State
TE.encodeUtf8 (Text -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> Text -> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall a b. (a -> b) -> a -> b
$ OIDC -> Text
OIDCS.oidcAuthorizationServerUrl OIDC
discoveredProvider
        URIRef Absolute
accessTokenEndpoint <- (URIParseError -> String)
-> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> URIParseError -> String
forall a b. a -> b -> a
const String
"Failed to parse OAuth2 access token endpoint.") (ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
 -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> (Either URIParseError (URIRef Absolute)
    -> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute))
-> Either URIParseError (URIRef Absolute)
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either URIParseError (URIRef Absolute)
-> ExceptT URIParseError (ServerPartT IO) (URIRef Absolute)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either URIParseError (URIRef Absolute)
 -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> (Text -> Either URIParseError (URIRef Absolute))
-> Text
-> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URIParserOptions -> State -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
strictURIParserOptions (State -> Either URIParseError (URIRef Absolute))
-> (Text -> State)
-> Text
-> Either URIParseError (URIRef Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> State
TE.encodeUtf8 (Text -> ExceptT String (ServerPartT IO) (URIRef Absolute))
-> Text -> ExceptT String (ServerPartT IO) (URIRef Absolute)
forall a b. (a -> b) -> a -> b
$ OIDC -> Text
OIDCS.oidcTokenEndpoint OIDC
discoveredProvider
        OAuth2 -> ExceptT String (ServerPartT IO) OAuth2
forall a. a -> ExceptT String (ServerPartT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OAuth2 -> ExceptT String (ServerPartT IO) OAuth2)
-> OAuth2 -> ExceptT String (ServerPartT IO) OAuth2
forall a b. (a -> b) -> a -> b
$ OA2.OAuth2
            { oauth2ClientId :: Text
OA2.oauth2ClientId = Text
clientId
            , oauth2ClientSecret :: Text
OA2.oauth2ClientSecret = Text
clientSecret
            , oauth2RedirectUri :: URIRef Absolute
OA2.oauth2RedirectUri = URIRef Absolute
callbackUri
            , oauth2AuthorizeEndpoint :: URIRef Absolute
OA2.oauth2AuthorizeEndpoint = URIRef Absolute
authorizeEndpoint
            , oauth2TokenEndpoint :: URIRef Absolute
OA2.oauth2TokenEndpoint = URIRef Absolute
accessTokenEndpoint
            }

-- TODO: return Either instead of MaybeT
extractClaims :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> OIDC.OIDC -> T.Text -> MaybeT IO Claims
extractClaims :: ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> OIDC
-> Text
-> MaybeT IO Claims
extractClaims ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider Text
identityTokenText = do
    -- Decode jwt token
    let publicKeys :: [Jwk]
publicKeys = Provider -> [Jwk]
OIDC.jwkSet (Provider -> [Jwk]) -> Provider -> [Jwk]
forall a b. (a -> b) -> a -> b
$ OIDC -> Provider
OIDCS.oidcProvider OIDC
discoveredProvider
    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 -> State -> IO (Either JwtError JwtContent)
forall (m :: * -> *).
MonadRandom m =>
[Jwk]
-> Maybe JwtEncoding -> State -> m (Either JwtError JwtContent)
JWT.decode [Jwk]
publicKeys Maybe JwtEncoding
forall a. Maybe a
Nothing (Text -> State
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
    State
jwsPayload <- Maybe State -> MaybeT IO State
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
liftMaybe (Maybe State -> MaybeT IO State) -> Maybe State -> MaybeT IO State
forall a b. (a -> b) -> a -> b
$ do
        case JwtContent
jwtToken of
            JWT.Jws (JwsHeader
jwsHeader, State
jwsPayload) -> State -> Maybe State
forall a. a -> Maybe a
Just State
jwsPayload
            JwtContent
_ -> Maybe State
forall a. Maybe a
Nothing
    -- Return extracted 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
$ State -> Maybe Claims
forall a. FromJSON a => State -> Maybe a
A.decodeStrict State
jwsPayload

-- TODO: return IO (Either String T.Text) instead of IO (Maybe T.Text)
fetchUserInfo :: ServerConfiguration -> ServerResources -> KnownOpenIdProvider -> OIDC.OIDC -> OA2.AccessToken -> IO (Maybe T.Text)
fetchUserInfo :: ServerConfiguration
-> ServerResources
-> KnownOpenIdProvider
-> OIDC
-> AccessToken
-> IO (Maybe Text)
fetchUserInfo ServerConfiguration
serverConfiguration ServerResources
serverResources KnownOpenIdProvider
knownProvider OIDC
discoveredProvider AccessToken
accessToken = do
    let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
    let accessTokenText :: Text
accessTokenText = AccessToken -> Text
OA2.atoken AccessToken
accessToken
    let userInfoEndpointMaybe :: Maybe Text
userInfoEndpointMaybe = (Configuration -> Maybe Text
OIDC.userinfoEndpoint (Configuration -> Maybe Text) -> Configuration -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Configuration
OIDC.configuration (Provider -> Configuration) -> Provider -> Configuration
forall a b. (a -> b) -> a -> b
$ OIDC -> Provider
OIDCS.oidcProvider OIDC
discoveredProvider)
    case Maybe Text
userInfoEndpointMaybe of
        Maybe Text
Nothing -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
        Just Text
userInfoEndpoint -> do
            Request
initialRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HC.parseRequest (Text -> String
T.unpack Text
userInfoEndpoint)
            let request :: Request
request = Request
initialRequest
                    { method :: State
HC.method = State
"POST"
                    , requestHeaders :: RequestHeaders
HC.requestHeaders = [(HeaderName
"Authorization", Text -> State
TE.encodeUtf8 (Text -> State) -> Text -> State
forall a b. (a -> b) -> a -> b
$ Text
"Bearer " Text -> Text -> Text
`T.append` Text
accessTokenText)]
                    }
            Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HC.httpLbs Request
request Manager
tlsManager
            Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ State -> Text
TE.decodeUtf8 (State -> Text) -> (ByteString -> State) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> State
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

retrieveBase64PictureUrl :: ServerConfiguration -> ServerResources -> OA2.AccessToken -> T.Text -> IO (Either String T.Text)
retrieveBase64PictureUrl :: ServerConfiguration
-> ServerResources
-> AccessToken
-> Text
-> IO (Either String Text)
retrieveBase64PictureUrl ServerConfiguration
serverConfiguration ServerResources
serverResources AccessToken
accessToken Text
originalPictureUrl = do
    if Text
originalPictureUrl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"https://graph.microsoft.com/v1.0/me/photo/$value" then
        -- Unfortunately, Microsoft Graph's profile picture API no longer works for consumer accounts.
        -- So there is no point in even calling it. Let's just pretend that the user lacks a profile picture.
        Either String Text -> IO (Either String Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Text -> IO (Either String Text))
-> Either String Text -> IO (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either String Text
forall a b. b -> Either a b
Right Text
T.empty
    else do
        let tlsManager :: Manager
tlsManager = ServerResources -> Manager
serverResourcesTlsManager ServerResources
serverResources
        let accessTokenText :: Text
accessTokenText = AccessToken -> Text
OA2.atoken AccessToken
accessToken
        Request
initialRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HC.parseRequest (Text -> String
T.unpack Text
originalPictureUrl)
        let request :: Request
request = Request
initialRequest
                { method :: State
HC.method = State
"GET"
                , requestHeaders :: RequestHeaders
HC.requestHeaders = [(HeaderName
"Authorization", Text -> State
TE.encodeUtf8 (Text -> State) -> Text -> State
forall a b. (a -> b) -> a -> b
$ Text
"Bearer " Text -> Text -> Text
`T.append` Text
accessTokenText)]
                }
        Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HC.httpLbs Request
request Manager
tlsManager
        case (Status -> Int
HT.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
HC.responseStatus Response ByteString
response) of
            Int
200 -> String -> IO (Either String Text)
forall a. HasCallStack => String -> a
error String
"Not yet implemented!" -- TODO: we should return a base64-encoded image
            Int
404 -> do
                -- If the user lacks a picture, then we just return an empty URL.
                Either String Text -> IO (Either String Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Text -> IO (Either String Text))
-> Either String Text -> IO (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either String Text
forall a b. b -> Either a b
Right Text
T.empty
            Int
_ -> do
                Either String Text -> IO (Either String Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Text -> IO (Either String Text))
-> Either String Text -> IO (Either String Text)
forall a b. (a -> b) -> a -> b
$ String -> Either String Text
forall a b. a -> Either a b
Left String
"Profile picture for user could not be retrieved."

-- * Cookies
providerCookiePrefix :: KnownOpenIdProvider -> T.Text
providerCookiePrefix :: KnownOpenIdProvider -> Text
providerCookiePrefix KnownOpenIdProvider
knownProvider = (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` Text
"_"

providerRefererCookieName :: KnownOpenIdProvider -> T.Text
providerRefererCookieName :: KnownOpenIdProvider -> Text
providerRefererCookieName KnownOpenIdProvider
knownProvider = (KnownOpenIdProvider -> Text
providerCookiePrefix KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` Text
"_referer"

providerIdentityTokenCookieName :: KnownOpenIdProvider -> T.Text
providerIdentityTokenCookieName :: KnownOpenIdProvider -> Text
providerIdentityTokenCookieName KnownOpenIdProvider
knownProvider = (KnownOpenIdProvider -> Text
providerCookiePrefix KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` Text
"_identityToken"

providerUserInfoCookieName :: KnownOpenIdProvider -> T.Text
providerUserInfoCookieName :: KnownOpenIdProvider -> Text
providerUserInfoCookieName KnownOpenIdProvider
knownProvider = (KnownOpenIdProvider -> Text
providerCookiePrefix KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` (KnownOpenIdProvider -> Text
knownProviderIdentifier KnownOpenIdProvider
knownProvider) Text -> Text -> Text
`T.append` Text
"_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 = State -> Text
TE.decodeUtf8 (State -> Text) -> (Text -> State) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
B64.encode (State -> State) -> (Text -> State) -> Text -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> State
TE.encodeUtf8

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