{-# 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"
  -- TODO: use discovery
  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
  -- Generate a state token and store it in SessionManager
  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
    -- Get the user id from provider
    (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
>>=
    -- TODO: catch?
      (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
>=>
      -- TODO: get user id (sub) from idToken in token, if
      -- available. Requires JWT handling.
       (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

-- User has successfully completed OAuth2 login.  Get the stored
-- intended action and perform it.
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
  -- When there's no user defined action stored, treat this as a
  -- regular login
  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
  -- Sanity check: See if the user is already logged in.
  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

-- Check that stored action is not too old and that user matches
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
    -- Compare current user with action's stored user
    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
      -- Compare current user with identity owner
      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)
      -- Ensure that the identity is not yet used
      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

-- User has successfully signed in via oauth2 and the provider/token
-- did not match with an existing user.  This is the endpoint for
-- requesting account creation afterwards.
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
    -- Sanity check: See if the user is already logged in.
    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)
    -- Get userName
    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
    -- Get the token and provider from session store
    (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