{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- |
--
-- Modules and support functions required by most or all provider
-- implementations. May also be useful for writing local providers.
--
module Yesod.Auth.OAuth2.Prelude
  ( authGetProfile
  , scopeParam
  , setExtra

    -- * Text
  , Text
  , decodeUtf8
  , encodeUtf8

    -- * JSON
  , (.:)
  , (.:?)
  , (.=)
  , (<>)
  , FromJSON(..)
  , ToJSON(..)
  , eitherDecode
  , withObject

    -- * Exceptions
  , throwIO

    -- * OAuth2
  , OAuth2(..)
  , OAuth2Token(..)
  , AccessToken(..)
  , RefreshToken(..)

    -- * HTTP
  , Manager

    -- * Yesod
  , YesodAuth(..)
  , AuthPlugin(..)
  , Creds(..)

    -- * Bytestring URI types
  , URI
  , Host(..)

    -- * Bytestring URI extensions
  , module URI.ByteString.Extension

    -- * Temporary, until I finish re-structuring modules
  , authOAuth2
  , authOAuth2Widget
  ) where

import Control.Exception.Safe
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Network.HTTP.Conduit
import Network.OAuth.OAuth2.Compat
import URI.ByteString
import URI.ByteString.Extension
import Yesod.Auth
import Yesod.Auth.OAuth2
import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception

-- | Retrieve a user's profile as JSON
--
-- The response should be parsed only far enough to read the required
-- @'credsIdent'@. Additional information should either be re-parsed by or
-- fetched via additional requests by consumers.
--
authGetProfile
  :: FromJSON a
  => Text
  -> Manager
  -> OAuth2Token
  -> URI
  -> IO (a, BL.ByteString)
authGetProfile :: forall a.
FromJSON a =>
Text -> Manager -> OAuth2Token -> URI -> IO (a, ByteString)
authGetProfile Text
name Manager
manager OAuth2Token
token URI
url = do
  ByteString
resp <- Text -> Either ByteString ByteString -> IO ByteString
fromAuthGet Text
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
authGetBS Manager
manager (OAuth2Token -> AccessToken
accessToken OAuth2Token
token) URI
url
  a
decoded <- forall a. FromJSON a => Text -> ByteString -> IO a
fromAuthJSON Text
name ByteString
resp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
decoded, ByteString
resp)

-- | Throws a @Left@ result as an @'YesodOAuth2Exception'@
fromAuthGet :: Text -> Either BL.ByteString BL.ByteString -> IO BL.ByteString
fromAuthGet :: Text -> Either ByteString ByteString -> IO ByteString
fromAuthGet Text
_ (Right ByteString
bs) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs -- nice
fromAuthGet Text
name (Left ByteString
err) =
  forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> YesodOAuth2Exception
YesodOAuth2Exception.OAuth2Error Text
name ByteString
err

-- | Throws a decoding error as an @'YesodOAuth2Exception'@
fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a
fromAuthJSON :: forall a. FromJSON a => Text -> ByteString -> IO a
fromAuthJSON Text
name =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String -> YesodOAuth2Exception
YesodOAuth2Exception.JSONDecodingError Text
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
eitherDecode

-- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter
scopeParam :: Text -> [Text] -> (ByteString, ByteString)
scopeParam :: Text -> [Text] -> (ByteString, ByteString)
scopeParam Text
d = (ByteString
"scope", ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
d

-- brittany-disable-next-binding

-- | Construct part of @'credsExtra'@
--
-- Always the following keys:
--
-- - @accessToken@: to support follow-up requests
-- - @userResponse@: to support getting additional information
--
-- May set the following keys:
--
-- - @refreshToken@: if the provider supports refreshing the @accessToken@
--
setExtra :: OAuth2Token -> BL.ByteString -> [(Text, Text)]
setExtra :: OAuth2Token -> ByteString -> [(Text, Text)]
setExtra OAuth2Token
token ByteString
userResponse =
    [ (Text
"accessToken", AccessToken -> Text
atoken forall a b. (a -> b) -> a -> b
$ OAuth2Token -> AccessToken
accessToken OAuth2Token
token)
    , (Text
"userResponse", ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
userResponse)
    ]
    forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"refreshToken", ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefreshToken -> Text
rtoken) (OAuth2Token -> Maybe RefreshToken
refreshToken OAuth2Token
token)