module Yesod.Auth.OAuth2
( authOAuth2
, authOAuth2Widget
, oauth2Url
, fromProfileURL
, YesodOAuth2Exception(..)
, maybeExtra
, module Network.OAuth.OAuth2
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Exception.Lifted
import Control.Monad.IO.Class
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2
import System.Random
import Yesod.Auth
import Yesod.Core
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as C8
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
deriving (Show, Typeable)
instance Exception YesodOAuth2Exception
oauth2Url :: Text -> AuthRoute
oauth2Url name = PluginR name ["forward"]
authOAuth2 :: YesodAuth m
=> Text
-> OAuth2
-> (Manager -> AccessToken -> IO (Creds m))
-> AuthPlugin m
authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
authOAuth2Widget :: YesodAuth m
=> WidgetT m IO ()
-> Text
-> OAuth2
-> (Manager -> AccessToken -> IO (Creds m))
-> AuthPlugin m
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
where
url = PluginR name ["callback"]
withCallback csrfToken = do
tm <- getRouteToParent
render <- lift getUrlRender
return oauth
{ oauthCallback = Just $ encodeUtf8 $ render $ tm url
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
`appendQuery` "state=" <> encodeUtf8 csrfToken
}
dispatch "GET" ["forward"] = do
csrfToken <- liftIO generateToken
setSession tokenSessionKey csrfToken
authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken
lift $ redirect authUrl
dispatch "GET" ["callback"] = do
csrfToken <- requireGetParam "state"
oldToken <- lookupSession tokenSessionKey
deleteSession tokenSessionKey
unless (oldToken == Just csrfToken) $ permissionDenied "Invalid OAuth2 state token"
code <- requireGetParam "code"
oauth' <- withCallback csrfToken
master <- lift getYesod
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
case result of
Left _ -> permissionDenied "Unable to retreive OAuth2 token"
Right token -> do
creds <- liftIO $ getCreds (authHttpManager master) token
lift $ setCredsRedirect creds
where
requireGetParam key = do
m <- lookupGetParam key
maybe (permissionDenied $ "'" <> key <> "' parameter not provided") return m
dispatch _ _ = notFound
generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen
tokenSessionKey :: Text
tokenSessionKey = "_yesod_oauth2_" <> name
login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
fromProfileURL :: FromJSON a
=> Text
-> URI
-> (a -> Creds m)
-> Manager -> AccessToken -> IO (Creds m)
fromProfileURL name url toCreds manager token = do
result <- authGetJSON manager token url
case result of
Right profile -> return $ toCreds profile
Left err -> throwIO $ InvalidProfileResponse name err
bsToText :: ByteString -> Text
bsToText = decodeUtf8With lenientDecode
appendQuery :: ByteString -> ByteString -> ByteString
appendQuery url query =
if '?' `C8.elem` url
then url <> "&" <> query
else url <> "?" <> query
maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
maybeExtra k (Just v) = [(k, v)]
maybeExtra _ Nothing = []