{-# 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
  (
      -- * Provider helpers
    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 :: 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 (Either ByteString ByteString -> IO ByteString)
-> IO (Either ByteString ByteString) -> IO ByteString
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 <- Text -> ByteString -> IO a
forall a. FromJSON a => Text -> ByteString -> IO a
fromAuthJSON Text
name ByteString
resp
  (a, ByteString) -> IO (a, ByteString)
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) = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs -- nice
fromAuthGet Text
name (Left ByteString
err) =
  YesodOAuth2Exception -> IO ByteString
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (YesodOAuth2Exception -> IO ByteString)
-> YesodOAuth2Exception -> IO ByteString
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 :: Text -> ByteString -> IO a
fromAuthJSON Text
name =
  (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (YesodOAuth2Exception -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (YesodOAuth2Exception -> IO a)
-> (String -> YesodOAuth2Exception) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String -> YesodOAuth2Exception
YesodOAuth2Exception.JSONDecodingError Text
name) a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either String a -> IO a)
-> (ByteString -> Either String a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
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", ) (ByteString -> (ByteString, ByteString))
-> ([Text] -> ByteString) -> [Text] -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
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 (AccessToken -> Text) -> AccessToken -> Text
forall a b. (a -> b) -> a -> b
$ OAuth2Token -> AccessToken
accessToken OAuth2Token
token)
    , (Text
"userResponse", ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
userResponse)
    ]
    [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)]
-> (RefreshToken -> [(Text, Text)])
-> Maybe RefreshToken
-> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text, Text) -> [(Text, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Text) -> [(Text, Text)])
-> (RefreshToken -> (Text, Text)) -> RefreshToken -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"refreshToken", ) (Text -> (Text, Text))
-> (RefreshToken -> Text) -> RefreshToken -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefreshToken -> Text
rtoken) (OAuth2Token -> Maybe RefreshToken
refreshToken OAuth2Token
token)