{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TupleSections #-}
module Snap.Snaplet.CustomAuth.OAuth2.Internal
( oauth2Init
, saveAction
, redirectToProvider
) where
import Control.Error.Util hiding (err)
import Control.Lens
import Control.Monad.Except
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.State
import Data.Aeson
import qualified Data.Binary
import Data.Binary (Binary)
import Data.Binary.Instances ()
import qualified Data.ByteString.Base64
import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
import Data.Char (chr)
import qualified Data.Configurator as C
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Maybe (isJust, isNothing, catMaybes)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Network.HTTP.Client (Manager)
import Network.OAuth.OAuth2
import Prelude hiding (lookup)
import Snap hiding (path)
import Snap.Snaplet.Session
import System.Random
import URI.ByteString
import Snap.Snaplet.CustomAuth.AuthManager
import Snap.Snaplet.CustomAuth.Types hiding (name)
import Snap.Snaplet.CustomAuth.User (setUser, currentUser, recoverSession)
import Snap.Snaplet.CustomAuth.Util (getStateName, getParamText, setFailure)
oauth2Init
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Initializer b (AuthManager u e b) (HashMap Text Provider)
oauth2Init :: OAuth2Settings u i e b
-> Initializer b (AuthManager u e b) (HashMap Text Provider)
oauth2Init OAuth2Settings u i e b
s = do
Config
cfg <- Initializer b (AuthManager u e b) Config
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig
ByteString
root <- Initializer b (AuthManager u e b) ByteString
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v ByteString
getSnapletRootURL
ByteString
hostname <- IO ByteString -> Initializer b (AuthManager u e b) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Initializer b (AuthManager u e b) ByteString)
-> IO ByteString -> Initializer b (AuthManager u e b) ByteString
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO ByteString
forall a. Configured a => Config -> Text -> IO a
C.require Config
cfg Text
"hostname"
ByteString
scheme <- IO ByteString -> Initializer b (AuthManager u e b) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Initializer b (AuthManager u e b) ByteString)
-> IO ByteString -> Initializer b (AuthManager u e b) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Config -> Text -> IO ByteString
forall a. Configured a => a -> Config -> Text -> IO a
C.lookupDefault ByteString
"https" Config
cfg Text
"protocol"
[Text]
names <- IO [Text] -> Initializer b (AuthManager u e b) [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> Initializer b (AuthManager u e b) [Text])
-> IO [Text] -> Initializer b (AuthManager u e b) [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Config -> Text -> IO [Text]
forall a. Configured a => a -> Config -> Text -> IO a
C.lookupDefault [] Config
cfg Text
"oauth2.providers"
let makeProvider :: Text -> MaybeT IO Provider
makeProvider Text
name = let
name' :: Text
name' = Text
"oauth2." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
lk :: Text -> MaybeT IO Text
lk = IO (Maybe Text) -> MaybeT IO Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Text) -> MaybeT IO Text)
-> (Text -> IO (Maybe Text)) -> Text -> MaybeT IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text -> IO (Maybe Text)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
cfg (Text -> IO (Maybe Text))
-> (Text -> Text) -> Text -> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
lku :: Text -> MaybeT IO (URIRef Absolute)
lku Text
n = Text -> MaybeT IO Text
lk Text
n MaybeT IO Text
-> (Text -> MaybeT IO (URIRef Absolute))
-> MaybeT IO (URIRef Absolute)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO (Maybe (URIRef Absolute)) -> MaybeT IO (URIRef Absolute)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (URIRef Absolute)) -> MaybeT IO (URIRef Absolute))
-> (Text -> IO (Maybe (URIRef Absolute)))
-> Text
-> MaybeT IO (URIRef Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (URIRef Absolute) -> IO (Maybe (URIRef Absolute))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (URIRef Absolute) -> IO (Maybe (URIRef Absolute)))
-> (Text -> Maybe (URIRef Absolute))
-> Text
-> IO (Maybe (URIRef Absolute))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either URIParseError (URIRef Absolute) -> Maybe (URIRef Absolute)
forall a b. Either a b -> Maybe b
hush (Either URIParseError (URIRef Absolute) -> Maybe (URIRef Absolute))
-> (Text -> Either URIParseError (URIRef Absolute))
-> Text
-> Maybe (URIRef Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
strictURIParserOptions (ByteString -> Either URIParseError (URIRef Absolute))
-> (Text -> ByteString)
-> Text
-> Either URIParseError (URIRef Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
callback :: URIRef Absolute
callback = Scheme
-> Maybe Authority
-> ByteString
-> Query
-> Maybe ByteString
-> URIRef Absolute
URI (ByteString -> Scheme
Scheme ByteString
scheme)
(Authority -> Maybe Authority
forall a. a -> Maybe a
Just (Authority -> Maybe Authority) -> Authority -> Maybe Authority
forall a b. (a -> b) -> a -> b
$ Maybe UserInfo -> Host -> Maybe Port -> Authority
Authority Maybe UserInfo
forall a. Maybe a
Nothing (ByteString -> Host
Host ByteString
hostname) Maybe Port
forall a. Maybe a
Nothing)
(ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
root ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/oauth2callback/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 Text
name))
Query
forall a. Monoid a => a
mempty Maybe ByteString
forall a. Maybe a
Nothing
in Text
-> Maybe (URIRef Absolute)
-> Text
-> URIRef Absolute
-> Text
-> OAuth2
-> Provider
Provider
(Text
-> Maybe (URIRef Absolute)
-> Text
-> URIRef Absolute
-> Text
-> OAuth2
-> Provider)
-> MaybeT IO Text
-> MaybeT
IO
(Maybe (URIRef Absolute)
-> Text -> URIRef Absolute -> Text -> OAuth2 -> Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO (Maybe Text) -> MaybeT IO Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Text) -> MaybeT IO Text)
-> IO (Maybe Text) -> MaybeT IO Text
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
name)
MaybeT
IO
(Maybe (URIRef Absolute)
-> Text -> URIRef Absolute -> Text -> OAuth2 -> Provider)
-> MaybeT IO (Maybe (URIRef Absolute))
-> MaybeT
IO (Text -> URIRef Absolute -> Text -> OAuth2 -> Provider)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (IO (Maybe (Maybe (URIRef Absolute)))
-> MaybeT IO (Maybe (URIRef Absolute))
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Maybe (URIRef Absolute)))
-> MaybeT IO (Maybe (URIRef Absolute)))
-> IO (Maybe (Maybe (URIRef Absolute)))
-> MaybeT IO (Maybe (URIRef Absolute))
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe (URIRef Absolute))
-> IO (Maybe (Maybe (URIRef Absolute)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe (URIRef Absolute))
-> IO (Maybe (Maybe (URIRef Absolute))))
-> Maybe (Maybe (URIRef Absolute))
-> IO (Maybe (Maybe (URIRef Absolute)))
forall a b. (a -> b) -> a -> b
$ Maybe (URIRef Absolute) -> Maybe (Maybe (URIRef Absolute))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (URIRef Absolute) -> Maybe (Maybe (URIRef Absolute)))
-> Maybe (URIRef Absolute) -> Maybe (Maybe (URIRef Absolute))
forall a b. (a -> b) -> a -> b
$ Maybe (URIRef Absolute)
forall a. Maybe a
Nothing)
MaybeT IO (Text -> URIRef Absolute -> Text -> OAuth2 -> Provider)
-> MaybeT IO Text
-> MaybeT IO (URIRef Absolute -> Text -> OAuth2 -> Provider)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> MaybeT IO Text
lk Text
".scope"
MaybeT IO (URIRef Absolute -> Text -> OAuth2 -> Provider)
-> MaybeT IO (URIRef Absolute)
-> MaybeT IO (Text -> OAuth2 -> Provider)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> MaybeT IO (URIRef Absolute)
lku Text
".endpoint.identity"
MaybeT IO (Text -> OAuth2 -> Provider)
-> MaybeT IO Text -> MaybeT IO (OAuth2 -> Provider)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> MaybeT IO Text
lk Text
".identityField"
MaybeT IO (OAuth2 -> Provider)
-> MaybeT IO OAuth2 -> MaybeT IO Provider
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text
-> Maybe Text
-> URIRef Absolute
-> URIRef Absolute
-> Maybe (URIRef Absolute)
-> OAuth2
OAuth2
(Text
-> Maybe Text
-> URIRef Absolute
-> URIRef Absolute
-> Maybe (URIRef Absolute)
-> OAuth2)
-> MaybeT IO Text
-> MaybeT
IO
(Maybe Text
-> URIRef Absolute
-> URIRef Absolute
-> Maybe (URIRef Absolute)
-> OAuth2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> MaybeT IO Text
lk Text
".clientId"
MaybeT
IO
(Maybe Text
-> URIRef Absolute
-> URIRef Absolute
-> Maybe (URIRef Absolute)
-> OAuth2)
-> MaybeT IO (Maybe Text)
-> MaybeT
IO
(URIRef Absolute
-> URIRef Absolute -> Maybe (URIRef Absolute) -> OAuth2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (IO (Maybe Text) -> MaybeT IO (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Text) -> MaybeT IO (Maybe Text))
-> IO (Maybe Text) -> MaybeT IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ MaybeT IO Text -> IO (Maybe Text)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Text -> IO (Maybe Text))
-> MaybeT IO Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> MaybeT IO Text
lk Text
".clientSecret")
MaybeT
IO
(URIRef Absolute
-> URIRef Absolute -> Maybe (URIRef Absolute) -> OAuth2)
-> MaybeT IO (URIRef Absolute)
-> MaybeT IO (URIRef Absolute -> Maybe (URIRef Absolute) -> OAuth2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> MaybeT IO (URIRef Absolute)
lku Text
".endpoint.auth"
MaybeT IO (URIRef Absolute -> Maybe (URIRef Absolute) -> OAuth2)
-> MaybeT IO (URIRef Absolute)
-> MaybeT IO (Maybe (URIRef Absolute) -> OAuth2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> MaybeT IO (URIRef Absolute)
lku Text
".endpoint.access"
MaybeT IO (Maybe (URIRef Absolute) -> OAuth2)
-> MaybeT IO (Maybe (URIRef Absolute)) -> MaybeT IO OAuth2
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe (URIRef Absolute) -> MaybeT IO (Maybe (URIRef Absolute))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (URIRef Absolute) -> MaybeT IO (Maybe (URIRef Absolute)))
-> Maybe (URIRef Absolute) -> MaybeT IO (Maybe (URIRef Absolute))
forall a b. (a -> b) -> a -> b
$ URIRef Absolute -> Maybe (URIRef Absolute)
forall a. a -> Maybe a
Just URIRef Absolute
callback))
[(ByteString, Handler b (AuthManager u e b) ())]
-> Initializer b (AuthManager u e b) ()
forall b v. [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes ([(ByteString, Handler b (AuthManager u e b) ())]
-> Initializer b (AuthManager u e b) ())
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> Initializer b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ ((ByteString, Handler b (AuthManager u e b) ())
-> Identity (ByteString, Handler b (AuthManager u e b) ()))
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> Identity [(ByteString, Handler b (AuthManager u e b) ())]
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped(((ByteString, Handler b (AuthManager u e b) ())
-> Identity (ByteString, Handler b (AuthManager u e b) ()))
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> Identity [(ByteString, Handler b (AuthManager u e b) ())])
-> ((Handler b (AuthManager u e b) ()
-> Identity (Handler b (AuthManager u e b) ()))
-> (ByteString, Handler b (AuthManager u e b) ())
-> Identity (ByteString, Handler b (AuthManager u e b) ()))
-> (Handler b (AuthManager u e b) ()
-> Identity (Handler b (AuthManager u e b) ()))
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> Identity [(ByteString, Handler b (AuthManager u e b) ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Handler b (AuthManager u e b) ()
-> Identity (Handler b (AuthManager u e b) ()))
-> (ByteString, Handler b (AuthManager u e b) ())
-> Identity (ByteString, Handler b (AuthManager u e b) ())
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Handler b (AuthManager u e b) ()
-> Identity (Handler b (AuthManager u e b) ()))
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> Identity [(ByteString, Handler b (AuthManager u e b) ())])
-> (Handler b (AuthManager u e b) ()
-> Handler b (AuthManager u e b) ())
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> [(ByteString, Handler b (AuthManager u e b) ())]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (OAuth2Settings u i e b
-> Handler b (AuthManager u e b) ()
-> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> Handler b (AuthManager u e b) ()
-> Handler b (AuthManager u e b) ()
bracket OAuth2Settings u i e b
s) ([(ByteString, Handler b (AuthManager u e b) ())]
-> [(ByteString, Handler b (AuthManager u e b) ())])
-> [(ByteString, Handler b (AuthManager u e b) ())]
-> [(ByteString, Handler b (AuthManager u e b) ())]
forall a b. (a -> b) -> a -> b
$
[ (ByteString
"oauth2createaccount", OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
oauth2CreateAccount OAuth2Settings u i e b
s)
, (ByteString
"oauth2callback/:provider", OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
oauth2Callback OAuth2Settings u i e b
s)
, (ByteString
"oauth2login/:provider", Handler b (AuthManager u e b) ()
forall b u e. Handler b (AuthManager u e b) ()
redirectLogin)
]
IO (HashMap Text Provider)
-> Initializer b (AuthManager u e b) (HashMap Text Provider)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap Text Provider)
-> Initializer b (AuthManager u e b) (HashMap Text Provider))
-> IO (HashMap Text Provider)
-> Initializer b (AuthManager u e b) (HashMap Text Provider)
forall a b. (a -> b) -> a -> b
$ [(Text, Provider)] -> HashMap Text Provider
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, Provider)] -> HashMap Text Provider)
-> ([Maybe Provider] -> [(Text, Provider)])
-> [Maybe Provider]
-> HashMap Text Provider
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Provider -> (Text, Provider)) -> [Provider] -> [(Text, Provider)]
forall a b. (a -> b) -> [a] -> [b]
map (\Provider
x -> (Provider -> Text
providerName Provider
x, Provider
x)) ([Provider] -> [(Text, Provider)])
-> ([Maybe Provider] -> [Provider])
-> [Maybe Provider]
-> [(Text, Provider)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Provider] -> [Provider]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Provider] -> HashMap Text Provider)
-> IO [Maybe Provider] -> IO (HashMap Text Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((Text -> IO (Maybe Provider)) -> [Text] -> IO [Maybe Provider]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MaybeT IO Provider -> IO (Maybe Provider)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Provider -> IO (Maybe Provider))
-> (Text -> MaybeT IO Provider) -> Text -> IO (Maybe Provider)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MaybeT IO Provider
makeProvider) [Text]
names)
redirectLogin
:: Handler b (AuthManager u e b) ()
redirectLogin :: Handler b (AuthManager u e b) ()
redirectLogin = do
HashMap Text Provider
provs <- (AuthManager u e b -> HashMap Text Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> HashMap Text Provider
forall u e b. AuthManager u e b -> HashMap Text Provider
providers
Maybe Provider
provider <- ((Text -> HashMap Text Provider -> Maybe Provider)
-> HashMap Text Provider -> Text -> Maybe Provider
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> HashMap Text Provider -> Maybe Provider
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup HashMap Text Provider
provs (Text -> Maybe Provider) -> Maybe Text -> Maybe Provider
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Text -> Maybe Provider)
-> Handler b (AuthManager u e b) (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Handler b (AuthManager u e b) (Maybe Text)
forall (f :: * -> *). MonadSnap f => ByteString -> f (Maybe Text)
getParamText ByteString
"provider"
Handler b (AuthManager u e b) ()
-> (Provider -> Handler b (AuthManager u e b) ())
-> Maybe Provider
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. MonadSnap m => m a
pass Provider -> Handler b (AuthManager u e b) ()
forall b u e. Provider -> Handler b (AuthManager u e b) ()
toProvider Maybe Provider
provider
where
toProvider :: Provider -> Handler b (AuthManager u e b) ()
toProvider Provider
p = do
Bool
success <- Text -> Handler b (AuthManager u e b) Bool
forall b u e. Text -> Handler b (AuthManager u e b) Bool
redirectToProvider (Text -> Handler b (AuthManager u e b) Bool)
-> Text -> Handler b (AuthManager u e b) Bool
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
p
if Bool
success then () -> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
getRedirUrl
:: Provider
-> Text
-> URI
getRedirUrl :: Provider -> Text -> URIRef Absolute
getRedirUrl Provider
p Text
token =
[(ByteString, ByteString)] -> URIRef Absolute -> URIRef Absolute
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString
"state", Text -> ByteString
encodeUtf8 Text
token)
,(ByteString
"scope", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Provider -> Text
scope Provider
p)] (URIRef Absolute -> URIRef Absolute)
-> URIRef Absolute -> URIRef Absolute
forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
authorizationUrl (OAuth2 -> URIRef Absolute) -> OAuth2 -> URIRef Absolute
forall a b. (a -> b) -> a -> b
$ Provider -> OAuth2
oauth Provider
p
redirectToProvider
:: Text
-> Handler b (AuthManager u e b) Bool
redirectToProvider :: Text -> Handler b (AuthManager u e b) Bool
redirectToProvider Text
pName = do
Handler b (AuthManager u e b) Bool
-> (Provider -> Handler b (AuthManager u e b) Bool)
-> Maybe Provider
-> Handler b (AuthManager u e b) Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Handler b (AuthManager u e b) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Provider -> Handler b (AuthManager u e b) Bool
forall b u e. Provider -> Handler b (AuthManager u e b) Bool
redirectToProvider' (Maybe Provider -> Handler b (AuthManager u e b) Bool)
-> Handler b (AuthManager u e b) (Maybe Provider)
-> Handler b (AuthManager u e b) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> HashMap Text Provider -> Maybe Provider
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
pName (HashMap Text Provider -> Maybe Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
-> Handler b (AuthManager u e b) (Maybe Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthManager u e b -> HashMap Text Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> HashMap Text Provider
forall u e b. AuthManager u e b -> HashMap Text Provider
providers
redirectToProvider'
:: Provider
-> Handler b (AuthManager u e b) Bool
redirectToProvider' :: Provider -> Handler b (AuthManager u e b) Bool
redirectToProvider' Provider
provider = do
SnapletLens (Snaplet b) SessionManager
store <- (AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
forall u e b.
AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
stateStore'
Text
stamp <- IO Text -> Handler b (AuthManager u e b) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler b (AuthManager u e b) Text)
-> IO Text -> Handler b (AuthManager u e b) Text
forall a b. (a -> b) -> a -> b
$ (String -> Text
T.pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show) (UTCTime -> Text) -> IO UTCTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
Text
name <- Handler b (AuthManager u e b) Text
forall b u e. Handler b (AuthManager u e b) Text
getStateName
let randomChar :: Int -> Char
randomChar Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
chr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
48)
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Int -> Char
chr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
55)
| Bool
otherwise = Int -> Char
chr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
61)
randomText :: Int -> IO Text
randomText Int
n = String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Char -> IO String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Int -> Char
randomChar (Int -> Char) -> IO Int -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0,Int
61))
Text
token <- IO Text -> Handler b (AuthManager u e b) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler b (AuthManager u e b) Text)
-> IO Text -> Handler b (AuthManager u e b) Text
forall a b. (a -> b) -> a -> b
$ Int -> IO Text
randomText Int
20
SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager () -> Handler b (AuthManager u e b) ())
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession Text
name Text
token
Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_stamp") Text
stamp
Handler b SessionManager ()
forall b. Handler b SessionManager ()
commitSession
let redirUrl :: ByteString
redirUrl = URIRef Absolute -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URIRef Absolute -> ByteString) -> URIRef Absolute -> ByteString
forall a b. (a -> b) -> a -> b
$ Provider -> Text -> URIRef Absolute
getRedirUrl Provider
provider Text
token
ByteString -> Int -> Handler b (AuthManager u e b) Bool
forall (m :: * -> *) a. MonadSnap m => ByteString -> Int -> m a
redirect' ByteString
redirUrl Int
303
getUserInfo
:: MonadIO m
=> Manager
-> Provider
-> AccessToken
-> ExceptT (Maybe ByteString) m Text
getUserInfo :: Manager
-> Provider -> AccessToken -> ExceptT (Maybe ByteString) m Text
getUserInfo Manager
mgr Provider
provider AccessToken
token = do
let endpoint :: URIRef Absolute
endpoint = Provider -> URIRef Absolute
identityEndpoint Provider
provider
((ByteString -> Maybe ByteString)
-> ExceptT ByteString m (HashMap Text Value)
-> ExceptT (Maybe ByteString) m (HashMap Text Value)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ExceptT ByteString m (HashMap Text Value)
-> ExceptT (Maybe ByteString) m (HashMap Text Value))
-> ExceptT ByteString m (HashMap Text Value)
-> ExceptT (Maybe ByteString) m (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ m (Either ByteString (HashMap Text Value))
-> ExceptT ByteString m (HashMap Text Value)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ByteString (HashMap Text Value))
-> ExceptT ByteString m (HashMap Text Value))
-> m (Either ByteString (HashMap Text Value))
-> ExceptT ByteString m (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ IO (Either ByteString (HashMap Text Value))
-> m (Either ByteString (HashMap Text Value))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ByteString (HashMap Text Value))
-> m (Either ByteString (HashMap Text Value)))
-> IO (Either ByteString (HashMap Text Value))
-> m (Either ByteString (HashMap Text Value))
forall a b. (a -> b) -> a -> b
$ Manager
-> AccessToken
-> URIRef Absolute
-> IO (Either ByteString (HashMap Text Value))
forall b.
FromJSON b =>
Manager
-> AccessToken -> URIRef Absolute -> IO (Either ByteString b)
authGetJSON Manager
mgr AccessToken
token URIRef Absolute
endpoint) ExceptT (Maybe ByteString) m (HashMap Text Value)
-> (HashMap Text Value -> ExceptT (Maybe ByteString) m Text)
-> ExceptT (Maybe ByteString) m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ExceptT (Maybe ByteString) m Text
-> (Text -> ExceptT (Maybe ByteString) m Text)
-> Maybe Text
-> ExceptT (Maybe ByteString) m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe ByteString -> ExceptT (Maybe ByteString) m Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Maybe ByteString
forall a. Maybe a
Nothing) Text -> ExceptT (Maybe ByteString) m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> ExceptT (Maybe ByteString) m Text)
-> (HashMap Text Value -> Maybe Text)
-> HashMap Text Value
-> ExceptT (Maybe ByteString) m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Value -> Maybe Text
lookupProviderInfo)
where
lookup' :: k -> HashMap k Value -> Maybe Text
lookup' k
a HashMap k Value
b = Value -> Maybe Text
maybeText (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< k -> HashMap k Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
a HashMap k Value
b
maybeText :: Value -> Maybe Text
maybeText (String Text
x) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
maybeText Value
_ = Maybe Text
forall a. Maybe a
Nothing
lookupProviderInfo :: HashMap Text Value -> Maybe Text
lookupProviderInfo = Text -> HashMap Text Value -> Maybe Text
forall k. (Eq k, Hashable k) => k -> HashMap k Value -> Maybe Text
lookup' (Provider -> Text
identityField Provider
provider)
oauth2Callback
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Handler b (AuthManager u e b) ()
oauth2Callback :: OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
oauth2Callback OAuth2Settings u i e b
s = do
HashMap Text Provider
provs <- (AuthManager u e b -> HashMap Text Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> HashMap Text Provider
forall u e b. AuthManager u e b -> HashMap Text Provider
providers
Handler b (AuthManager u e b) ()
-> (Provider -> Handler b (AuthManager u e b) ())
-> Maybe Provider
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. MonadSnap m => m a
pass (OAuth2Settings u i e b
-> Provider -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b
-> Provider -> Handler b (AuthManager u e b) ()
oauth2Callback' OAuth2Settings u i e b
s) (Maybe Provider -> Handler b (AuthManager u e b) ())
-> Handler b (AuthManager u e b) (Maybe Provider)
-> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(((Text -> HashMap Text Provider -> Maybe Provider)
-> HashMap Text Provider -> Text -> Maybe Provider
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> HashMap Text Provider -> Maybe Provider
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup HashMap Text Provider
provs (Text -> Maybe Provider) -> Maybe Text -> Maybe Provider
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Text -> Maybe Provider)
-> Handler b (AuthManager u e b) (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Handler b (AuthManager u e b) (Maybe Text)
forall (f :: * -> *). MonadSnap f => ByteString -> f (Maybe Text)
getParamText ByteString
"provider")
oauth2Callback'
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Provider
-> Handler b (AuthManager u e b) ()
oauth2Callback' :: OAuth2Settings u i e b
-> Provider -> Handler b (AuthManager u e b) ()
oauth2Callback' OAuth2Settings u i e b
s Provider
provider = do
Text
name <- Handler b (AuthManager u e b) Text
forall b u e. Handler b (AuthManager u e b) Text
getStateName
let ss :: SnapletLens (Snaplet b) SessionManager
ss = OAuth2Settings u i e b -> SnapletLens (Snaplet b) SessionManager
forall u i e b.
OAuth2Settings u i e b -> SnapletLens (Snaplet b) SessionManager
stateStore OAuth2Settings u i e b
s
mgr :: Manager
mgr = OAuth2Settings u i e b -> Manager
forall u i e b. OAuth2Settings u i e b -> Manager
httpManager OAuth2Settings u i e b
s
Either OAuth2Failure Text
res <- ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
-> Handler b (AuthManager u e b) (Either OAuth2Failure Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
-> Handler b (AuthManager u e b) (Either OAuth2Failure Text))
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
-> Handler b (AuthManager u e b) (Either OAuth2Failure Text)
forall a b. (a -> b) -> a -> b
$ do
let param :: OAuth2
param = Provider -> OAuth2
oauth Provider
provider
Bool
expiredStamp <- Handler b (AuthManager u e b) Bool
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) Bool
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Bool)
-> Handler b (AuthManager u e b) Bool
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Bool
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager Bool
-> Handler b (AuthManager u e b) Bool
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
ss (Handler b SessionManager Bool
-> Handler b (AuthManager u e b) Bool)
-> Handler b SessionManager Bool
-> Handler b (AuthManager u e b) Bool
forall a b. (a -> b) -> a -> b
$
Handler b SessionManager Bool
-> (UTCTime -> Handler b SessionManager Bool)
-> Maybe UTCTime
-> Handler b SessionManager Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Handler b SessionManager Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (IO Bool -> Handler b SessionManager Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Handler b SessionManager Bool)
-> (UTCTime -> IO Bool) -> UTCTime -> Handler b SessionManager Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> IO Bool
isExpiredStamp) (Maybe UTCTime -> Handler b SessionManager Bool)
-> Handler b SessionManager (Maybe UTCTime)
-> Handler b SessionManager Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Text -> UTCTime) -> Maybe Text -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> UTCTime
forall a. Read a => String -> a
read (String -> UTCTime) -> (Text -> String) -> Text -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Maybe Text -> Maybe UTCTime)
-> Handler b SessionManager (Maybe Text)
-> Handler b SessionManager (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_stamp")
Bool
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
expiredStamp (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ())
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Failure
ExpiredState
Text
hostState <- ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
-> (Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> Maybe Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Failure
StateNotStored) Text -> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text))
-> Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
ss (Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text))
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession Text
name)
Text
providerState <- ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
-> (Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> Maybe Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Failure
StateNotReceived) Text -> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text))
-> Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b (AuthManager u e b) (Maybe Text)
forall (f :: * -> *). MonadSnap f => ByteString -> f (Maybe Text)
getParamText ByteString
"state")
Bool
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
hostState Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
providerState) (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ())
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Failure
BadState
Maybe Any
_ <- MaybeT (ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Any)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Any))
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Any)
forall a b. (a -> b) -> a -> b
$ do
ByteString
err <- ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString)
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString)
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) ByteString)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString)
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) ByteString
forall a b. (a -> b) -> a -> b
$ Handler b (AuthManager u e b) (Maybe ByteString)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe ByteString)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString))
-> Handler b (AuthManager u e b) (Maybe ByteString)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b (AuthManager u e b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
"error"
ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any)
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any
-> MaybeT
(ExceptT OAuth2Failure (Handler b (AuthManager u e b))) Any
forall a b. (a -> b) -> a -> b
$ OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any)
-> OAuth2Failure
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Any
forall a b. (a -> b) -> a -> b
$ Maybe Text -> OAuth2Failure
ProviderError (Maybe Text -> OAuth2Failure) -> Maybe Text -> OAuth2Failure
forall a b. (a -> b) -> a -> b
$ Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> Either UnicodeException Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
err
(ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
-> (ExchangeToken
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken)
-> Maybe ExchangeToken
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OAuth2Failure
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Maybe Text -> OAuth2Failure
IdExtractionFailed Maybe Text
forall a. Maybe a
Nothing)) ExchangeToken
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ExchangeToken
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ExchangeToken)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
((Text -> ExchangeToken) -> Maybe Text -> Maybe ExchangeToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ExchangeToken
ExchangeToken) (Maybe Text -> Maybe ExchangeToken)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe ExchangeToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text))
-> Handler b (AuthManager u e b) (Maybe Text)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b (AuthManager u e b) (Maybe Text)
forall (f :: * -> *). MonadSnap f => ByteString -> f (Maybe Text)
getParamText ByteString
"code")) ExceptT OAuth2Failure (Handler b (AuthManager u e b)) ExchangeToken
-> (ExchangeToken
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(IO (OAuth2Result Errors OAuth2Token)
-> ExceptT
OAuth2Failure
(Handler b (AuthManager u e b))
(OAuth2Result Errors OAuth2Token)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (OAuth2Result Errors OAuth2Token)
-> ExceptT
OAuth2Failure
(Handler b (AuthManager u e b))
(OAuth2Result Errors OAuth2Token))
-> (ExchangeToken -> IO (OAuth2Result Errors OAuth2Token))
-> ExchangeToken
-> ExceptT
OAuth2Failure
(Handler b (AuthManager u e b))
(OAuth2Result Errors OAuth2Token)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manager
-> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
fetchAccessToken Manager
mgr OAuth2
param (ExchangeToken
-> ExceptT
OAuth2Failure
(Handler b (AuthManager u e b))
(OAuth2Result Errors OAuth2Token))
-> (OAuth2Result Errors OAuth2Token
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> ExchangeToken
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
(OAuth2Error Errors
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token)
-> (OAuth2Token
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token)
-> OAuth2Result Errors OAuth2Token
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
-> OAuth2Error Errors
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
forall a b. a -> b -> a
const (ExceptT OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
-> OAuth2Error Errors
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token)
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
-> OAuth2Error Errors
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
forall a b. (a -> b) -> a -> b
$ OAuth2Failure
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Failure
AccessTokenFetchError) OAuth2Token
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OAuth2Result Errors OAuth2Token
-> ExceptT
OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token)
-> (OAuth2Token
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> OAuth2Result Errors OAuth2Token
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
(Maybe ByteString -> OAuth2Failure)
-> ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe Text -> OAuth2Failure
IdExtractionFailed (Maybe Text -> OAuth2Failure)
-> (Maybe ByteString -> Maybe Text)
-> Maybe ByteString
-> OAuth2Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict) (ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)) (ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text)
-> (OAuth2Token
-> ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text)
-> OAuth2Token
-> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Manager
-> Provider
-> AccessToken
-> ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text
forall (m :: * -> *).
MonadIO m =>
Manager
-> Provider -> AccessToken -> ExceptT (Maybe ByteString) m Text
getUserInfo (OAuth2Settings u i e b -> Manager
forall u i e b. OAuth2Settings u i e b -> Manager
httpManager OAuth2Settings u i e b
s) Provider
provider (AccessToken
-> ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text)
-> (OAuth2Token -> AccessToken)
-> OAuth2Token
-> ExceptT (Maybe ByteString) (Handler b (AuthManager u e b)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OAuth2Token -> AccessToken
accessToken)
(OAuth2Failure -> Handler b (AuthManager u e b) ())
-> (Text -> Handler b (AuthManager u e b) ())
-> Either OAuth2Failure Text
-> Handler b (AuthManager u e b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
forall b u e.
Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
setFailure ((OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
oauth2Failure OAuth2Settings u i e b
s) OAuth2Stage
SCallback) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
provider) (Either e (AuthFailure e) -> Handler b (AuthManager u e b) ())
-> (OAuth2Failure -> Either e (AuthFailure e))
-> OAuth2Failure
-> Handler b (AuthManager u e b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
AuthFailure e -> Either e (AuthFailure e)
forall a b. b -> Either a b
Right (AuthFailure e -> Either e (AuthFailure e))
-> (OAuth2Failure -> AuthFailure e)
-> OAuth2Failure
-> Either e (AuthFailure e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateFailure -> AuthFailure e
forall e. CreateFailure -> AuthFailure e
Create (CreateFailure -> AuthFailure e)
-> (OAuth2Failure -> CreateFailure)
-> OAuth2Failure
-> AuthFailure e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OAuth2Failure -> CreateFailure
OAuth2Failure)
(OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
oauth2Success OAuth2Settings u i e b
s Provider
provider) Either OAuth2Failure Text
res
oauth2Success
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Provider
-> Text
-> Handler b (AuthManager u e b) ()
oauth2Success :: OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
oauth2Success OAuth2Settings u i e b
s Provider
provider Text
token = do
Text
key <- Text -> Handler b (AuthManager u e b) Text
forall b u e. Text -> Handler b (AuthManager u e b) Text
getActionKey (Text -> Handler b (AuthManager u e b) Text)
-> Text -> Handler b (AuthManager u e b) Text
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
provider
SnapletLens (Snaplet b) SessionManager
store <- (AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
forall u e b.
AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
stateStore'
Text
name <- Handler b (AuthManager u e b) Text
forall b u e. Handler b (AuthManager u e b) Text
getStateName
Maybe Text
act <- SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text))
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ MaybeT (Handler b SessionManager) Text
-> Handler b SessionManager (Maybe Text)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b SessionManager) Text
-> Handler b SessionManager (Maybe Text))
-> MaybeT (Handler b SessionManager) Text
-> Handler b SessionManager (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
Text
act <- Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text)
-> Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text
forall a b. (a -> b) -> a -> b
$ Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession Text
key
Handler b SessionManager () -> MaybeT (Handler b SessionManager) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b SessionManager ()
-> MaybeT (Handler b SessionManager) ())
-> Handler b SessionManager ()
-> MaybeT (Handler b SessionManager) ()
forall a b. (a -> b) -> a -> b
$ Text -> Handler b SessionManager ()
forall b. Text -> Handler b SessionManager ()
deleteFromSession Text
key Handler b SessionManager ()
-> Handler b SessionManager () -> Handler b SessionManager ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b SessionManager ()
forall b. Handler b SessionManager ()
commitSession
Text -> MaybeT (Handler b SessionManager) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
act
SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager () -> Handler b (AuthManager u e b) ())
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_provider") (Provider -> Text
providerName Provider
provider)
Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_token") Text
token
Handler b SessionManager ()
forall b. Handler b SessionManager ()
commitSession
Handler b (AuthManager u e b) ()
-> (Text -> Handler b (AuthManager u e b) ())
-> Maybe Text
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
doOauth2Login OAuth2Settings u i e b
s Provider
provider Text
token) (OAuth2Settings u i e b
-> Provider -> Text -> Text -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b
-> Provider -> Text -> Text -> Handler b (AuthManager u e b) ()
doResume OAuth2Settings u i e b
s Provider
provider Text
token) Maybe Text
act
doOauth2Login
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Provider
-> Text
-> Handler b (AuthManager u e b) ()
doOauth2Login :: OAuth2Settings u i e b
-> Provider -> Text -> Handler b (AuthManager u e b) ()
doOauth2Login OAuth2Settings u i e b
s Provider
provider Text
token = do
Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
Handler b (AuthManager u e b) ()
recoverSession
Handler b (AuthManager u e b) (Maybe u)
forall u b e. UserData u => Handler b (AuthManager u e b) (Maybe u)
currentUser Handler b (AuthManager u e b) (Maybe u)
-> (Maybe u -> Handler b (AuthManager u e b) ())
-> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Handler b (AuthManager u e b) ()
-> (u -> Handler b (AuthManager u e b) ())
-> Maybe u
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler b (AuthManager u e b) ()
proceed (Handler b (AuthManager u e b) ()
-> u -> Handler b (AuthManager u e b) ()
forall a b. a -> b -> a
const (Handler b (AuthManager u e b) ()
-> u -> Handler b (AuthManager u e b) ())
-> Handler b (AuthManager u e b) ()
-> u
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
forall b u e.
Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
setFailure ((OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
oauth2Failure OAuth2Settings u i e b
s) OAuth2Stage
SLogin)
(Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
provider) (Either e (AuthFailure e) -> Handler b (AuthManager u e b) ())
-> Either e (AuthFailure e) -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$
AuthFailure e -> Either e (AuthFailure e)
forall a b. b -> Either a b
Right (AuthFailure e -> Either e (AuthFailure e))
-> AuthFailure e -> Either e (AuthFailure e)
forall a b. (a -> b) -> a -> b
$ CreateFailure -> AuthFailure e
forall e. CreateFailure -> AuthFailure e
Create (CreateFailure -> AuthFailure e) -> CreateFailure -> AuthFailure e
forall a b. (a -> b) -> a -> b
$ OAuth2Failure -> CreateFailure
OAuth2Failure OAuth2Failure
AlreadyLoggedIn)
where
proceed :: Handler b (AuthManager u e b) ()
proceed = do
Either e (Maybe u)
res <- ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
-> Handler b (AuthManager u e b) (Either e (Maybe u))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
-> Handler b (AuthManager u e b) (Either e (Maybe u)))
-> ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
-> Handler b (AuthManager u e b) (Either e (Maybe u))
forall a b. (a -> b) -> a -> b
$ do
Maybe u
usr <- Handler b (AuthManager u e b) (Either e (Maybe u))
-> ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Handler b (AuthManager u e b) (Either e (Maybe u))
-> ExceptT e (Handler b (AuthManager u e b)) (Maybe u))
-> Handler b (AuthManager u e b) (Either e (Maybe u))
-> ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
forall a b. (a -> b) -> a -> b
$ (OAuth2Settings u i e b
-> Text
-> Text
-> Handler b (AuthManager u e b) (Either e (Maybe u))
forall u i e b.
OAuth2Settings u i e b
-> Text
-> Text
-> Handler b (AuthManager u e b) (Either e (Maybe u))
oauth2Login OAuth2Settings u i e b
s) (Provider -> Text
providerName Provider
provider) Text
token
ExceptT e (Handler b (AuthManager u e b)) ()
-> (u -> ExceptT e (Handler b (AuthManager u e b)) ())
-> Maybe u
-> ExceptT e (Handler b (AuthManager u e b)) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExceptT e (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Handler b (AuthManager u e b) ()
-> ExceptT e (Handler b (AuthManager u e b)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) ()
-> ExceptT e (Handler b (AuthManager u e b)) ())
-> (u -> Handler b (AuthManager u e b) ())
-> u
-> ExceptT e (Handler b (AuthManager u e b)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Handler b (AuthManager u e b) ()
forall u b e. UserData u => u -> Handler b (AuthManager u e b) ()
setUser) Maybe u
usr
Maybe u -> ExceptT e (Handler b (AuthManager u e b)) (Maybe u)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe u
usr
(e -> Handler b (AuthManager u e b) ())
-> (Maybe u -> Handler b (AuthManager u e b) ())
-> Either e (Maybe u)
-> Handler b (AuthManager u e b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
forall b u e.
Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
setFailure ((OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
oauth2Failure OAuth2Settings u i e b
s) OAuth2Stage
SLogin)
(Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
provider) (Either e (AuthFailure e) -> Handler b (AuthManager u e b) ())
-> (e -> Either e (AuthFailure e))
-> e
-> Handler b (AuthManager u e b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e (AuthFailure e)
forall a b. a -> Either a b
Left)
(Handler b (AuthManager u e b) ()
-> Maybe u -> Handler b (AuthManager u e b) ()
forall a b. a -> b -> a
const (Handler b (AuthManager u e b) ()
-> Maybe u -> Handler b (AuthManager u e b) ())
-> Handler b (AuthManager u e b) ()
-> Maybe u
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
oauth2LoginDone OAuth2Settings u i e b
s) Either e (Maybe u)
res
isExpiredStamp
:: UTCTime
-> IO Bool
isExpiredStamp :: UTCTime -> IO Bool
isExpiredStamp UTCTime
stamp = do
UTCTime
current <- IO UTCTime
getCurrentTime
let diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
current UTCTime
stamp
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
0 Bool -> Bool -> Bool
|| NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
300
prepareOAuth2Create'
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Provider
-> Text
-> Handler b (AuthManager u e b) (Either (Either e CreateFailure) i)
prepareOAuth2Create' :: OAuth2Settings u i e b
-> Provider
-> Text
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
prepareOAuth2Create' OAuth2Settings u i e b
s Provider
provider Text
token =
(OAuth2Settings u i e b
-> Text -> Text -> Handler b (AuthManager u e b) (Either e i)
forall u i e b.
OAuth2Settings u i e b
-> Text -> Text -> Handler b (AuthManager u e b) (Either e i)
prepareOAuth2Create OAuth2Settings u i e b
s) (Provider -> Text
providerName Provider
provider) Text
token Handler b (AuthManager u e b) (Either e i)
-> (Either e i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i))
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(e
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i))
-> (i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i))
-> Either e i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall u i a b b.
IAuthBackend u i a b =>
a
-> Handler
b (AuthManager u a b) (Either (Either a CreateFailure) b)
checkDuplicate (Either (Either e CreateFailure) i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either e CreateFailure) i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i))
-> (i -> Either (Either e CreateFailure) i)
-> i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Either (Either e CreateFailure) i
forall a b. b -> Either a b
Right)
where
checkDuplicate :: a
-> Handler
b (AuthManager u a b) (Either (Either a CreateFailure) b)
checkDuplicate a
e = do
Bool
isE <- a -> Handler b (AuthManager u a b) Bool
forall u i e b.
IAuthBackend u i e b =>
e -> Handler b (AuthManager u e b) Bool
isDuplicateError a
e
Either (Either a CreateFailure) b
-> Handler
b (AuthManager u a b) (Either (Either a CreateFailure) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either a CreateFailure) b
-> Handler
b (AuthManager u a b) (Either (Either a CreateFailure) b))
-> Either (Either a CreateFailure) b
-> Handler
b (AuthManager u a b) (Either (Either a CreateFailure) b)
forall a b. (a -> b) -> a -> b
$ Either a CreateFailure -> Either (Either a CreateFailure) b
forall a b. a -> Either a b
Left (Either a CreateFailure -> Either (Either a CreateFailure) b)
-> Either a CreateFailure -> Either (Either a CreateFailure) b
forall a b. (a -> b) -> a -> b
$ if Bool
isE then CreateFailure -> Either a CreateFailure
forall a b. b -> Either a b
Right (CreateFailure -> Either a CreateFailure)
-> CreateFailure -> Either a CreateFailure
forall a b. (a -> b) -> a -> b
$ OAuth2Failure -> CreateFailure
OAuth2Failure OAuth2Failure
IdentityInUse else a -> Either a CreateFailure
forall a b. a -> Either a b
Left a
e
doResume
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Provider
-> Text
-> Text
-> Handler b (AuthManager u e b) ()
doResume :: OAuth2Settings u i e b
-> Provider -> Text -> Text -> Handler b (AuthManager u e b) ()
doResume OAuth2Settings u i e b
s Provider
provider Text
token Text
d = do
Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
Handler b (AuthManager u e b) ()
recoverSession
Maybe u
user <- Handler b (AuthManager u e b) (Maybe u)
forall u b e. UserData u => Handler b (AuthManager u e b) (Maybe u)
currentUser
Maybe ByteString
userId <- MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString))
-> MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Handler b (AuthManager u e b) ByteString
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) ByteString
-> MaybeT (Handler b (AuthManager u e b)) ByteString)
-> (u -> Handler b (AuthManager u e b) ByteString)
-> u
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Handler b (AuthManager u e b) ByteString
forall u i e b.
IAuthBackend u i e b =>
u -> Handler b (AuthManager u e b) ByteString
getUserId (u -> MaybeT (Handler b (AuthManager u e b)) ByteString)
-> MaybeT (Handler b (AuthManager u e b)) u
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Handler b (AuthManager u e b) (Maybe u)
-> MaybeT (Handler b (AuthManager u e b)) u
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager u e b) (Maybe u)
-> MaybeT (Handler b (AuthManager u e b)) u)
-> Handler b (AuthManager u e b) (Maybe u)
-> MaybeT (Handler b (AuthManager u e b)) u
forall a b. (a -> b) -> a -> b
$ Maybe u -> Handler b (AuthManager u e b) (Maybe u)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe u
user)
Either (Either e OAuth2ActionFailure) ByteString
res <- ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) ByteString)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) ByteString))
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) ByteString)
forall a b. (a -> b) -> a -> b
$ do
SavedAction
d' <- Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) SavedAction)
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
SavedAction
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) SavedAction)
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
SavedAction)
-> (Either (Either e OAuth2ActionFailure) SavedAction
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) SavedAction))
-> Either (Either e OAuth2ActionFailure) SavedAction
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
SavedAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Either e OAuth2ActionFailure) SavedAction
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) SavedAction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either e OAuth2ActionFailure) SavedAction
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
SavedAction)
-> Either (Either e OAuth2ActionFailure) SavedAction
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
SavedAction
forall a b. (a -> b) -> a -> b
$ Either (Either e OAuth2ActionFailure) SavedAction
-> (SavedAction
-> Either (Either e OAuth2ActionFailure) SavedAction)
-> Maybe SavedAction
-> Either (Either e OAuth2ActionFailure) SavedAction
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either e OAuth2ActionFailure
-> Either (Either e OAuth2ActionFailure) SavedAction
forall a b. a -> Either a b
Left (Either e OAuth2ActionFailure
-> Either (Either e OAuth2ActionFailure) SavedAction)
-> Either e OAuth2ActionFailure
-> Either (Either e OAuth2ActionFailure) SavedAction
forall a b. (a -> b) -> a -> b
$ OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
ActionDecodeError) SavedAction -> Either (Either e OAuth2ActionFailure) SavedAction
forall a b. b -> Either a b
Right (Maybe SavedAction
-> Either (Either e OAuth2ActionFailure) SavedAction)
-> Maybe SavedAction
-> Either (Either e OAuth2ActionFailure) SavedAction
forall a b. (a -> b) -> a -> b
$
((((ByteString, ByteOffset, SavedAction) -> SavedAction)
-> Maybe (ByteString, ByteOffset, SavedAction) -> Maybe SavedAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ByteString, ByteOffset, SavedAction) -> SavedAction)
-> Maybe (ByteString, ByteOffset, SavedAction)
-> Maybe SavedAction)
-> ((ByteString, ByteOffset, SavedAction) -> SavedAction)
-> Maybe (ByteString, ByteOffset, SavedAction)
-> Maybe SavedAction
forall a b. (a -> b) -> a -> b
$ \(ByteString
_, ByteOffset
_, SavedAction
x) -> SavedAction
x) (Maybe (ByteString, ByteOffset, SavedAction) -> Maybe SavedAction)
-> (ByteString -> Maybe (ByteString, ByteOffset, SavedAction))
-> ByteString
-> Maybe SavedAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction)
-> Maybe (ByteString, ByteOffset, SavedAction)
forall a b. Either a b -> Maybe b
hush (Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction)
-> Maybe (ByteString, ByteOffset, SavedAction))
-> (ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction))
-> ByteString
-> Maybe (ByteString, ByteOffset, SavedAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Data.Binary.decodeOrFail (ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction))
-> (ByteString -> ByteString)
-> ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, SavedAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict) (ByteString -> Maybe SavedAction)
-> Maybe ByteString -> Maybe SavedAction
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Either String ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
hush (Either String ByteString -> Maybe ByteString)
-> Either String ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
Data.ByteString.Base64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
d)
Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SavedAction -> Bool
requireUser SavedAction
d' Bool -> Bool -> Bool
&& Maybe u -> Bool
forall a. Maybe a -> Bool
isNothing Maybe u
user) (ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ Either e OAuth2ActionFailure
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
AttachNotLoggedIn)
Maybe ByteString
u <- Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
(Maybe ByteString)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
(Maybe ByteString))
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
(Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Either (Either e OAuth2ActionFailure) (Maybe ByteString)
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either e OAuth2ActionFailure) (Maybe ByteString)
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString)))
-> (Either e (Maybe ByteString)
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> Either e (Maybe ByteString)
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> (Maybe ByteString
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> Either e (Maybe ByteString)
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e OAuth2ActionFailure
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString)
forall a b. a -> Either a b
Left (Either e OAuth2ActionFailure
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString))
-> (e -> Either e OAuth2ActionFailure)
-> e
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e OAuth2ActionFailure
forall a b. a -> Either a b
Left) Maybe ByteString
-> Either (Either e OAuth2ActionFailure) (Maybe ByteString)
forall a b. b -> Either a b
Right (Either e (Maybe ByteString)
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString)))
-> Handler b (AuthManager u e b) (Either e (Maybe ByteString))
-> Handler
b
(AuthManager u e b)
(Either (Either e OAuth2ActionFailure) (Maybe ByteString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(OAuth2Settings u i e b
-> Text
-> Text
-> Handler b (AuthManager u e b) (Either e (Maybe ByteString))
forall u i e b.
OAuth2Settings u i e b
-> Text
-> Text
-> Handler b (AuthManager u e b) (Either e (Maybe ByteString))
oauth2Check OAuth2Settings u i e b
s) (Provider -> Text
providerName Provider
provider) Text
token
Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString
userId Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= SavedAction -> Maybe ByteString
actionUser SavedAction
d') (ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$
Either e OAuth2ActionFailure
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
ActionUserMismatch)
case SavedAction -> Bool
requireUser SavedAction
d' of
Bool
True -> Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ByteString
userId) (Maybe ByteString -> Bool)
-> (ByteString -> Maybe ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) Maybe ByteString
u) (ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$
Either e OAuth2ActionFailure
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
ActionUserMismatch)
Bool
False -> Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
u) (ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ Either e OAuth2ActionFailure
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
AlreadyAttached)
Bool
expired <- IO Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
Bool)
-> IO Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) Bool
forall a b. (a -> b) -> a -> b
$ UTCTime -> IO Bool
isExpiredStamp (SavedAction -> UTCTime
actionStamp SavedAction
d')
Bool
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
expired (ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ Either e OAuth2ActionFailure
-> ExceptT
(Either e OAuth2ActionFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (OAuth2ActionFailure -> Either e OAuth2ActionFailure
forall a b. b -> Either a b
Right OAuth2ActionFailure
ActionTimeout)
ByteString
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString)
-> ByteString
-> ExceptT
(Either e OAuth2ActionFailure)
(Handler b (AuthManager u e b))
ByteString
forall a b. (a -> b) -> a -> b
$ SavedAction -> ByteString
savedAction SavedAction
d'
(Either e OAuth2ActionFailure -> Handler b (AuthManager u e b) ())
-> (ByteString -> Handler b (AuthManager u e b) ())
-> Either (Either e OAuth2ActionFailure) ByteString
-> Handler b (AuthManager u e b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
forall b u e.
Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
setFailure ((OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
oauth2Failure OAuth2Settings u i e b
s) OAuth2Stage
SAction)
(Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Text
providerName Provider
provider) (Either e (AuthFailure e) -> Handler b (AuthManager u e b) ())
-> (Either e OAuth2ActionFailure -> Either e (AuthFailure e))
-> Either e OAuth2ActionFailure
-> Handler b (AuthManager u e b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OAuth2ActionFailure -> AuthFailure e)
-> Either e OAuth2ActionFailure -> Either e (AuthFailure e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuth2ActionFailure -> AuthFailure e
forall e. OAuth2ActionFailure -> AuthFailure e
Action)
((OAuth2Settings u i e b
-> Text -> Text -> ByteString -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> Text -> Text -> ByteString -> Handler b (AuthManager u e b) ()
resumeAction OAuth2Settings u i e b
s) (Provider -> Text
providerName Provider
provider) Text
token) Either (Either e OAuth2ActionFailure) ByteString
res
oauth2CreateAccount
:: IAuthBackend u i e b
=> OAuth2Settings u i e b
-> Handler b (AuthManager u e b) ()
oauth2CreateAccount :: OAuth2Settings u i e b -> Handler b (AuthManager u e b) ()
oauth2CreateAccount OAuth2Settings u i e b
s = do
SnapletLens (Snaplet b) SessionManager
store <- (AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
forall u e b.
AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
stateStore'
HashMap Text Provider
provs <- (AuthManager u e b -> HashMap Text Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> HashMap Text Provider
forall u e b. AuthManager u e b -> HashMap Text Provider
providers
Maybe Text
usrName <- ((Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8') (ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe ByteString -> Maybe Text)
-> Handler b (AuthManager u e b) (Maybe ByteString)
-> Handler b (AuthManager u e b) (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(ByteString -> Handler b (AuthManager u e b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam (ByteString -> Handler b (AuthManager u e b) (Maybe ByteString))
-> Handler b (AuthManager u e b) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ByteString
"_new" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> Handler b (AuthManager u e b) ByteString
-> Handler b (AuthManager u e b) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthManager u e b -> ByteString)
-> Handler b (AuthManager u e b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> ByteString
forall u e b. AuthManager u e b -> ByteString
userField)
Text
name <- Handler b (AuthManager u e b) Text
forall b u e. Handler b (AuthManager u e b) Text
getStateName
Maybe Provider
provider <- ((Text -> HashMap Text Provider -> Maybe Provider)
-> HashMap Text Provider -> Text -> Maybe Provider
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> HashMap Text Provider -> Maybe Provider
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup HashMap Text Provider
provs (Text -> Maybe Provider) -> Maybe Text -> Maybe Provider
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Text -> Maybe Provider)
-> Handler b (AuthManager u e b) (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Provider)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text))
-> Handler b SessionManager (Maybe Text)
-> Handler b (AuthManager u e b) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_provider"))
Either (Either e CreateFailure) (i, Text)
user <- ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text)))
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
forall a b. (a -> b) -> a -> b
$ do
Maybe u
u <- Handler b (AuthManager u e b) (Maybe u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (Maybe u)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (Maybe u))
-> Handler b (AuthManager u e b) (Maybe u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (Maybe u)
forall a b. (a -> b) -> a -> b
$ Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
Handler b (AuthManager u e b) ()
recoverSession Handler b (AuthManager u e b) ()
-> Handler b (AuthManager u e b) (Maybe u)
-> Handler b (AuthManager u e b) (Maybe u)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b (AuthManager u e b) (Maybe u)
forall u b e. UserData u => Handler b (AuthManager u e b) (Maybe u)
currentUser
Bool
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe u -> Bool
forall a. Maybe a -> Bool
isJust Maybe u
u) (ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ())
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ Either e CreateFailure
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CreateFailure -> Either e CreateFailure
forall a b. b -> Either a b
Right (CreateFailure -> Either e CreateFailure)
-> CreateFailure -> Either e CreateFailure
forall a b. (a -> b) -> a -> b
$ OAuth2Failure -> CreateFailure
OAuth2Failure OAuth2Failure
AlreadyUser)
Text
userName <- Either (Either e CreateFailure) Text
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) Text
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither (Either (Either e CreateFailure) Text
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) Text)
-> Either (Either e CreateFailure) Text
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) Text
forall a b. (a -> b) -> a -> b
$ Either e CreateFailure
-> Maybe Text -> Either (Either e CreateFailure) Text
forall a b. a -> Maybe b -> Either a b
note (CreateFailure -> Either e CreateFailure
forall a b. b -> Either a b
Right CreateFailure
MissingName) Maybe Text
usrName
(Provider, Text)
res <- ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
-> ((Provider, Text)
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text))
-> Maybe (Provider, Text)
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either e CreateFailure
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Either e CreateFailure
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text))
-> Either e CreateFailure
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
forall a b. (a -> b) -> a -> b
$ CreateFailure -> Either e CreateFailure
forall a b. b -> Either a b
Right (CreateFailure -> Either e CreateFailure)
-> CreateFailure -> Either e CreateFailure
forall a b. (a -> b) -> a -> b
$ OAuth2Failure -> CreateFailure
OAuth2Failure OAuth2Failure
NoStoredToken) (Provider, Text)
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Provider, Text)
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text))
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Maybe (Provider, Text))
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Provider, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Handler b (AuthManager u e b) (Maybe (Provider, Text))
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Maybe (Provider, Text))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Maybe (Provider, Text))
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Maybe (Provider, Text)))
-> Handler b (AuthManager u e b) (Maybe (Provider, Text))
-> ExceptT
(Either e CreateFailure)
(Handler b (AuthManager u e b))
(Maybe (Provider, Text))
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager (Maybe (Provider, Text))
-> Handler b (AuthManager u e b) (Maybe (Provider, Text))
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager (Maybe (Provider, Text))
-> Handler b (AuthManager u e b) (Maybe (Provider, Text)))
-> Handler b SessionManager (Maybe (Provider, Text))
-> Handler b (AuthManager u e b) (Maybe (Provider, Text))
forall a b. (a -> b) -> a -> b
$ MaybeT (Handler b SessionManager) (Provider, Text)
-> Handler b SessionManager (Maybe (Provider, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b SessionManager) (Provider, Text)
-> Handler b SessionManager (Maybe (Provider, Text)))
-> MaybeT (Handler b SessionManager) (Provider, Text)
-> Handler b SessionManager (Maybe (Provider, Text))
forall a b. (a -> b) -> a -> b
$ do
Provider
provider' <- Handler b SessionManager (Maybe Provider)
-> MaybeT (Handler b SessionManager) Provider
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b SessionManager (Maybe Provider)
-> MaybeT (Handler b SessionManager) Provider)
-> Handler b SessionManager (Maybe Provider)
-> MaybeT (Handler b SessionManager) Provider
forall a b. (a -> b) -> a -> b
$ Maybe Provider -> Handler b SessionManager (Maybe Provider)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Provider
provider
Text
token <- Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text)
-> Handler b SessionManager (Maybe Text)
-> MaybeT (Handler b SessionManager) Text
forall a b. (a -> b) -> a -> b
$ Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_token")
(Provider, Text)
-> MaybeT (Handler b SessionManager) (Provider, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Provider
provider', Text
token))
Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text))
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
forall a b. (a -> b) -> a -> b
$ (i -> (i, Text))
-> Either (Either e CreateFailure) i
-> Either (Either e CreateFailure) (i, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Text
userName) (Either (Either e CreateFailure) i
-> Either (Either e CreateFailure) (i, Text))
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) (i, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OAuth2Settings u i e b
-> Provider
-> Text
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
forall u i e b.
IAuthBackend u i e b =>
OAuth2Settings u i e b
-> Provider
-> Text
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) i)
prepareOAuth2Create' OAuth2Settings u i e b
s ((Provider, Text) -> Provider
forall a b. (a, b) -> a
fst (Provider, Text)
res) ((Provider, Text) -> Text
forall a b. (a, b) -> b
snd (Provider, Text)
res)
Either (Either e CreateFailure) u
res <- ExceptT (Either e CreateFailure) (Handler b (AuthManager u e b)) u
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Either e CreateFailure) (Handler b (AuthManager u e b)) u
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u))
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) u
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u)
forall a b. (a -> b) -> a -> b
$ do
(i
i, Text
userName) <- Either (Either e CreateFailure) (i, Text)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) (i, Text)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither Either (Either e CreateFailure) (i, Text)
user
u
usr <- Handler b (AuthManager u e b) (Either (Either e CreateFailure) u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) u
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Handler b (AuthManager u e b) (Either (Either e CreateFailure) u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) u)
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u)
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) u
forall a b. (a -> b) -> a -> b
$ Text
-> i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u)
forall u i e b.
IAuthBackend u i e b =>
Text
-> i
-> Handler
b (AuthManager u e b) (Either (Either e CreateFailure) u)
create Text
userName i
i
Handler b (AuthManager u e b) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ())
-> Handler b (AuthManager u e b) ()
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) ()
forall a b. (a -> b) -> a -> b
$ u -> Handler b (AuthManager u e b) ()
forall u b e. UserData u => u -> Handler b (AuthManager u e b) ()
setUser u
usr
u
-> ExceptT
(Either e CreateFailure) (Handler b (AuthManager u e b)) u
forall (m :: * -> *) a. Monad m => a -> m a
return u
usr
case (Either (Either e CreateFailure) (i, Text)
user, Either (Either e CreateFailure) u
res) of
(Right (i
i,Text
_), Left Either e CreateFailure
_) -> i -> Handler b (AuthManager u e b) ()
forall u i e b.
IAuthBackend u i e b =>
i -> Handler b (AuthManager u e b) ()
cancelPrepare i
i
(Either (Either e CreateFailure) (i, Text),
Either (Either e CreateFailure) u)
_ -> () -> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Either e CreateFailure -> Handler b (AuthManager u e b) ())
-> (u -> Handler b (AuthManager u e b) ())
-> Either (Either e CreateFailure) u
-> Handler b (AuthManager u e b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
forall b u e.
Handler b (AuthManager u e b) ()
-> Maybe Text
-> Either e (AuthFailure e)
-> Handler b (AuthManager u e b) ()
setFailure ((OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b
-> OAuth2Stage -> Handler b (AuthManager u e b) ()
oauth2Failure OAuth2Settings u i e b
s) OAuth2Stage
SCreate) (Provider -> Text
providerName (Provider -> Text) -> Maybe Provider -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Provider
provider) (Either e (AuthFailure e) -> Handler b (AuthManager u e b) ())
-> (Either e CreateFailure -> Either e (AuthFailure e))
-> Either e CreateFailure
-> Handler b (AuthManager u e b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CreateFailure -> AuthFailure e)
-> Either e CreateFailure -> Either e (AuthFailure e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CreateFailure -> AuthFailure e
forall e. CreateFailure -> AuthFailure e
Create)
(OAuth2Settings u i e b -> u -> Handler b (AuthManager u e b) ()
forall u i e b.
OAuth2Settings u i e b -> u -> Handler b (AuthManager u e b) ()
oauth2AccountCreated OAuth2Settings u i e b
s) Either (Either e CreateFailure) u
res
getActionKey
:: Text
-> Handler b (AuthManager u e b) Text
getActionKey :: Text -> Handler b (AuthManager u e b) Text
getActionKey Text
p = do
Text
path <- Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auth" Text -> Text
forall a. a -> a
id (Maybe Text -> Text)
-> (ByteString -> Maybe Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Text)
-> Handler b (AuthManager u e b) ByteString
-> Handler b (AuthManager u e b) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager u e b) ByteString
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v ByteString
getSnapletRootURL
Text
name <- Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auth" Text -> Text
forall a. a -> a
id (Maybe Text -> Text)
-> Handler b (AuthManager u e b) (Maybe Text)
-> Handler b (AuthManager u e b) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager u e b) (Maybe Text)
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v (Maybe Text)
getSnapletName
Text -> Handler b (AuthManager u e b) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Handler b (AuthManager u e b) Text)
-> Text -> Handler b (AuthManager u e b) Text
forall a b. (a -> b) -> a -> b
$ Text
"__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_action_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p
saveAction
:: (IAuthBackend u i e b, Binary a)
=> Bool
-> Text
-> a
-> Handler b (AuthManager u e b) ()
saveAction :: Bool -> Text -> a -> Handler b (AuthManager u e b) ()
saveAction Bool
require Text
provider a
a = do
HashMap Text Provider
provs <- (AuthManager u e b -> HashMap Text Provider)
-> Handler b (AuthManager u e b) (HashMap Text Provider)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> HashMap Text Provider
forall u e b. AuthManager u e b -> HashMap Text Provider
providers
Bool -> Handler b (AuthManager u e b) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Handler b (AuthManager u e b) ())
-> Bool -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ Text
provider Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (HashMap Text Provider -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text Provider
provs)
let d :: ByteString
d = a -> ByteString
forall a. Binary a => a -> ByteString
Data.Binary.encode a
a
Text
key <- Text -> Handler b (AuthManager u e b) Text
forall b u e. Text -> Handler b (AuthManager u e b) Text
getActionKey Text
provider
SnapletLens (Snaplet b) SessionManager
store <- (AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager))
-> (AuthManager u e b -> SnapletLens (Snaplet b) SessionManager)
-> Handler
b (AuthManager u e b) (SnapletLens (Snaplet b) SessionManager)
forall a b. (a -> b) -> a -> b
$ AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
forall u e b.
AuthManager u e b -> SnapletLens (Snaplet b) SessionManager
stateStore'
UTCTime
stamp <- IO UTCTime -> Handler b (AuthManager u e b) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Handler b (AuthManager u e b) UTCTime)
-> IO UTCTime -> Handler b (AuthManager u e b) UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
Maybe ByteString
i <- MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString))
-> MaybeT (Handler b (AuthManager u e b)) ByteString
-> Handler b (AuthManager u e b) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Handler b (AuthManager u e b) ByteString
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) ByteString
-> MaybeT (Handler b (AuthManager u e b)) ByteString)
-> (u -> Handler b (AuthManager u e b) ByteString)
-> u
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Handler b (AuthManager u e b) ByteString
forall u i e b.
IAuthBackend u i e b =>
u -> Handler b (AuthManager u e b) ByteString
getUserId (u -> MaybeT (Handler b (AuthManager u e b)) ByteString)
-> MaybeT (Handler b (AuthManager u e b)) u
-> MaybeT (Handler b (AuthManager u e b)) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handler b (AuthManager u e b) (Maybe u)
-> MaybeT (Handler b (AuthManager u e b)) u
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT Handler b (AuthManager u e b) (Maybe u)
forall u b e. UserData u => Handler b (AuthManager u e b) (Maybe u)
currentUser
let payload :: SavedAction
payload = SavedAction :: Text
-> UTCTime -> Maybe ByteString -> Bool -> ByteString -> SavedAction
SavedAction {
actionProvider :: Text
actionProvider = Text
provider
, actionStamp :: UTCTime
actionStamp = UTCTime
stamp
, actionUser :: Maybe ByteString
actionUser = Maybe ByteString
i
, requireUser :: Bool
requireUser = Bool
require
, savedAction :: ByteString
savedAction = ByteString -> ByteString
toStrict ByteString
d
}
let d' :: Text
d' = ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Data.ByteString.Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (SavedAction -> ByteString) -> SavedAction -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedAction -> ByteString
forall a. Binary a => a -> ByteString
Data.Binary.encode (SavedAction -> ByteString) -> SavedAction -> ByteString
forall a b. (a -> b) -> a -> b
$ SavedAction
payload
SnapletLens (Snaplet b) SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) SessionManager
store (Handler b SessionManager () -> Handler b (AuthManager u e b) ())
-> Handler b SessionManager () -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession Text
key Text
d'
Handler b SessionManager ()
forall b. Handler b SessionManager ()
commitSession