{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Effect.OAuth2
  ( OAuth2 (..)
  , authUrl
  , validateCode
  , exchangeAuth
  , exchangeRefresh
  , runOAuth2
  , getConfigEnv
  , Scopes (..)
  , AuthFlow (..)
  , Config (..)
  , TokenType (..)
  , Authenticated (..)
  , Token (..)
  , ClientId
  , ClientSecret
  , Code
  , Access
  , Refresh
  , State
  , Auth
  , OAuth2Error (..)
  ) where

import Control.Monad (unless, when)
import Data.Aeson (FromJSON (..), Options (..), ToJSON (..), Value (..), defaultOptions, eitherDecode, genericParseJSON, genericToJSON)
import Data.ByteString.Lazy qualified as BL
import Data.Default
import Data.Maybe (isJust)
import Data.String (IsString (..))
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Environment
import Effectful.Exception
import GHC.Generics (Generic)
import Network.HTTP.Client (HttpException, Request (..), RequestBody (..))
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types (hAccept, hContentType)
import Network.URI (parseURI)
import Text.Casing (quietSnake)
import Web.Hyperbole.Data.Encoded
import Web.Hyperbole.Data.Param
import Web.Hyperbole.Data.URI
import Web.Hyperbole.Effect.GenRandom
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Query
import Web.Hyperbole.Effect.Response (respondError)
import Web.Hyperbole.Effect.Session (Session (..), deleteSession, saveSession, session)
import Web.Hyperbole.Types.Response


-- TODO: could all hyperbole applications have an oauth2 redirect endpoint?
-- TVar (Map State (Eff es _))
-- then you could execute it afterwards!

-- High level effect interface

authUrl :: (OAuth2 :> es) => URI -> Scopes -> Eff es URI
authUrl :: forall (es :: [Effect]).
(OAuth2 :> es) =>
URI -> Scopes -> Eff es URI
authUrl URI
redirectUrl Scopes
scopes = OAuth2 (Eff es) URI -> Eff es URI
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (OAuth2 (Eff es) URI -> Eff es URI)
-> OAuth2 (Eff es) URI -> Eff es URI
forall a b. (a -> b) -> a -> b
$ URI -> Scopes -> OAuth2 (Eff es) URI
forall (m :: * -> *). URI -> Scopes -> OAuth2 m URI
AuthUrl URI
redirectUrl Scopes
scopes


validateCode :: (OAuth2 :> es) => Eff es (Token Code)
validateCode :: forall (es :: [Effect]). (OAuth2 :> es) => Eff es (Token Code)
validateCode = OAuth2 (Eff es) (Token Code) -> Eff es (Token Code)
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send OAuth2 (Eff es) (Token Code)
forall (m :: * -> *). OAuth2 m (Token Code)
ValidateCode


exchangeAuth :: (OAuth2 :> es) => Token Code -> Eff es Authenticated
exchangeAuth :: forall (es :: [Effect]).
(OAuth2 :> es) =>
Token Code -> Eff es Authenticated
exchangeAuth Token Code
authCode = OAuth2 (Eff es) Authenticated -> Eff es Authenticated
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (OAuth2 (Eff es) Authenticated -> Eff es Authenticated)
-> OAuth2 (Eff es) Authenticated -> Eff es Authenticated
forall a b. (a -> b) -> a -> b
$ Token Code -> OAuth2 (Eff es) Authenticated
forall (m :: * -> *). Token Code -> OAuth2 m Authenticated
ExchangeAuth Token Code
authCode


exchangeRefresh :: (OAuth2 :> es) => Token Refresh -> Eff es Authenticated
exchangeRefresh :: forall (es :: [Effect]).
(OAuth2 :> es) =>
Token Refresh -> Eff es Authenticated
exchangeRefresh Token Refresh
refToken = OAuth2 (Eff es) Authenticated -> Eff es Authenticated
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (OAuth2 (Eff es) Authenticated -> Eff es Authenticated)
-> OAuth2 (Eff es) Authenticated -> Eff es Authenticated
forall a b. (a -> b) -> a -> b
$ Token Refresh -> OAuth2 (Eff es) Authenticated
forall (m :: * -> *). Token Refresh -> OAuth2 m Authenticated
ExchangeRefresh Token Refresh
refToken


data OAuth2 :: Effect where
  AuthUrl :: URI -> Scopes -> OAuth2 m URI
  ValidateCode :: OAuth2 m (Token Code)
  ExchangeAuth :: Token Code -> OAuth2 m Authenticated
  ExchangeRefresh :: Token Refresh -> OAuth2 m Authenticated


type instance DispatchOf OAuth2 = 'Dynamic


runOAuth2
  :: (GenRandom :> es, IOE :> es, Hyperbole :> es)
  => Config
  -> HTTP.Manager
  -> Eff (OAuth2 : es) a
  -> Eff es a
runOAuth2 :: forall (es :: [Effect]) a.
(GenRandom :> es, IOE :> es, Hyperbole :> es) =>
Config -> Manager -> Eff (OAuth2 : es) a -> Eff es a
runOAuth2 Config
cfg Manager
mgr = EffectHandler OAuth2 es -> Eff (OAuth2 : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret (EffectHandler OAuth2 es -> Eff (OAuth2 : es) a -> Eff es a)
-> EffectHandler OAuth2 es -> Eff (OAuth2 : es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs es
_ -> \case
  AuthUrl URI
red Scopes
scopes -> do
    Token State
state <- Int -> Eff es (Token State)
forall {k} (es :: [Effect]) (a :: k).
(GenRandom :> es) =>
Int -> Eff es (Token a)
genRandomToken Int
6
    let url :: URI
url = Endpoint Auth
-> Token ClientId -> URI -> Scopes -> Token State -> URI
authorizationUrl Config
cfg.authorize Config
cfg.clientId URI
red Scopes
scopes Token State
state
    AuthFlow -> Eff es ()
forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
a -> Eff es ()
saveSession (AuthFlow -> Eff es ()) -> AuthFlow -> Eff es ()
forall a b. (a -> b) -> a -> b
$ URI -> Token State -> AuthFlow
AuthFlow URI
red Token State
state
    a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
URI
url
  OAuth2 (Eff localEs) a
ValidateCode -> do
    AuthFlow
flow <- forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
Eff es a
session @AuthFlow
    AuthFlow -> Eff es (Token Code)
forall (es :: [Effect]).
(Hyperbole :> es) =>
AuthFlow -> Eff es (Token Code)
validateRedirectParams AuthFlow
flow
  ExchangeAuth Token Code
authCode -> do
    AuthFlow
flow <- forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
Eff es a
session @AuthFlow
    let params :: Query
params = Token ClientId -> Token ClientSecret -> URI -> Token Code -> Query
tokenParams Config
cfg.clientId Config
cfg.clientSecret AuthFlow
flow.redirect Token Code
authCode
    Authenticated
auth <- Config -> Manager -> Query -> Eff es Authenticated
forall (es :: [Effect]).
(IOE :> es) =>
Config -> Manager -> Query -> Eff es Authenticated
sendTokenRequest Config
cfg Manager
mgr Query
params
    forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Eff es ()
deleteSession @AuthFlow
    a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Authenticated
auth
  ExchangeRefresh Token Refresh
refToken -> do
    let params :: Query
params = Token ClientId -> Token ClientSecret -> Token Refresh -> Query
refreshParams Config
cfg.clientId Config
cfg.clientSecret Token Refresh
refToken
    Config -> Manager -> Query -> Eff es Authenticated
forall (es :: [Effect]).
(IOE :> es) =>
Config -> Manager -> Query -> Eff es Authenticated
sendTokenRequest Config
cfg Manager
mgr Query
params


{- | read oauth config from env. This is not required, you can obtain these secrets another way
and configure the app however you please. Just pass the results into runOAuth2 in your app
-}
getConfigEnv :: (Environment :> es) => Eff es Config
getConfigEnv :: forall (es :: [Effect]). (Environment :> es) => Eff es Config
getConfigEnv = do
  Token ClientId
clientId <- Text -> Token ClientId
forall {k} (a :: k). Text -> Token a
Token (Text -> Token ClientId)
-> (String -> Text) -> String -> Token ClientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Token ClientId)
-> Eff es String -> Eff es (Token ClientId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Eff es String
forall (es :: [Effect]).
(Environment :> es) =>
String -> Eff es String
getEnv String
"OAUTH2_CLIENT_ID"
  Token ClientSecret
clientSecret <- Text -> Token ClientSecret
forall {k} (a :: k). Text -> Token a
Token (Text -> Token ClientSecret)
-> (String -> Text) -> String -> Token ClientSecret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Token ClientSecret)
-> Eff es String -> Eff es (Token ClientSecret)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Eff es String
forall (es :: [Effect]).
(Environment :> es) =>
String -> Eff es String
getEnv String
"OAUTH2_CLIENT_SECRET"
  Endpoint Auth
authorize <- URI -> Endpoint Auth
forall {k} (a :: k). URI -> Endpoint a
Endpoint (URI -> Endpoint Auth) -> Eff es URI -> Eff es (Endpoint Auth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Eff es URI
forall {es :: [Effect]}.
(Environment :> es) =>
String -> Eff es URI
getEnvURI String
"OAUTH2_AUTHORIZE_ENDPOINT"
  Endpoint (Token ())
token <- URI -> Endpoint (Token ())
forall {k} (a :: k). URI -> Endpoint a
Endpoint (URI -> Endpoint (Token ()))
-> Eff es URI -> Eff es (Endpoint (Token ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Eff es URI
forall {es :: [Effect]}.
(Environment :> es) =>
String -> Eff es URI
getEnvURI String
"OAUTH2_TOKEN_ENDPOINT"
  Config -> Eff es Config
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> Eff es Config) -> Config -> Eff es Config
forall a b. (a -> b) -> a -> b
$ Config{Token ClientId
clientId :: Token ClientId
$sel:clientId:Config :: Token ClientId
clientId, Token ClientSecret
clientSecret :: Token ClientSecret
$sel:clientSecret:Config :: Token ClientSecret
clientSecret, Endpoint Auth
authorize :: Endpoint Auth
$sel:authorize:Config :: Endpoint Auth
authorize, Endpoint (Token ())
token :: Endpoint (Token ())
$sel:token:Config :: Endpoint (Token ())
token}
 where
  getEnvURI :: String -> Eff es URI
getEnvURI String
n = do
    String
str <- String -> Eff es String
forall (es :: [Effect]).
(Environment :> es) =>
String -> Eff es String
getEnv String
n
    case String -> Maybe URI
parseURI String
str of
      Maybe URI
Nothing -> OAuth2Error -> Eff es URI
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (OAuth2Error -> Eff es URI) -> OAuth2Error -> Eff es URI
forall a b. (a -> b) -> a -> b
$ String -> String -> OAuth2Error
OAuth2BadEnv String
n String
str
      Just URI
u -> URI -> Eff es URI
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
u


-- Types -------------------------------------------------

newtype Scopes = Scopes [Text]
  deriving (Int -> Scopes -> ShowS
[Scopes] -> ShowS
Scopes -> String
(Int -> Scopes -> ShowS)
-> (Scopes -> String) -> ([Scopes] -> ShowS) -> Show Scopes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scopes -> ShowS
showsPrec :: Int -> Scopes -> ShowS
$cshow :: Scopes -> String
show :: Scopes -> String
$cshowList :: [Scopes] -> ShowS
showList :: [Scopes] -> ShowS
Show, (forall x. Scopes -> Rep Scopes x)
-> (forall x. Rep Scopes x -> Scopes) -> Generic Scopes
forall x. Rep Scopes x -> Scopes
forall x. Scopes -> Rep Scopes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Scopes -> Rep Scopes x
from :: forall x. Scopes -> Rep Scopes x
$cto :: forall x. Rep Scopes x -> Scopes
to :: forall x. Rep Scopes x -> Scopes
Generic)
  deriving anyclass (Maybe Text -> Either String Scopes
ParamValue -> Either String Scopes
(ParamValue -> Either String Scopes)
-> (Maybe Text -> Either String Scopes) -> FromParam Scopes
forall a.
(ParamValue -> Either String a)
-> (Maybe Text -> Either String a) -> FromParam a
$cparseParam :: ParamValue -> Either String Scopes
parseParam :: ParamValue -> Either String Scopes
$cdecodeFormValue :: Maybe Text -> Either String Scopes
decodeFormValue :: Maybe Text -> Either String Scopes
FromParam, Scopes -> ParamValue
(Scopes -> ParamValue) -> ToParam Scopes
forall a. (a -> ParamValue) -> ToParam a
$ctoParam :: Scopes -> ParamValue
toParam :: Scopes -> ParamValue
ToParam)
instance ToJSON Scopes where
  toJSON :: Scopes -> Value
toJSON (Scopes [Text]
ss) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text]
ss
instance FromJSON Scopes where
  parseJSON :: Value -> Parser Scopes
parseJSON Value
v = do
    String
t <- forall a. FromJSON a => Value -> Parser a
parseJSON @String Value
v
    Scopes -> Parser Scopes
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scopes -> Parser Scopes) -> Scopes -> Parser Scopes
forall a b. (a -> b) -> a -> b
$ String -> Scopes
forall a. IsString a => String -> a
fromString String
t
instance IsString Scopes where
  fromString :: String -> Scopes
fromString String
s = [Text] -> Scopes
Scopes ([Text] -> Scopes) -> [Text] -> Scopes
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
s


data ClientId
data ClientSecret
data Code
data Refresh
data Access
data State
data Auth

#if (!MIN_VERSION_aeson(2,2,0))
instance FromJSON URI
instance ToJSON URI
instance FromJSON URIAuth
instance ToJSON URIAuth
#endif


data AuthFlow = AuthFlow
  { AuthFlow -> URI
redirect :: URI
  , AuthFlow -> Token State
state :: Token State
  }
  deriving ((forall x. AuthFlow -> Rep AuthFlow x)
-> (forall x. Rep AuthFlow x -> AuthFlow) -> Generic AuthFlow
forall x. Rep AuthFlow x -> AuthFlow
forall x. AuthFlow -> Rep AuthFlow x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AuthFlow -> Rep AuthFlow x
from :: forall x. AuthFlow -> Rep AuthFlow x
$cto :: forall x. Rep AuthFlow x -> AuthFlow
to :: forall x. Rep AuthFlow x -> AuthFlow
Generic, Encoded -> Either String AuthFlow
(Encoded -> Either String AuthFlow) -> FromEncoded AuthFlow
forall a. (Encoded -> Either String a) -> FromEncoded a
$cparseEncoded :: Encoded -> Either String AuthFlow
parseEncoded :: Encoded -> Either String AuthFlow
FromEncoded, AuthFlow -> Encoded
(AuthFlow -> Encoded) -> ToEncoded AuthFlow
forall a. (a -> Encoded) -> ToEncoded a
$ctoEncoded :: AuthFlow -> Encoded
toEncoded :: AuthFlow -> Encoded
ToEncoded)
instance Session AuthFlow where
  sessionKey :: Text
sessionKey = Text
"OAuth2AuthFlow"
  cookiePath :: Maybe Path
cookiePath = Path -> Maybe Path
forall a. a -> Maybe a
Just Path
"/"
instance Default AuthFlow where
  def :: AuthFlow
def = URI -> Token State -> AuthFlow
AuthFlow (Path -> URI
pathUri Path
"/") (Text -> Token State
forall {k} (a :: k). Text -> Token a
Token Text
forall a. Monoid a => a
mempty)


data Config = Config
  { Config -> Token ClientId
clientId :: Token ClientId
  , Config -> Token ClientSecret
clientSecret :: Token ClientSecret
  , Config -> Endpoint Auth
authorize :: Endpoint Auth
  , Config -> Endpoint (Token ())
token :: Endpoint (Token ())
  }


data TokenType
  = Bearer
  deriving (Int -> TokenType -> ShowS
[TokenType] -> ShowS
TokenType -> String
(Int -> TokenType -> ShowS)
-> (TokenType -> String)
-> ([TokenType] -> ShowS)
-> Show TokenType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenType -> ShowS
showsPrec :: Int -> TokenType -> ShowS
$cshow :: TokenType -> String
show :: TokenType -> String
$cshowList :: [TokenType] -> ShowS
showList :: [TokenType] -> ShowS
Show, ReadPrec [TokenType]
ReadPrec TokenType
Int -> ReadS TokenType
ReadS [TokenType]
(Int -> ReadS TokenType)
-> ReadS [TokenType]
-> ReadPrec TokenType
-> ReadPrec [TokenType]
-> Read TokenType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TokenType
readsPrec :: Int -> ReadS TokenType
$creadList :: ReadS [TokenType]
readList :: ReadS [TokenType]
$creadPrec :: ReadPrec TokenType
readPrec :: ReadPrec TokenType
$creadListPrec :: ReadPrec [TokenType]
readListPrec :: ReadPrec [TokenType]
Read, (forall x. TokenType -> Rep TokenType x)
-> (forall x. Rep TokenType x -> TokenType) -> Generic TokenType
forall x. Rep TokenType x -> TokenType
forall x. TokenType -> Rep TokenType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TokenType -> Rep TokenType x
from :: forall x. TokenType -> Rep TokenType x
$cto :: forall x. Rep TokenType x -> TokenType
to :: forall x. Rep TokenType x -> TokenType
Generic, TokenType -> ParamValue
(TokenType -> ParamValue) -> ToParam TokenType
forall a. (a -> ParamValue) -> ToParam a
$ctoParam :: TokenType -> ParamValue
toParam :: TokenType -> ParamValue
ToParam, Maybe Text -> Either String TokenType
ParamValue -> Either String TokenType
(ParamValue -> Either String TokenType)
-> (Maybe Text -> Either String TokenType) -> FromParam TokenType
forall a.
(ParamValue -> Either String a)
-> (Maybe Text -> Either String a) -> FromParam a
$cparseParam :: ParamValue -> Either String TokenType
parseParam :: ParamValue -> Either String TokenType
$cdecodeFormValue :: Maybe Text -> Either String TokenType
decodeFormValue :: Maybe Text -> Either String TokenType
FromParam)
instance ToJSON TokenType where
  toJSON :: TokenType -> Value
toJSON TokenType
s = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ TokenType -> String
forall a. Show a => a -> String
show TokenType
s
instance FromJSON TokenType where
  parseJSON :: Value -> Parser TokenType
parseJSON (String Text
ttyp) | Text -> Text
T.toLower Text
ttyp Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"bearer" = TokenType -> Parser TokenType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TokenType
Bearer
  parseJSON Value
val = String -> Parser TokenType
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TokenType) -> String -> Parser TokenType
forall a b. (a -> b) -> a -> b
$ String
"expected TokenType but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
val


data Authenticated = Authenticated
  { Authenticated -> TokenType
tokenType :: TokenType
  , Authenticated -> Maybe Int
expiresIn :: Maybe Int
  , Authenticated -> Maybe Scopes
scope :: Maybe Scopes
  , Authenticated -> Token Access
accessToken :: Token Access
  , Authenticated -> Maybe (Token Refresh)
refreshToken :: Maybe (Token Refresh)
  }
  deriving ((forall x. Authenticated -> Rep Authenticated x)
-> (forall x. Rep Authenticated x -> Authenticated)
-> Generic Authenticated
forall x. Rep Authenticated x -> Authenticated
forall x. Authenticated -> Rep Authenticated x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Authenticated -> Rep Authenticated x
from :: forall x. Authenticated -> Rep Authenticated x
$cto :: forall x. Rep Authenticated x -> Authenticated
to :: forall x. Rep Authenticated x -> Authenticated
Generic, Int -> Authenticated -> ShowS
[Authenticated] -> ShowS
Authenticated -> String
(Int -> Authenticated -> ShowS)
-> (Authenticated -> String)
-> ([Authenticated] -> ShowS)
-> Show Authenticated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Authenticated -> ShowS
showsPrec :: Int -> Authenticated -> ShowS
$cshow :: Authenticated -> String
show :: Authenticated -> String
$cshowList :: [Authenticated] -> ShowS
showList :: [Authenticated] -> ShowS
Show, Authenticated -> ParamValue
(Authenticated -> ParamValue) -> ToParam Authenticated
forall a. (a -> ParamValue) -> ToParam a
$ctoParam :: Authenticated -> ParamValue
toParam :: Authenticated -> ParamValue
ToParam, Maybe Text -> Either String Authenticated
ParamValue -> Either String Authenticated
(ParamValue -> Either String Authenticated)
-> (Maybe Text -> Either String Authenticated)
-> FromParam Authenticated
forall a.
(ParamValue -> Either String a)
-> (Maybe Text -> Either String a) -> FromParam a
$cparseParam :: ParamValue -> Either String Authenticated
parseParam :: ParamValue -> Either String Authenticated
$cdecodeFormValue :: Maybe Text -> Either String Authenticated
decodeFormValue :: Maybe Text -> Either String Authenticated
FromParam, Authenticated -> Encoded
(Authenticated -> Encoded) -> ToEncoded Authenticated
forall a. (a -> Encoded) -> ToEncoded a
$ctoEncoded :: Authenticated -> Encoded
toEncoded :: Authenticated -> Encoded
ToEncoded, Encoded -> Either String Authenticated
(Encoded -> Either String Authenticated)
-> FromEncoded Authenticated
forall a. (Encoded -> Either String a) -> FromEncoded a
$cparseEncoded :: Encoded -> Either String Authenticated
parseEncoded :: Encoded -> Either String Authenticated
FromEncoded)
instance FromJSON Authenticated where
  parseJSON :: Value -> Parser Authenticated
parseJSON = Options -> Value -> Parser Authenticated
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions{fieldLabelModifier = quietSnake}
instance ToJSON Authenticated where
  toJSON :: Authenticated -> Value
toJSON = Options -> Authenticated -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions{fieldLabelModifier = quietSnake}
instance Session Authenticated where
  sessionKey :: Text
sessionKey = Text
"OAuth2Authenticated"
  cookiePath :: Maybe Path
cookiePath = Path -> Maybe Path
forall a. a -> Maybe a
Just Path
"/"


data OAuth2Error
  = OAuth2BadResponse String BL.ByteString
  | OAuth2TokenRequest HttpException
  | OAuth2BadEnv String String
  deriving (Int -> OAuth2Error -> ShowS
[OAuth2Error] -> ShowS
OAuth2Error -> String
(Int -> OAuth2Error -> ShowS)
-> (OAuth2Error -> String)
-> ([OAuth2Error] -> ShowS)
-> Show OAuth2Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuth2Error -> ShowS
showsPrec :: Int -> OAuth2Error -> ShowS
$cshow :: OAuth2Error -> String
show :: OAuth2Error -> String
$cshowList :: [OAuth2Error] -> ShowS
showList :: [OAuth2Error] -> ShowS
Show, Show OAuth2Error
Typeable OAuth2Error
(Typeable OAuth2Error, Show OAuth2Error) =>
(OAuth2Error -> SomeException)
-> (SomeException -> Maybe OAuth2Error)
-> (OAuth2Error -> String)
-> Exception OAuth2Error
SomeException -> Maybe OAuth2Error
OAuth2Error -> String
OAuth2Error -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: OAuth2Error -> SomeException
toException :: OAuth2Error -> SomeException
$cfromException :: SomeException -> Maybe OAuth2Error
fromException :: SomeException -> Maybe OAuth2Error
$cdisplayException :: OAuth2Error -> String
displayException :: OAuth2Error -> String
Exception)


-- Lower level --------------------------------------------------

authorizationUrl :: Endpoint Auth -> Token ClientId -> URI -> Scopes -> Token State -> URI
authorizationUrl :: Endpoint Auth
-> Token ClientId -> URI -> Scopes -> Token State -> URI
authorizationUrl (Endpoint URI
auth) (Token Text
cid) URI
redUrl (Scopes [Text]
scopes) (Token Text
state) =
  URI
auth{uriQuery = cs $ renderQuery True authParams}
 where
  authParams :: Query
authParams =
    [ (ByteString
"response_type", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"code")
    , (ByteString
"client_id", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
cid)
    , (ByteString
"redirect_uri", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText URI
redUrl)
    , (ByteString
"scope", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
" " [Text]
scopes)
    , (ByteString
"state", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
state)
    ]


tokenParams :: Token ClientId -> Token ClientSecret -> URI -> Token Code -> Query
tokenParams :: Token ClientId -> Token ClientSecret -> URI -> Token Code -> Query
tokenParams (Token Text
cid) (Token Text
sec) URI
redUrl (Token Text
ac) =
  [ (ByteString
"grant_type", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"authorization_code")
  , (ByteString
"client_id", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
cid)
  , (ByteString
"client_secret", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
sec)
  , (ByteString
"redirect_uri", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText URI
redUrl)
  , (ByteString
"code", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
ac)
  ]


refreshParams :: Token ClientId -> Token ClientSecret -> Token Refresh -> Query
refreshParams :: Token ClientId -> Token ClientSecret -> Token Refresh -> Query
refreshParams (Token Text
cid) (Token Text
sec) (Token Text
ref) =
  [ (ByteString
"grant_type", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"refresh_token")
  , (ByteString
"client_id", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
cid)
  , (ByteString
"client_secret", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
sec)
  , (ByteString
"refresh_token", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
ref)
  ]


validateRedirectParams :: (Hyperbole :> es) => AuthFlow -> Eff es (Token Code)
validateRedirectParams :: forall (es :: [Effect]).
(Hyperbole :> es) =>
AuthFlow -> Eff es (Token Code)
validateRedirectParams AuthFlow
flow = do
  Maybe Text
err <- forall a (es :: [Effect]).
(FromParam a, Hyperbole :> es) =>
Param -> Eff es (Maybe a)
lookupParam @Text Param
"error"

  Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
err) (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
    Text
desc <- Param -> Eff es Text
forall a (es :: [Effect]).
(FromParam a, Hyperbole :> es) =>
Param -> Eff es a
param Param
"error_description"
    ResponseError -> Eff es ()
forall (es :: [Effect]) a.
(Hyperbole :> es) =>
ResponseError -> Eff es a
respondError (ResponseError -> Eff es ()) -> ResponseError -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
ErrAuth Text
desc

  Token State
authState <- forall a (es :: [Effect]).
(FromParam a, Hyperbole :> es) =>
Param -> Eff es a
param @(Token State) Param
"state"
  Token Code
authCode <- forall a (es :: [Effect]).
(FromParam a, Hyperbole :> es) =>
Param -> Eff es a
param @(Token Code) Param
"code"

  Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthFlow
flow.state Token State -> Token State -> Bool
forall a. Eq a => a -> a -> Bool
== Token State
authState) (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
    ResponseError -> Eff es ()
forall (es :: [Effect]) a.
(Hyperbole :> es) =>
ResponseError -> Eff es a
respondError (ResponseError -> Eff es ()) -> ResponseError -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
ErrAuth Text
"Oauth2 State mismatch"

  Token Code -> Eff es (Token Code)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token Code
authCode


sendTokenRequest :: (IOE :> es) => Config -> HTTP.Manager -> Query -> Eff es Authenticated
sendTokenRequest :: forall (es :: [Effect]).
(IOE :> es) =>
Config -> Manager -> Query -> Eff es Authenticated
sendTokenRequest Config
cfg Manager
mgr Query
params = do
  Request
baseReq <- URI -> Eff es Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI Config
cfg.token.uri

  let req :: Request
req =
        Request
baseReq
          { method = "POST"
          , requestBody = RequestBodyBS $ renderQuery False params
          , requestHeaders =
              [ (hContentType, "application/x-www-form-urlencoded")
              , (hAccept, "application/json")
              ]
          }

  Response ByteString
res <- IO (Response ByteString) -> Eff es (Response ByteString)
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
mgr) Eff es (Response ByteString)
-> (HttpException -> Eff es (Response ByteString))
-> Eff es (Response ByteString)
forall e (es :: [Effect]) a.
Exception e =>
Eff es a -> (e -> Eff es a) -> Eff es a
`catch` (OAuth2Error -> Eff es (Response ByteString)
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (OAuth2Error -> Eff es (Response ByteString))
-> (HttpException -> OAuth2Error)
-> HttpException
-> Eff es (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> OAuth2Error
OAuth2TokenRequest)

  let body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
res
  case forall a. FromJSON a => ByteString -> Either String a
eitherDecode @Authenticated ByteString
body of
    Left String
e -> OAuth2Error -> Eff es Authenticated
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (OAuth2Error -> Eff es Authenticated)
-> OAuth2Error -> Eff es Authenticated
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> OAuth2Error
OAuth2BadResponse String
e ByteString
body
    Right Authenticated
tr -> Authenticated -> Eff es Authenticated
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Authenticated
tr