{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Yesod.Auth.OAuth2
( OAuth2(..)
, FetchCreds
, Manager
, OAuth2Token(..)
, Creds(..)
, oauth2Url
, authOAuth2
, authOAuth2Widget
, authOAuth2'
, authOAuth2Widget'
, getAccessToken
, getRefreshToken
, getUserResponse
, getUserResponseJSON
) where
import Control.Error.Util (note)
import Control.Monad ((<=<))
import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Lazy (ByteString, fromStrict)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2.Compat
import Yesod.Auth
import Yesod.Auth.OAuth2.Dispatch
import Yesod.Core.Widget
oauth2Url :: Text -> AuthRoute
oauth2Url :: Text -> AuthRoute
oauth2Url Text
name = Text -> Texts -> AuthRoute
PluginR Text
name [Text
"forward"]
authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2 :: forall m.
YesodAuth m =>
Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2 Text
name = forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget [whamlet|Login via #{name}|] Text
name
authOAuth2' :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2' :: forall m.
YesodAuth m =>
Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2' Text
name = forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget' [whamlet|Login via #{name}|] Text
name
authOAuth2Widget
:: YesodAuth m
=> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
authOAuth2Widget :: forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget = forall m.
YesodAuth m =>
FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
buildPlugin FetchToken
fetchAccessToken
authOAuth2Widget'
:: YesodAuth m
=> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
authOAuth2Widget' :: forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget' = forall m.
YesodAuth m =>
FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
buildPlugin FetchToken
fetchAccessToken2
buildPlugin
:: YesodAuth m
=> FetchToken
-> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
buildPlugin :: forall m.
YesodAuth m =>
FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
buildPlugin FetchToken
getToken WidgetFor m ()
widget Text
name OAuth2
oauth FetchCreds m
getCreds = forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin
Text
name
(forall m.
Text
-> OAuth2
-> FetchToken
-> FetchCreds m
-> Text
-> Texts
-> AuthHandler m TypedContent
dispatchAuthRequest Text
name OAuth2
oauth FetchToken
getToken FetchCreds m
getCreds)
(AuthRoute -> Route m) -> WidgetFor m ()
login
where login :: (AuthRoute -> Route m) -> WidgetFor m ()
login AuthRoute -> Route m
tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
getAccessToken :: Creds m -> Maybe AccessToken
getAccessToken :: forall m. Creds m -> Maybe AccessToken
getAccessToken = (Text -> AccessToken
AccessToken forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"accessToken" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall master. Creds master -> [(Text, Text)]
credsExtra
getRefreshToken :: Creds m -> Maybe RefreshToken
getRefreshToken :: forall m. Creds m -> Maybe RefreshToken
getRefreshToken = (Text -> RefreshToken
RefreshToken forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"refreshToken" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall master. Creds master -> [(Text, Text)]
credsExtra
getUserResponse :: Creds m -> Maybe ByteString
getUserResponse :: forall m. Creds m -> Maybe ByteString
getUserResponse =
(ByteString -> ByteString
fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"userResponse" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall master. Creds master -> [(Text, Text)]
credsExtra
getUserResponseJSON :: FromJSON a => Creds m -> Either String a
getUserResponseJSON :: forall a m. FromJSON a => Creds m -> Either String a
getUserResponseJSON =
forall a. FromJSON a => ByteString -> Either String a
eitherDecode forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b. a -> Maybe b -> Either a b
note String
"userResponse key not present" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Creds m -> Maybe ByteString
getUserResponse