{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- |
--
-- Generic OAuth2 plugin for Yesod
--
-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
--
module Yesod.Auth.OAuth2
  ( OAuth2(..)
  , FetchCreds
  , Manager
  , OAuth2Token(..)
  , Creds(..)
  , oauth2Url
  , authOAuth2
  , authOAuth2Widget

    -- * Alternatives that use 'fetchAccessToken2'
  , authOAuth2'
  , authOAuth2Widget'

    -- * Reading our @'credsExtra'@ keys
  , 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"]

-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
--
-- Presents a generic @"Login via #{name}"@ link
--
authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2 :: Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2 Text
name = WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget [whamlet|Login via #{name}|] Text
name

-- | A version of 'authOAuth2' that uses 'fetchAccessToken2'
--
-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
--
authOAuth2' :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2' :: Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2' Text
name = WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
forall m.
YesodAuth m =>
WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget' [whamlet|Login via #{name}|] Text
name

-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
--
-- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
-- example.
--
authOAuth2Widget
  :: YesodAuth m
  => WidgetFor m ()
  -> Text
  -> OAuth2
  -> FetchCreds m
  -> AuthPlugin m
authOAuth2Widget :: WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget = FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
forall m.
YesodAuth m =>
FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
buildPlugin FetchToken
fetchAccessToken

-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2'
--
-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
--
authOAuth2Widget'
  :: YesodAuth m
  => WidgetFor m ()
  -> Text
  -> OAuth2
  -> FetchCreds m
  -> AuthPlugin m
authOAuth2Widget' :: WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
authOAuth2Widget' = FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
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 :: FetchToken
-> WidgetFor m () -> Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
buildPlugin FetchToken
getToken WidgetFor m ()
widget Text
name OAuth2
oauth FetchCreds m
getCreds = Text
-> (Text -> Texts -> AuthHandler m TypedContent)
-> ((AuthRoute -> Route m) -> WidgetFor m ())
-> AuthPlugin m
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin
  Text
name
  (Text
-> OAuth2
-> FetchToken
-> FetchCreds m
-> Text
-> Texts
-> AuthHandler m TypedContent
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}|]

-- | Read the @'AccessToken'@ from the values set via @'setExtra'@
getAccessToken :: Creds m -> Maybe AccessToken
getAccessToken :: Creds m -> Maybe AccessToken
getAccessToken = (Text -> AccessToken
AccessToken (Text -> AccessToken) -> Maybe Text -> Maybe AccessToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Text -> Maybe AccessToken)
-> (Creds m -> Maybe Text) -> Creds m -> Maybe AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"accessToken" ([(Text, Text)] -> Maybe Text)
-> (Creds m -> [(Text, Text)]) -> Creds m -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Creds m -> [(Text, Text)]
forall master. Creds master -> [(Text, Text)]
credsExtra

-- | Read the @'RefreshToken'@ from the values set via @'setExtra'@
--
-- N.B. not all providers supply this value.
--
getRefreshToken :: Creds m -> Maybe RefreshToken
getRefreshToken :: Creds m -> Maybe RefreshToken
getRefreshToken = (Text -> RefreshToken
RefreshToken (Text -> RefreshToken) -> Maybe Text -> Maybe RefreshToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Text -> Maybe RefreshToken)
-> (Creds m -> Maybe Text) -> Creds m -> Maybe RefreshToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"refreshToken" ([(Text, Text)] -> Maybe Text)
-> (Creds m -> [(Text, Text)]) -> Creds m -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Creds m -> [(Text, Text)]
forall master. Creds master -> [(Text, Text)]
credsExtra

-- | Read the original profile response from the values set via @'setExtra'@
getUserResponse :: Creds m -> Maybe ByteString
getUserResponse :: Creds m -> Maybe ByteString
getUserResponse =
  (ByteString -> ByteString
fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Text -> Maybe ByteString)
-> (Creds m -> Maybe Text) -> Creds m -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"userResponse" ([(Text, Text)] -> Maybe Text)
-> (Creds m -> [(Text, Text)]) -> Creds m -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Creds m -> [(Text, Text)]
forall master. Creds master -> [(Text, Text)]
credsExtra

-- | @'getUserResponse'@, and decode as JSON
getUserResponseJSON :: FromJSON a => Creds m -> Either String a
getUserResponseJSON :: Creds m -> Either String a
getUserResponseJSON =
  ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> (Creds m -> Either String ByteString)
-> Creds m
-> Either String a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Maybe ByteString -> Either String ByteString
forall a b. a -> Maybe b -> Either a b
note String
"userResponse key not present" (Maybe ByteString -> Either String ByteString)
-> (Creds m -> Maybe ByteString)
-> Creds m
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Creds m -> Maybe ByteString
forall m. Creds m -> Maybe ByteString
getUserResponse