{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.Dispatch
( FetchCreds
, dispatchAuthRequest
)
where
import Control.Exception.Safe
import Control.Monad (unless, (<=<))
import Crypto.Random (getRandomBytes)
import Data.ByteArray.Encoding (Base(Base64), convertToBase)
import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2
import URI.ByteString.Extension
import Yesod.Auth hiding (ServerError)
import Yesod.Auth.OAuth2.ErrorResponse
import Yesod.Auth.OAuth2.Exception
import Yesod.Core hiding (ErrorResponse)
type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)
dispatchAuthRequest
:: Text
-> OAuth2
-> FetchCreds m
-> Text
-> [Text]
-> AuthHandler m TypedContent
dispatchAuthRequest name oauth2 _ "GET" ["forward"] =
dispatchForward name oauth2
dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] =
dispatchCallback name oauth2 getCreds
dispatchAuthRequest _ _ _ _ _ = notFound
dispatchForward :: Text -> OAuth2 -> AuthHandler m TypedContent
dispatchForward name oauth2 = do
csrf <- setSessionCSRF $ tokenSessionKey name
oauth2' <- withCallbackAndState name oauth2 csrf
redirect $ toText $ authorizationUrl oauth2'
dispatchCallback :: Text -> OAuth2 -> FetchCreds m -> AuthHandler m TypedContent
dispatchCallback name oauth2 getCreds = do
csrf <- verifySessionCSRF $ tokenSessionKey name
onErrorResponse $ oauth2HandshakeError name
code <- requireGetParam "code"
manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf
token <- errLeft $ fetchAccessToken2 manager oauth2' $ ExchangeToken code
creds <- errLeft $ tryFetchCreds $ getCreds manager token
setCredsRedirect creds
where
errLeft :: Show e => IO (Either e a) -> AuthHandler m a
errLeft = either (unexpectedError name) pure <=< liftIO
oauth2HandshakeError :: Text -> ErrorResponse -> AuthHandler m a
oauth2HandshakeError name err = do
$(logError) $ "Handshake failure in " <> name <> " plugin: " <> tshow err
redirectMessage $ "OAuth2 handshake failure: " <> erUserMessage err
unexpectedError :: Show e => Text -> e -> AuthHandler m a
unexpectedError name err = do
$(logError) $ "Error in " <> name <> " OAuth2 plugin: " <> tshow err
redirectMessage "Unexpected error logging in with OAuth2"
redirectMessage :: Text -> AuthHandler m a
redirectMessage msg = do
toParent <- getRouteToParent
setMessage $ toHtml msg
redirect $ toParent LoginR
tryFetchCreds :: IO a -> IO (Either SomeException a)
tryFetchCreds f =
(Right <$> f)
`catch` (\(ex :: IOException) -> pure $ Left $ toException ex)
`catch` (\(ex :: YesodOAuth2Exception) -> pure $ Left $ toException ex)
withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2
withCallbackAndState name oauth2 csrf = do
let url = PluginR name ["callback"]
render <- getParentUrlRender
let callbackText = render url
callback <-
maybe
(liftIO
$ throwString
$ "Invalid callback URI: "
<> T.unpack callbackText
<> ". Not using an absolute Approot?"
)
pure
$ fromText callbackText
pure oauth2
{ oauthCallback = Just callback
, oauthOAuthorizeEndpoint =
oauthOAuthorizeEndpoint oauth2
`withQuery` [("state", encodeUtf8 csrf)]
}
getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
setSessionCSRF :: MonadHandler m => Text -> m Text
setSessionCSRF sessionKey = do
csrfToken <- liftIO randomToken
csrfToken <$ setSession sessionKey csrfToken
where
randomToken =
decodeUtf8 . convertToBase @ByteString Base64 <$> getRandomBytes 64
verifySessionCSRF :: MonadHandler m => Text -> m Text
verifySessionCSRF sessionKey = do
token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey
deleteSession sessionKey
unless (sessionToken == Just token)
$ permissionDenied "Invalid OAuth2 state token"
return token
requireGetParam :: MonadHandler m => Text -> m Text
requireGetParam key = do
m <- lookupGetParam key
maybe errInvalidArgs return m
where
errInvalidArgs = invalidArgs ["The '" <> key <> "' parameter is required"]
tokenSessionKey :: Text -> Text
tokenSessionKey name = "_yesod_oauth2_" <> name
tshow :: Show a => a -> Text
tshow = T.pack . show