haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

It all compiles

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-18 15:04:45 +02:00
parent aed10fc84a
commit 8e265f6ebc
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
13 changed files with 228 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
yesod-auth-oauth/Yesod/Auth/OAuth.hs
View File

@ -1,5 +1,8 @@
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
@ -14,6 +17,7 @@ import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Exception.Lifted
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text)
@ -35,26 +39,37 @@ instance Exception YesodOAuthException
oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"]
authOAuth :: YesodAuth m
authOAuth :: forall master. YesodAuth master
=> OAuth -- ^ 'OAuth' data-type for signing.
-> (Credential -> IO (Creds m)) -- ^ How to extract ident.
-> AuthPlugin m
-> (Credential -> IO (Creds master)) -- ^ How to extract ident.
-> AuthPlugin master
authOAuth oauth mkCreds = AuthPlugin name dispatch login
where
name = T.pack $ oauthServerName oauth
url = PluginR name []
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
oauthSessionName :: Text
oauthSessionName = "__oauth_token_secret"
dispatch
:: ( MonadSubHandler m
, master ~ HandlerSite m
, Auth ~ SubHandlerSite m
, MonadUnliftIO m
)
=> Text
-> [Text]
-> m TypedContent
dispatch "GET" ["forward"] = do
render <- lift getUrlRender
render <- getUrlRender
tm <- getRouteToParent
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
master <- lift getYesod
tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
manager <- authHttpManager
tok <- getTemporaryCredential oauth' manager
setSession oauthSessionName $ lookupTokenSecret tok
redirect $ authorizeUrl oauth' tok
dispatch "GET" [] = lift $ do
dispatch "GET" [] = do
Just tokSec <- lookupSession oauthSessionName
deleteSession oauthSessionName
reqTok <-
@ -72,8 +87,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
, ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)
]
master <- getYesod
accTok <- getAccessToken oauth reqTok (authHttpManager master)
manager <- authHttpManager
accTok <- getAccessToken oauth reqTok manager
creds <- liftIO $ mkCreds accTok
setCredsRedirect creds
dispatch _ _ = notFound

1
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -29,6 +29,7 @@ library
, yesod-form >= 1.4 && < 1.5
, transformers >= 0.2.2 && < 0.6
, lifted-base >= 0.2 && < 0.3
, unliftio-core
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

140
yesod-auth/Yesod/Auth.hs
View File

@ -39,6 +39,7 @@ module Yesod.Auth
-- * Exception
, AuthException (..)
-- * Helper
, MonadAuthHandler
, AuthHandler
-- * Internal
, credsKey
@ -49,8 +50,7 @@ module Yesod.Auth
import Control.Monad (when)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.IO.Unlift (withRunInIO)
import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO)
import Yesod.Auth.Routes
import Data.Aeson hiding (json)
@ -78,7 +78,8 @@ import Control.Monad (void)
type AuthRoute = Route Auth
type AuthHandler master a = forall m. (MonadSubHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m) => m a
type MonadAuthHandler master m = (MonadSubHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
type Method = Text
type Piece = Text
@ -192,8 +193,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager\"@ here.
authHttpManager :: master -> IO Manager
authHttpManager _ = getGlobalManager
authHttpManager :: AuthHandler master Manager
authHttpManager = liftIO getGlobalManager
-- | Called on a successful login. By default, calls
-- @addMessageI "success" NowLoggedIn@.
@ -232,13 +233,14 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
-- This is an experimental API that is not broadly used throughout the yesod-auth code base
runHttpRequest :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth)
=> Request
-> (Response BodyReader -> ReaderT (SubsiteData Auth master) (HandlerFor master) a)
-> m a
runHttpRequest
:: MonadAuthHandler master m
=> Request
-> (Response BodyReader -> m a)
-> m a
runHttpRequest req inner = do
man <- getYesod >>= liftIO . authHttpManager
lift $ withRunInIO $ \run -> withResponse req man $ run . inner
man <- authHttpManager
withRunInIO $ \run -> withResponse req man $ run . inner
{-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
@ -268,7 +270,8 @@ defaultMaybeAuthId = runMaybeT $ do
cachedAuth
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthId master -> AuthHandler master (Maybe (AuthEntity master))
=> AuthId master
-> AuthHandler master (Maybe (AuthEntity master))
cachedAuth
= fmap unCachedMaybeAuth
. cached
@ -285,25 +288,25 @@ cachedAuth
defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do
tp <- getRouteToParent
liftHandler $ authLayout $ do
authLayout $ do
setTitleI Msg.LoginTitle
master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master)
loginErrorMessageI :: (YesodAuth (HandlerSite m), MonadSubHandler m)
=> Route (SubHandlerSite m)
-> AuthMessage
-> m TypedContent
loginErrorMessageI
:: Route Auth
-> AuthMessage
-> AuthHandler master TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
liftHandler $ loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI :: (YesodAuth master, RenderMessage master AuthMessage)
=> Route master
-> AuthMessage
-> AuthHandler master TypedContent
loginErrorMessageMasterI
:: Route master
-> AuthMessage
-> AuthHandler master TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
@ -316,19 +319,22 @@ loginErrorMessage :: YesodAuth master
-> AuthHandler master TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth)
=> Text
-> m Html
-> m TypedContent
messageJson401
:: MonadAuthHandler master m
=> Text
-> m Html
-> m TypedContent
messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent
messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent
messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus :: Status
-> Text
-> HandlerFor master Html
-> HandlerFor master TypedContent
messageJsonStatus
:: MonadAuthHandler master m
=> Status
-> Text
-> m Html
-> m TypedContent
messageJsonStatus status msg html = selectRep $ do
provideRep html
provideRep $ do
@ -340,9 +346,9 @@ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect :: YesodAuth master
=> Creds master -- ^ new credentials
-> HandlerFor master TypedContent
setCredsRedirect
:: Creds master -- ^ new credentials
-> AuthHandler master TypedContent
setCredsRedirect creds = do
y <- getYesod
auth <- authenticate creds
@ -381,10 +387,9 @@ setCredsRedirect creds = do
return $ renderAuthMessage master langs msg
-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done
setCreds :: Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials
-> HandlerFor master ()
-> AuthHandler master ()
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
@ -394,10 +399,11 @@ setCreds doRedirects creds =
_ -> return ()
-- | same as defaultLayoutJson, but uses authLayout
authLayoutJson :: (YesodAuth site, ToJSON j)
=> WidgetFor site () -- ^ HTML
-> HandlerFor site j -- ^ JSON
-> HandlerFor site TypedContent
authLayoutJson
:: (ToJSON j, MonadAuthHandler master m)
=> WidgetFor master () -- ^ HTML
-> m j -- ^ JSON
-> m TypedContent
authLayoutJson w json = selectRep $ do
provideRep $ authLayout w
provideRep $ fmap toJSON json
@ -405,18 +411,17 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session.
--
-- Since 1.1.7
clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> m ()
clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> AuthHandler master ()
clearCreds doRedirects = do
y <- getYesod
liftHandler onLogout
onLogout
deleteSession credsKey
when doRedirects $ do
redirectUltDest $ logoutDest y
getCheckR :: AuthHandler master TypedContent
getCheckR = liftHandler $ do
getCheckR = do
creds <- maybeAuthId
authLayoutJson (do
setTitle "Authentication Status"
@ -437,7 +442,7 @@ $nothing
]
setUltDestReferer' :: AuthHandler master ()
setUltDestReferer' = liftHandler $ do
setUltDestReferer' = do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
@ -471,17 +476,16 @@ maybeAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => HandlerFor master (Maybe (Entity val))
maybeAuth = runMaybeT $ do
(aid, ae) <- MaybeT maybeAuthPair
return $ Entity aid ae
) => AuthHandler master (Maybe (Entity val))
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
-- Persistent database.
--
-- Since 1.4.0
maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerFor master (Maybe (AuthId master, AuthEntity master))
maybeAuthPair
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId
ae <- MaybeT $ cachedAuth aid
@ -512,9 +516,8 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: AuthId master -> HandlerFor master (Maybe (AuthEntity master))
getAuthEntity :: AuthId master -> AuthHandler master (Maybe (AuthEntity master))
#if MIN_VERSION_persistent(2,5,0)
default getAuthEntity
:: ( YesodPersistBackend master ~ backend
, PersistRecordBackend (AuthEntity master) backend
@ -522,16 +525,6 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
, PersistStore backend
)
=> AuthId master -> HandlerFor master (Maybe (AuthEntity master))
#else
default getAuthEntity
:: ( YesodPersistBackend master
~ PersistEntityBackend (AuthEntity master)
, Key (AuthEntity master) ~ AuthId master
, PersistStore (YesodPersistBackend master)
, PersistEntity (AuthEntity master)
)
=> AuthId master -> HandlerFor master (Maybe (AuthEntity master))
#endif
getAuthEntity = runDB . get
@ -542,7 +535,7 @@ type instance KeyEntity (Key x) = x
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- Since 1.1.0
requireAuthId :: YesodAuth master => HandlerFor master (AuthId master)
requireAuthId :: AuthHandler master (AuthId master)
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
@ -554,23 +547,26 @@ requireAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => HandlerFor master (Entity val)
) => AuthHandler master (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
--
-- Since 1.4.0
requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerFor master (AuthId master, AuthEntity master)
requireAuthPair
:: ( YesodAuthPersist master
, Typeable (AuthEntity master)
)
=> AuthHandler master (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: YesodAuth master => HandlerFor master a
handleAuthLack :: AuthHandler master a
handleAuthLack = do
aj <- acceptsJson
if aj then notAuthenticated else redirectLogin
redirectLogin :: YesodAuth master => HandlerFor master a
redirectLogin :: AuthHandler master a
redirectLogin = do
y <- getYesod
when (redirectToCurrent y) setUltDestCurrent
@ -586,7 +582,7 @@ data AuthException = InvalidFacebookResponse
instance Exception AuthException
-- FIXME HandlerSite m ~ SubHandlerSite m should be unnecessary
instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m) => YesodSubDispatch Auth m where
instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m, MonadUnliftIO m) => YesodSubDispatch Auth m where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html

12
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -70,7 +70,6 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
master <- getYesod
audience <-
case bisAudience of
Just a -> return a
@ -78,13 +77,14 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
r <- getUrlRender
tm <- getRouteToParent
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
memail <- liftHandler $ checkAssertion audience assertion (authHttpManager master)
manager <- authHttpManager
memail <- liftResourceT $ checkAssertion audience assertion manager
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent
liftHandler $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> liftHandler $ setCredsRedirect Creds
loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
@ -117,7 +117,7 @@ $newline never
createOnClickOverride :: BrowserIdSettings
-> (Route Auth -> Route master)
-> Maybe (Route master)
-> WidgetT master IO Text
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
unless bisLazyLoad $ addScriptRemote browserIdJs
onclick <- newIdent
@ -166,5 +166,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
-- name.
createOnClick :: BrowserIdSettings
-> (Route Auth -> Route master)
-> WidgetT master IO Text
-> WidgetFor master Text
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

3
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
-- | Provides a dummy authentication module that simply lets a user specify
-- his/her identifier. This is not intended for real world use, just for
-- testing.
@ -16,7 +17,7 @@ authDummy :: YesodAuth m => AuthPlugin m
authDummy =
AuthPlugin "dummy" dispatch login
where
dispatch "POST" [] = liftHandler $ do
dispatch "POST" [] = do
ident <- runInputPost $ ireq textField "ident"
setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound

133
yesod-auth/Yesod/Auth/Email.hs
View File

@ -186,29 +186,29 @@ class ( YesodAuth site
-- has not yet been verified.
--
-- @since 1.1.0
addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)
-- | Send an email to the given address to verify ownership.
--
-- @since 1.1.0
sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
-- | Get the verification key for the given email ID.
--
-- @since 1.1.0
getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey)
-- | Set the verification key for the given email ID.
--
-- @since 1.1.0
setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()
-- | Hash and salt a password
--
-- Default: 'saltPass'.
--
-- @since 1.4.20
hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
hashAndSaltPassword = liftIO . saltPass
-- | Verify a password matches the stored password for the given account.
@ -216,7 +216,7 @@ class ( YesodAuth site
-- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
--
-- @since 1.4.20
verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
verifyPassword plain salted = return $ isValidPass plain salted
-- | Verify the email address on the given account.
@ -228,28 +228,28 @@ class ( YesodAuth site
-- See <https://github.com/yesodweb/yesod/issues/1222>.
--
-- @since 1.1.0
verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
-- | Get the salted password for the given account.
--
-- @since 1.1.0
getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass)
-- | Set the salted password for the given account.
--
-- @since 1.1.0
setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
setPassword :: AuthId site -> SaltedPass -> AuthHandler site ()
-- | Get the credentials for the given @Identifier@, which may be either an
-- email address or some other identification (e.g., username).
--
-- @since 1.2.0
getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))
getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site))
-- | Get the email address for the given email ID.
--
-- @since 1.1.0
getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
-- | Generate a random alphanumeric string.
--
@ -268,7 +268,7 @@ class ( YesodAuth site
-- Default: if the user logged in via an email link do not require a password.
--
-- @since 1.2.1
needOldPassword :: AuthId site -> HandlerT site IO Bool
needOldPassword :: AuthId site -> AuthHandler site Bool
needOldPassword aid' = do
mkey <- lookupSession loginLinkKey
case mkey >>= readMay . TS.unpack of
@ -280,7 +280,7 @@ class ( YesodAuth site
-- | Check that the given plain-text password meets minimum security standards.
--
-- Default: password is at least three characters.
checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ())
checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ())
checkPasswordSecurity _ x
| TS.length x >= 3 = return $ Right ()
| otherwise = return $ Left "Password must be at least three characters"
@ -288,7 +288,7 @@ class ( YesodAuth site
-- | Response after sending a confirmation email.
--
-- @since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
confirmationEmailSentResponse identifier = do
mr <- getMessageRender
selectRep $ do
@ -314,7 +314,7 @@ class ( YesodAuth site
-- Default: 'defaultEmailLoginHandler'.
--
-- @since 1.4.17
emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()
emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
emailLoginHandler = defaultEmailLoginHandler
@ -377,9 +377,12 @@ getRegisterR = registerHandler
-- | Default implementation of 'emailLoginHandler'.
--
-- @since 1.4.17
defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
defaultEmailLoginHandler
:: YesodAuthEmail master
=> (Route Auth -> Route master)
-> WidgetFor master ()
defaultEmailLoginHandler toParent = do
(widget, enctype) <- liftWidgetT $ generateFormPost loginForm
(widget, enctype) <- generateFormPost loginForm
[whamlet|
<form method="post" action="@{toParent loginR}", enctype=#{enctype}>
@ -439,9 +442,9 @@ defaultEmailLoginHandler toParent = do
-- @since 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do
(widget, enctype) <- lift $ generateFormPost registrationForm
(widget, enctype) <- generateFormPost registrationForm
toParentRoute <- getRouteToParent
lift $ authLayout $ do
authLayout $ do
setTitleI Msg.RegisterLong
[whamlet|
<p>_{Msg.EnterEmail}
@ -482,12 +485,12 @@ registerHelper :: YesodAuthEmail master
-> Route Auth
-> AuthHandler master TypedContent
registerHelper allowUsername dest = do
y <- lift getYesod
y <- getYesod
checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
pidentifier <- lookupPostParam "email"
midentifier <- case pidentifier of
Nothing -> do
(jidentifier :: Result Value) <- lift parseCheckJsonBody
(jidentifier :: Result Value) <- parseCheckJsonBody
case jidentifier of
Error _ -> return Nothing
Success val -> return $ parseMaybe parseEmail val
@ -502,28 +505,29 @@ registerHelper allowUsername dest = do
case eidentifier of
Left route -> loginErrorMessageI dest route
Right identifier -> do
mecreds <- lift $ getEmailCreds identifier
mecreds <- getEmailCreds identifier
registerCreds <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
lid <- addUnverified identifier key
return $ Just (lid, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do
render <- getUrlRender
let verUrl = render $ verifyR (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
tp <- getRouteToParent
let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
sendVerifyEmail email verKey verUrl
confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
postRegisterR = registerHelper False registerR
@ -536,9 +540,9 @@ getForgotPasswordR = forgotPasswordHandler
-- @since 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler = do
(widget, enctype) <- lift $ generateFormPost forgotPasswordForm
(widget, enctype) <- generateFormPost forgotPasswordForm
toParent <- getRouteToParent
lift $ authLayout $ do
authLayout $ do
setTitleI Msg.PasswordResetTitle
[whamlet|
<p>_{Msg.PasswordResetPrompt}
@ -577,27 +581,28 @@ getVerifyR :: YesodAuthEmail site
-> Text
-> AuthHandler site TypedContent
getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid
mr <- lift getMessageRender
realKey <- getVerifyKey lid
memail <- getEmail lid
mr <- getMessageRender
case (realKey == Just key, memail) of
(True, Just email) -> do
muid <- lift $ verifyAccount lid
muid <- verifyAccount lid
case muid of
Nothing -> invalidKey mr
Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setLoginLinkKey uid
setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
setLoginLinkKey uid
let msgAv = Msg.AddressVerified
selectRep $ do
provideRep $ do
lift $ addMessageI "success" msgAv
fmap asHtml $ redirect setpassR
addMessageI "success" msgAv
tp <- getRouteToParent
fmap asHtml $ redirect $ tp setpassR
provideJsonMessage $ mr msgAv
_ -> invalidKey mr
where
msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do
setTitleI msgIk
[whamlet|
$newline never
@ -614,14 +619,14 @@ parseCreds = withObject "creds" (\obj -> do
postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR = do
result <- lift $ runInputPostResult $ (,)
result <- runInputPostResult $ (,)
<$> ireq textField "email"
<*> ireq textField "password"
midentifier <- case result of
FormSuccess (iden, pass) -> return $ Just (iden, pass)
_ -> do
(creds :: Result Value) <- lift parseCheckJsonBody
(creds :: Result Value) <- parseCheckJsonBody
case creds of
Error _ -> return Nothing
Success val -> return $ parseMaybe parseCreds val
@ -629,18 +634,18 @@ postLoginR = do
case midentifier of
Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
Just (identifier, pass) -> do
mecreds <- lift $ getEmailCreds identifier
mecreds <- getEmailCreds identifier
maid <-
case ( mecreds >>= emailCredsAuthId
, emailCredsEmail <$> mecreds
, emailCredsStatus <$> mecreds
) of
(Just aid, Just email', Just True) -> do
mrealpass <- lift $ getPassword aid
mrealpass <- getPassword aid
case mrealpass of
Nothing -> return Nothing
Just realpass -> do
passValid <- lift $ verifyPassword pass realpass
passValid <- verifyPassword pass realpass
return $ if passValid
then Just email'
else Nothing
@ -648,7 +653,7 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of
Just email' ->
lift $ setCredsRedirect $ Creds
setCredsRedirect $ Creds
(if isEmail then "email" else "username")
email'
[("verifiedEmail", email')]
@ -660,11 +665,11 @@ postLoginR = do
getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
getPasswordR = do
maid <- lift maybeAuthId
maid <- maybeAuthId
case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid
needOld <- maybe (return True) needOldPassword maid
setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'.
@ -672,12 +677,12 @@ getPasswordR = do
-- @since 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler needOld = do
messageRender <- lift getMessageRender
messageRender <- getMessageRender
toParent <- getRouteToParent
selectRep $ do
provideJsonMessage $ messageRender Msg.SetPass
provideRep $ lift $ authLayout $ do
(widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm
provideRep $ authLayout $ do
(widget, enctype) <- generateFormPost setPasswordForm
setTitleI Msg.SetPassTitle
[whamlet|
<h3>_{Msg.SetPass}
@ -751,8 +756,8 @@ parsePassword = withObject "password" (\obj -> do
postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR = do
maid <- lift maybeAuthId
(creds :: Result Value) <- lift parseCheckJsonBody
maid <- maybeAuthId
(creds :: Result Value) <- parseCheckJsonBody
let jcreds = case creds of
Error _ -> Nothing
Success val -> parseMaybe parsePassword val
@ -761,26 +766,26 @@ postPasswordR = do
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do
tm <- getRouteToParent
needOld <- lift $ needOldPassword aid
needOld <- needOldPassword aid
if not needOld then confirmPassword aid tm jcreds else do
res <- lift $ runInputPostResult $ ireq textField "current"
res <- runInputPostResult $ ireq textField "current"
let fcurrent = case res of
FormSuccess currentPass -> Just currentPass
_ -> Nothing
let current = if doJsonParsing
then getThird jcreds
else fcurrent
mrealpass <- lift $ getPassword aid
mrealpass <- getPassword aid
case (mrealpass, current) of
(Nothing, _) ->
liftHandler $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
(_, Nothing) ->
loginErrorMessageI LoginR Msg.BadSetPass
(Just realpass, Just current') -> do
passValid <- liftHandler $ verifyPassword current' realpass
passValid <- verifyPassword current' realpass
if passValid
then confirmPassword aid tm jcreds
else liftHandler $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
else loginErrorMessage (tm setpassR) "Invalid current password, please try again"
where
msgOk = Msg.PassUpdated
@ -789,7 +794,7 @@ postPasswordR = do
getNewConfirm (Just (a,b,_)) = Just (a,b)
getNewConfirm _ = Nothing
confirmPassword aid tm jcreds = do
res <- lift $ runInputPostResult $ (,)
res <- runInputPostResult $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
let creds = if (isJust jcreds)
@ -803,21 +808,21 @@ postPasswordR = do
if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch
else do
isSecure <- lift $ checkPasswordSecurity aid new
isSecure <- checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Left e -> loginErrorMessage (tm setpassR) e
Right () -> do
salted <- lift $ hashAndSaltPassword new
y <- lift $ do
salted <- hashAndSaltPassword new
y <- do
setPassword aid salted
deleteSession loginLinkKey
addMessageI "success" msgOk
getYesod
mr <- lift getMessageRender
mr <- getMessageRender
selectRep $ do
provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y
fmap asHtml $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk)
saltLength :: Int

89
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -1,89 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
-- | Use an email address as an identifier via Google's OpenID login system.
--
-- This backend will not use the OpenID identifier at all. It only uses OpenID
-- as a login system. By using this plugin, you are trusting Google to validate
-- an email address, and requiring users to have a Google account. On the plus
-- side, you get to use email addresses as the identifier, many users have
-- existing Google accounts, the login system has been long tested (as opposed
-- to BrowserID), and it requires no credential managing or setup (as opposed
-- to Email).
module Yesod.Auth.GoogleEmail
{-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}
( authGoogleEmail
, forwardUrl
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Core
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
pid :: Text
pid = "googleemail"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
googleIdent :: Text
googleIdent = "https://www.google.com/accounts/o8/id"
authGoogleEmail :: YesodAuth m => AuthPlugin m
authGoogleEmail =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
login tm =
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch "GET" ["forward"] = do
render <- getUrlRender
let complete' = render complete
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ns.ax.required", "email")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.required", "email")
, ("openid.ui.icon", "true")
] (authHttpManager master)
either
(\err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
redirect
eres
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper posts
dispatch _ _ = notFound
completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do
master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres
where
onFailure tm err =
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
onSuccess tm oir = do
let OpenId.Identifier ident = OpenId.oirOpLocal oir
memail <- lookupGetParam "openid.ext1.value.email"
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
(Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

43
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -2,6 +2,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Use an email address as an identifier via Google's login system.
--
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
@ -54,12 +56,12 @@ import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth,
runHttpRequest, setCredsRedirect,
logoutDest)
logoutDest, AuthHandler)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, HandlerT, MonadHandler,
import Yesod.Core (HandlerSite, MonadHandler,
TypedContent, getRouteToParent,
getUrlRender, invalidArgs,
lift, liftIO, lookupGetParam,
liftIO, lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:),
addMessage, getYesod,
@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret =
dispatch :: YesodAuth site
=> Text
-> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent
-> AuthHandler site TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
lift (getDest tm) >>= redirect
getDest tm >>= redirect
dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state"
@ -207,30 +209,27 @@ authPlugin storeToken clientID clientSecret =
case merr of
Nothing -> invalidArgs ["Missing code paramter"]
Just err -> do
master <- lift getYesod
master <- getYesod
let msg =
case err of
"access_denied" -> "Access denied"
_ -> "Unknown error occurred: " `T.append` err
addMessage "error" $ toHtml msg
lift $ redirect $ logoutDest master
redirect $ logoutDest master
Just c -> return c
render <- getUrlRender
tm <- getRouteToParent
req' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req =
urlEncodedBody
[ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render complete)
, ("redirect_uri", encodeUtf8 $ render $ tm complete)
, ("grant_type", "authorization_code")
]
req'
@ -257,15 +256,12 @@ authPlugin storeToken clientID clientSecret =
[e] -> return e
[] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue
setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound
makeHttpRequest
:: (YesodAuth site)
=> Request
-> HandlerT Auth (HandlerT site IO) A.Value
makeHttpRequest req = lift $
makeHttpRequest :: Request -> AuthHandler site A.Value
makeHttpRequest req =
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
-- | Allows to fetch information about a user from Google's API.
@ -273,7 +269,7 @@ makeHttpRequest req = lift $
-- Will throw 'HttpException' in case of network problems or error response code.
--
-- @since 1.4.3
getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
getPerson manager token = parseMaybe parseJSON <$> (do
req <- personValueRequest token
res <- http req manager
@ -282,13 +278,8 @@ getPerson manager token = parseMaybe parseJSON <$> (do
personValueRequest :: MonadIO m => Token -> m Request
personValueRequest token = do
req2' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"https://www.googleapis.com/plus/v1/people/me"
req2' <- liftIO
$ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
return req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)

23
yesod-auth/Yesod/Auth/Hardcoded.hs
View File

@ -131,9 +131,10 @@ module Yesod.Auth.Hardcoded
, loginR )
where
import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute,
import Yesod.Auth (AuthPlugin (..), AuthRoute,
Creds (..), Route (..), YesodAuth,
loginErrorMessageI, setCredsRedirect)
loginErrorMessageI, setCredsRedirect,
AuthHandler)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core
import Yesod.Form (ireq, runInputPost, textField)
@ -148,10 +149,10 @@ loginR = PluginR "hardcoded" ["login"]
class (YesodAuth site) => YesodAuthHardcoded site where
-- | Check whether given user name exists among hardcoded names.
doesUserNameExist :: Text -> HandlerT site IO Bool
doesUserNameExist :: Text -> AuthHandler site Bool
-- | Validate given user name with given password.
validatePassword :: Text -> Text -> HandlerT site IO Bool
validatePassword :: Text -> Text -> AuthHandler site Bool
authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
@ -182,16 +183,16 @@ authHardcoded =
|]
postLoginR :: (YesodAuthHardcoded master)
=> HandlerT Auth (HandlerT master IO) TypedContent
postLoginR :: YesodAuthHardcoded site
=> AuthHandler site TypedContent
postLoginR =
do (username, password) <- lift (runInputPost
do (username, password) <- runInputPost
((,) Control.Applicative.<$> ireq textField "username"
Control.Applicative.<*> ireq textField "password"))
isValid <- lift (validatePassword username password)
Control.Applicative.<*> ireq textField "password")
isValid <- validatePassword username password
if isValid
then lift (setCredsRedirect (Creds "hardcoded" username []))
else do isExists <- lift (doesUserNameExist username)
then setCredsRedirect (Creds "hardcoded" username [])
else do isExists <- doesUserNameExist username
loginErrorMessageI LoginR
(if isExists
then Msg.InvalidUsernamePass

26
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.OpenId
( authOpenId
, forwardUrl
@ -36,7 +37,10 @@ authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
name :: Text
name = "openid_identifier"
login tm = do
ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the
@ -57,18 +61,20 @@ $newline never
<input id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}">
|]
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
dispatch "GET" ["forward"] = do
roid <- lift $ runInputGet $ iopt textField name
roid <- runInputGet $ iopt textField name
case roid of
Just oid -> do
tm <- getRouteToParent
render <- getUrlRender
let complete' = render complete
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
let complete' = render $ tm complete
manager <- authHttpManager
eres <- liftResourceT $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
case eres of
Left err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
@ -84,13 +90,13 @@ $newline never
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do
master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
manager <- authHttpManager
eres <- liftResourceT $ try $ OpenId.authenticateClaimed gets' manager
either onFailure onSuccess eres
where
onFailure err = do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
onSuccess oir = do
let claimed =
@ -105,7 +111,7 @@ completeHelper idType gets' = do
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
lift $ setCredsRedirect $ Creds "openid" i gets''
setCredsRedirect $ Creds "openid" i gets''
-- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

14
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.Rpxnow
( authRpxnow
) where
@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery)
authRpxnow :: YesodAuth m
authRpxnow :: YesodAuth master
=> String -- ^ app name
-> String -- ^ key
-> AuthPlugin m
-> AuthPlugin master
authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login
where
@ -32,14 +33,17 @@ authRpxnow app apiKey =
$newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|]
dispatch :: a -> [b] -> AuthHandler master TypedContent
dispatch _ [] = do
token1 <- lookupGetParams "token"
token2 <- lookupPostParams "token"
token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x
master <- lift getYesod
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
manager <- authHttpManager
Rpxnow.Identifier ident extra <-
liftResourceT $ Rpxnow.authenticate apiKey token manager
let creds =
Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x))
@ -47,7 +51,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[]
lift $ setCredsRedirect creds
setCredsRedirect creds
dispatch _ _ = notFound
-- | Get some form of a display name.

5
yesod-auth/yesod-auth.cabal
View File

@ -38,9 +38,9 @@ library
, unordered-containers
, yesod-form >= 1.4 && < 1.5
, transformers >= 0.2.2
, persistent >= 2.1 && < 2.8
, persistent >= 2.5 && < 2.8
, persistent-template >= 2.1 && < 2.8
, http-client
, http-client >= 0.5
, http-client-tls
, http-conduit >= 2.1
, aeson >= 0.7
@ -76,7 +76,6 @@ library
Yesod.Auth.OpenId
Yesod.Auth.Rpxnow
Yesod.Auth.Message
Yesod.Auth.GoogleEmail
Yesod.Auth.GoogleEmail2
Yesod.Auth.Hardcoded
Yesod.Auth.Util.PasswordStore

7
yesod-static/Yesod/Static.hs
View File

@ -78,7 +78,6 @@ import Language.Haskell.TH.Syntax as TH
import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.State
import qualified Data.ByteArray as ByteArray
@ -175,12 +174,10 @@ instance RenderRoute Static where
instance ParseRoute Static where
parseRoute (x, y) = Just $ StaticRoute x y
instance (MonadThrow m, MonadIO m, MonadBaseControl IO m)
=> YesodSubDispatch Static (HandlerT master m) where
instance MonadHandler m => YesodSubDispatch Static m where
yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ StaticRoute (pathInfo req) []
Static set = ysreGetSub $ yreSite $ ysreParentEnv