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

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

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

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

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

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

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

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

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

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

@ -186,29 +186,29 @@ class ( YesodAuth site
-- has not yet been verified. -- has not yet been verified.
-- --
-- @since 1.1.0 -- @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. -- | Send an email to the given address to verify ownership.
-- --
-- @since 1.1.0 -- @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. -- | Get the verification key for the given email ID.
-- --
-- @since 1.1.0 -- @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. -- | Set the verification key for the given email ID.
-- --
-- @since 1.1.0 -- @since 1.1.0
setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()
-- | Hash and salt a password -- | Hash and salt a password
-- --
-- Default: 'saltPass'. -- Default: 'saltPass'.
-- --
-- @since 1.4.20 -- @since 1.4.20
hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
hashAndSaltPassword = liftIO . saltPass hashAndSaltPassword = liftIO . saltPass
-- | Verify a password matches the stored password for the given account. -- | 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'. -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
-- --
-- @since 1.4.20 -- @since 1.4.20
verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
verifyPassword plain salted = return $ isValidPass plain salted verifyPassword plain salted = return $ isValidPass plain salted
-- | Verify the email address on the given account. -- | Verify the email address on the given account.
@ -228,28 +228,28 @@ class ( YesodAuth site
-- See <https://github.com/yesodweb/yesod/issues/1222>. -- See <https://github.com/yesodweb/yesod/issues/1222>.
-- --
-- @since 1.1.0 -- @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. -- | Get the salted password for the given account.
-- --
-- @since 1.1.0 -- @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. -- | Set the salted password for the given account.
-- --
-- @since 1.1.0 -- @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 -- | Get the credentials for the given @Identifier@, which may be either an
-- email address or some other identification (e.g., username). -- email address or some other identification (e.g., username).
-- --
-- @since 1.2.0 -- @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. -- | Get the email address for the given email ID.
-- --
-- @since 1.1.0 -- @since 1.1.0
getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
-- | Generate a random alphanumeric string. -- | 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. -- Default: if the user logged in via an email link do not require a password.
-- --
-- @since 1.2.1 -- @since 1.2.1
needOldPassword :: AuthId site -> HandlerT site IO Bool needOldPassword :: AuthId site -> AuthHandler site Bool
needOldPassword aid' = do needOldPassword aid' = do
mkey <- lookupSession loginLinkKey mkey <- lookupSession loginLinkKey
case mkey >>= readMay . TS.unpack of case mkey >>= readMay . TS.unpack of
@ -280,7 +280,7 @@ class ( YesodAuth site
-- | Check that the given plain-text password meets minimum security standards. -- | Check that the given plain-text password meets minimum security standards.
-- --
-- Default: password is at least three characters. -- 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 checkPasswordSecurity _ x
| TS.length x >= 3 = return $ Right () | TS.length x >= 3 = return $ Right ()
| otherwise = return $ Left "Password must be at least three characters" | otherwise = return $ Left "Password must be at least three characters"
@ -288,7 +288,7 @@ class ( YesodAuth site
-- | Response after sending a confirmation email. -- | Response after sending a confirmation email.
-- --
-- @since 1.2.2 -- @since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
confirmationEmailSentResponse identifier = do confirmationEmailSentResponse identifier = do
mr <- getMessageRender mr <- getMessageRender
selectRep $ do selectRep $ do
@ -314,7 +314,7 @@ class ( YesodAuth site
-- Default: 'defaultEmailLoginHandler'. -- Default: 'defaultEmailLoginHandler'.
-- --
-- @since 1.4.17 -- @since 1.4.17
emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
emailLoginHandler = defaultEmailLoginHandler emailLoginHandler = defaultEmailLoginHandler
@ -377,9 +377,12 @@ getRegisterR = registerHandler
-- | Default implementation of 'emailLoginHandler'. -- | Default implementation of 'emailLoginHandler'.
-- --
-- @since 1.4.17 -- @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 defaultEmailLoginHandler toParent = do
(widget, enctype) <- liftWidgetT $ generateFormPost loginForm (widget, enctype) <- generateFormPost loginForm
[whamlet| [whamlet|
<form method="post" action="@{toParent loginR}", enctype=#{enctype}> <form method="post" action="@{toParent loginR}", enctype=#{enctype}>
@ -439,9 +442,9 @@ defaultEmailLoginHandler toParent = do
-- @since 1.2.6 -- @since 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do defaultRegisterHandler = do
(widget, enctype) <- lift $ generateFormPost registrationForm (widget, enctype) <- generateFormPost registrationForm
toParentRoute <- getRouteToParent toParentRoute <- getRouteToParent
lift $ authLayout $ do authLayout $ do
setTitleI Msg.RegisterLong setTitleI Msg.RegisterLong
[whamlet| [whamlet|
<p>_{Msg.EnterEmail} <p>_{Msg.EnterEmail}
@ -482,12 +485,12 @@ registerHelper :: YesodAuthEmail master
-> Route Auth -> Route Auth
-> AuthHandler master TypedContent -> AuthHandler master TypedContent
registerHelper allowUsername dest = do registerHelper allowUsername dest = do
y <- lift getYesod y <- getYesod
checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
pidentifier <- lookupPostParam "email" pidentifier <- lookupPostParam "email"
midentifier <- case pidentifier of midentifier <- case pidentifier of
Nothing -> do Nothing -> do
(jidentifier :: Result Value) <- lift parseCheckJsonBody (jidentifier :: Result Value) <- parseCheckJsonBody
case jidentifier of case jidentifier of
Error _ -> return Nothing Error _ -> return Nothing
Success val -> return $ parseMaybe parseEmail val Success val -> return $ parseMaybe parseEmail val
@ -502,28 +505,29 @@ registerHelper allowUsername dest = do
case eidentifier of case eidentifier of
Left route -> loginErrorMessageI dest route Left route -> loginErrorMessageI dest route
Right identifier -> do Right identifier -> do
mecreds <- lift $ getEmailCreds identifier mecreds <- getEmailCreds identifier
registerCreds <- registerCreds <-
case mecreds of case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email) Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
lift $ setVerifyKey lid key setVerifyKey lid key
return $ Just (lid, key, email) return $ Just (lid, key, email)
Nothing Nothing
| allowUsername -> return Nothing | allowUsername -> return Nothing
| otherwise -> do | otherwise -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key lid <- addUnverified identifier key
return $ Just (lid, key, identifier) return $ Just (lid, key, identifier)
case registerCreds of case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier) Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do Just (lid, verKey, email) -> do
render <- getUrlRender render <- getUrlRender
let verUrl = render $ verifyR (toPathPiece lid) verKey tp <- getRouteToParent
lift $ sendVerifyEmail email verKey verUrl let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
lift $ confirmationEmailSentResponse identifier sendVerifyEmail email verKey verUrl
confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
postRegisterR = registerHelper False registerR postRegisterR = registerHelper False registerR
@ -536,9 +540,9 @@ getForgotPasswordR = forgotPasswordHandler
-- @since 1.2.6 -- @since 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler = do defaultForgotPasswordHandler = do
(widget, enctype) <- lift $ generateFormPost forgotPasswordForm (widget, enctype) <- generateFormPost forgotPasswordForm
toParent <- getRouteToParent toParent <- getRouteToParent
lift $ authLayout $ do authLayout $ do
setTitleI Msg.PasswordResetTitle setTitleI Msg.PasswordResetTitle
[whamlet| [whamlet|
<p>_{Msg.PasswordResetPrompt} <p>_{Msg.PasswordResetPrompt}
@ -577,27 +581,28 @@ getVerifyR :: YesodAuthEmail site
-> Text -> Text
-> AuthHandler site TypedContent -> AuthHandler site TypedContent
getVerifyR lid key = do getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid realKey <- getVerifyKey lid
memail <- lift $ getEmail lid memail <- getEmail lid
mr <- lift getMessageRender mr <- getMessageRender
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
(True, Just email) -> do (True, Just email) -> do
muid <- lift $ verifyAccount lid muid <- verifyAccount lid
case muid of case muid of
Nothing -> invalidKey mr Nothing -> invalidKey mr
Just uid -> do Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid? setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setLoginLinkKey uid setLoginLinkKey uid
let msgAv = Msg.AddressVerified let msgAv = Msg.AddressVerified
selectRep $ do selectRep $ do
provideRep $ do provideRep $ do
lift $ addMessageI "success" msgAv addMessageI "success" msgAv
fmap asHtml $ redirect setpassR tp <- getRouteToParent
fmap asHtml $ redirect $ tp setpassR
provideJsonMessage $ mr msgAv provideJsonMessage $ mr msgAv
_ -> invalidKey mr _ -> invalidKey mr
where where
msgIk = Msg.InvalidKey msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do
setTitleI msgIk setTitleI msgIk
[whamlet| [whamlet|
$newline never $newline never
@ -614,14 +619,14 @@ parseCreds = withObject "creds" (\obj -> do
postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR = do postLoginR = do
result <- lift $ runInputPostResult $ (,) result <- runInputPostResult $ (,)
<$> ireq textField "email" <$> ireq textField "email"
<*> ireq textField "password" <*> ireq textField "password"
midentifier <- case result of midentifier <- case result of
FormSuccess (iden, pass) -> return $ Just (iden, pass) FormSuccess (iden, pass) -> return $ Just (iden, pass)
_ -> do _ -> do
(creds :: Result Value) <- lift parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
case creds of case creds of
Error _ -> return Nothing Error _ -> return Nothing
Success val -> return $ parseMaybe parseCreds val Success val -> return $ parseMaybe parseCreds val
@ -629,18 +634,18 @@ postLoginR = do
case midentifier of case midentifier of
Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
Just (identifier, pass) -> do Just (identifier, pass) -> do
mecreds <- lift $ getEmailCreds identifier mecreds <- getEmailCreds identifier
maid <- maid <-
case ( mecreds >>= emailCredsAuthId case ( mecreds >>= emailCredsAuthId
, emailCredsEmail <$> mecreds , emailCredsEmail <$> mecreds
, emailCredsStatus <$> mecreds , emailCredsStatus <$> mecreds
) of ) of
(Just aid, Just email', Just True) -> do (Just aid, Just email', Just True) -> do
mrealpass <- lift $ getPassword aid mrealpass <- getPassword aid
case mrealpass of case mrealpass of
Nothing -> return Nothing Nothing -> return Nothing
Just realpass -> do Just realpass -> do
passValid <- lift $ verifyPassword pass realpass passValid <- verifyPassword pass realpass
return $ if passValid return $ if passValid
then Just email' then Just email'
else Nothing else Nothing
@ -648,7 +653,7 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of case maid of
Just email' -> Just email' ->
lift $ setCredsRedirect $ Creds setCredsRedirect $ Creds
(if isEmail then "email" else "username") (if isEmail then "email" else "username")
email' email'
[("verifiedEmail", email')] [("verifiedEmail", email')]
@ -660,11 +665,11 @@ postLoginR = do
getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
getPasswordR = do getPasswordR = do
maid <- lift maybeAuthId maid <- maybeAuthId
case maid of case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid needOld <- maybe (return True) needOldPassword maid
setPasswordHandler needOld setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'. -- | Default implementation of 'setPasswordHandler'.
@ -672,12 +677,12 @@ getPasswordR = do
-- @since 1.2.6 -- @since 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler needOld = do defaultSetPasswordHandler needOld = do
messageRender <- lift getMessageRender messageRender <- getMessageRender
toParent <- getRouteToParent toParent <- getRouteToParent
selectRep $ do selectRep $ do
provideJsonMessage $ messageRender Msg.SetPass provideJsonMessage $ messageRender Msg.SetPass
provideRep $ lift $ authLayout $ do provideRep $ authLayout $ do
(widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm (widget, enctype) <- generateFormPost setPasswordForm
setTitleI Msg.SetPassTitle setTitleI Msg.SetPassTitle
[whamlet| [whamlet|
<h3>_{Msg.SetPass} <h3>_{Msg.SetPass}
@ -751,8 +756,8 @@ parsePassword = withObject "password" (\obj -> do
postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR = do postPasswordR = do
maid <- lift maybeAuthId maid <- maybeAuthId
(creds :: Result Value) <- lift parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
let jcreds = case creds of let jcreds = case creds of
Error _ -> Nothing Error _ -> Nothing
Success val -> parseMaybe parsePassword val Success val -> parseMaybe parsePassword val
@ -761,26 +766,26 @@ postPasswordR = do
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do Just aid -> do
tm <- getRouteToParent tm <- getRouteToParent
needOld <- lift $ needOldPassword aid needOld <- needOldPassword aid
if not needOld then confirmPassword aid tm jcreds else do 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 let fcurrent = case res of
FormSuccess currentPass -> Just currentPass FormSuccess currentPass -> Just currentPass
_ -> Nothing _ -> Nothing
let current = if doJsonParsing let current = if doJsonParsing
then getThird jcreds then getThird jcreds
else fcurrent else fcurrent
mrealpass <- lift $ getPassword aid mrealpass <- getPassword aid
case (mrealpass, current) of case (mrealpass, current) of
(Nothing, _) -> (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) -> (_, Nothing) ->
loginErrorMessageI LoginR Msg.BadSetPass loginErrorMessageI LoginR Msg.BadSetPass
(Just realpass, Just current') -> do (Just realpass, Just current') -> do
passValid <- liftHandler $ verifyPassword current' realpass passValid <- verifyPassword current' realpass
if passValid if passValid
then confirmPassword aid tm jcreds 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 where
msgOk = Msg.PassUpdated msgOk = Msg.PassUpdated
@ -789,7 +794,7 @@ postPasswordR = do
getNewConfirm (Just (a,b,_)) = Just (a,b) getNewConfirm (Just (a,b,_)) = Just (a,b)
getNewConfirm _ = Nothing getNewConfirm _ = Nothing
confirmPassword aid tm jcreds = do confirmPassword aid tm jcreds = do
res <- lift $ runInputPostResult $ (,) res <- runInputPostResult $ (,)
<$> ireq textField "new" <$> ireq textField "new"
<*> ireq textField "confirm" <*> ireq textField "confirm"
let creds = if (isJust jcreds) let creds = if (isJust jcreds)
@ -803,21 +808,21 @@ postPasswordR = do
if new /= confirm if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch then loginErrorMessageI setpassR Msg.PassMismatch
else do else do
isSecure <- lift $ checkPasswordSecurity aid new isSecure <- checkPasswordSecurity aid new
case isSecure of case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e Left e -> loginErrorMessage (tm setpassR) e
Right () -> do Right () -> do
salted <- lift $ hashAndSaltPassword new salted <- hashAndSaltPassword new
y <- lift $ do y <- do
setPassword aid salted setPassword aid salted
deleteSession loginLinkKey deleteSession loginLinkKey
addMessageI "success" msgOk addMessageI "success" msgOk
getYesod getYesod
mr <- lift getMessageRender mr <- getMessageRender
selectRep $ do selectRep $ do
provideRep $ provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y fmap asHtml $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk) provideJsonMessage (mr msgOk)
saltLength :: Int 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 FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Use an email address as an identifier via Google's login system. -- | Use an email address as an identifier via Google's login system.
-- --
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends -- 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), AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth, Route (PluginR), YesodAuth,
runHttpRequest, setCredsRedirect, runHttpRequest, setCredsRedirect,
logoutDest) logoutDest, AuthHandler)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, HandlerT, MonadHandler, import Yesod.Core (HandlerSite, MonadHandler,
TypedContent, getRouteToParent, TypedContent, getRouteToParent,
getUrlRender, invalidArgs, getUrlRender, invalidArgs,
lift, liftIO, lookupGetParam, liftIO, lookupGetParam,
lookupSession, notFound, redirect, lookupSession, notFound, redirect,
setSession, whamlet, (.:), setSession, whamlet, (.:),
addMessage, getYesod, addMessage, getYesod,
@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret =
dispatch :: YesodAuth site dispatch :: YesodAuth site
=> Text => Text
-> [Text] -> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent -> AuthHandler site TypedContent
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
tm <- getRouteToParent tm <- getRouteToParent
lift (getDest tm) >>= redirect getDest tm >>= redirect
dispatch "GET" ["complete"] = do dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state" mstate <- lookupGetParam "state"
@ -207,30 +209,27 @@ authPlugin storeToken clientID clientSecret =
case merr of case merr of
Nothing -> invalidArgs ["Missing code paramter"] Nothing -> invalidArgs ["Missing code paramter"]
Just err -> do Just err -> do
master <- lift getYesod master <- getYesod
let msg = let msg =
case err of case err of
"access_denied" -> "Access denied" "access_denied" -> "Access denied"
_ -> "Unknown error occurred: " `T.append` err _ -> "Unknown error occurred: " `T.append` err
addMessage "error" $ toHtml msg addMessage "error" $ toHtml msg
lift $ redirect $ logoutDest master redirect $ logoutDest master
Just c -> return c Just c -> return c
render <- getUrlRender render <- getUrlRender
tm <- getRouteToParent
req' <- liftIO $ req' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow 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 "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req = let req =
urlEncodedBody urlEncodedBody
[ ("code", encodeUtf8 code) [ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID) , ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret) , ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render complete) , ("redirect_uri", encodeUtf8 $ render $ tm complete)
, ("grant_type", "authorization_code") , ("grant_type", "authorization_code")
] ]
req' req'
@ -257,15 +256,12 @@ authPlugin storeToken clientID clientSecret =
[e] -> return e [e] -> return e
[] -> error "No account email" [] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound dispatch _ _ = notFound
makeHttpRequest makeHttpRequest :: Request -> AuthHandler site A.Value
:: (YesodAuth site) makeHttpRequest req =
=> Request
-> HandlerT Auth (HandlerT site IO) A.Value
makeHttpRequest req = lift $
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json' runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
-- | Allows to fetch information about a user from Google's API. -- | 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. -- Will throw 'HttpException' in case of network problems or error response code.
-- --
-- @since 1.4.3 -- @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 getPerson manager token = parseMaybe parseJSON <$> (do
req <- personValueRequest token req <- personValueRequest token
res <- http req manager res <- http req manager
@ -282,13 +278,8 @@ getPerson manager token = parseMaybe parseJSON <$> (do
personValueRequest :: MonadIO m => Token -> m Request personValueRequest :: MonadIO m => Token -> m Request
personValueRequest token = do personValueRequest token = do
req2' <- liftIO $ req2' <- liftIO
#if MIN_VERSION_http_client(0,4,30) $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"https://www.googleapis.com/plus/v1/people/me"
return req2' return req2'
{ requestHeaders = { requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token) [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)

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

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

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

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.OpenId module Yesod.Auth.OpenId
( authOpenId ( authOpenId
, forwardUrl , forwardUrl
@ -36,7 +37,10 @@ authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login AuthPlugin "openid" dispatch login
where where
complete = PluginR "openid" ["complete"] complete = PluginR "openid" ["complete"]
name :: Text
name = "openid_identifier" name = "openid_identifier"
login tm = do login tm = do
ident <- newIdent ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the -- 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 id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}"> <input type="submit" value="_{Msg.LoginOpenID}">
|] |]
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
roid <- lift $ runInputGet $ iopt textField name roid <- runInputGet $ iopt textField name
case roid of case roid of
Just oid -> do Just oid -> do
tm <- getRouteToParent
render <- getUrlRender render <- getUrlRender
let complete' = render complete let complete' = render $ tm complete
master <- lift getYesod manager <- authHttpManager
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) eres <- liftResourceT $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
case eres of case eres of
Left err -> do Left err -> do
tm <- getRouteToParent loginErrorMessage (tm LoginR) $ T.pack $
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException) show (err :: SomeException)
Right x -> redirect x Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
@ -84,13 +90,13 @@ $newline never
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do completeHelper idType gets' = do
master <- lift getYesod manager <- authHttpManager
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- liftResourceT $ try $ OpenId.authenticateClaimed gets' manager
either onFailure onSuccess eres either onFailure onSuccess eres
where where
onFailure err = do onFailure err = do
tm <- getRouteToParent tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException) show (err :: SomeException)
onSuccess oir = do onSuccess oir = do
let claimed = let claimed =
@ -105,7 +111,7 @@ completeHelper idType gets' = do
case idType of case idType of
OPLocal -> OpenId.oirOpLocal oir OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed 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 -- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier -- \"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 OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.Rpxnow module Yesod.Auth.Rpxnow
( authRpxnow ( authRpxnow
) where ) where
@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***)) import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery) import Network.HTTP.Types (renderQuery)
authRpxnow :: YesodAuth m authRpxnow :: YesodAuth master
=> String -- ^ app name => String -- ^ app name
-> String -- ^ key -> String -- ^ key
-> AuthPlugin m -> AuthPlugin master
authRpxnow app apiKey = authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login AuthPlugin "rpxnow" dispatch login
where where
@ -32,14 +33,17 @@ authRpxnow app apiKey =
$newline never $newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> <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 dispatch _ [] = do
token1 <- lookupGetParams "token" token1 <- lookupGetParams "token"
token2 <- lookupPostParams "token" token2 <- lookupPostParams "token"
token <- case token1 ++ token2 of token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"] [] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x x:_ -> return $ unpack x
master <- lift getYesod manager <- authHttpManager
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) Rpxnow.Identifier ident extra <-
liftResourceT $ Rpxnow.authenticate apiKey token manager
let creds = let creds =
Creds "rpxnow" ident Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x)) $ maybe id (\x -> (:) ("verifiedEmail", x))
@ -47,7 +51,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x)) $ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[] []
lift $ setCredsRedirect creds setCredsRedirect creds
dispatch _ _ = notFound dispatch _ _ = notFound
-- | Get some form of a display name. -- | Get some form of a display name.

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

@ -38,9 +38,9 @@ library
, unordered-containers , unordered-containers
, yesod-form >= 1.4 && < 1.5 , yesod-form >= 1.4 && < 1.5
, transformers >= 0.2.2 , transformers >= 0.2.2
, persistent >= 2.1 && < 2.8 , persistent >= 2.5 && < 2.8
, persistent-template >= 2.1 && < 2.8 , persistent-template >= 2.1 && < 2.8
, http-client , http-client >= 0.5
, http-client-tls , http-client-tls
, http-conduit >= 2.1 , http-conduit >= 2.1
, aeson >= 0.7 , aeson >= 0.7
@ -76,7 +76,6 @@ library
Yesod.Auth.OpenId Yesod.Auth.OpenId
Yesod.Auth.Rpxnow Yesod.Auth.Rpxnow
Yesod.Auth.Message Yesod.Auth.Message
Yesod.Auth.GoogleEmail
Yesod.Auth.GoogleEmail2 Yesod.Auth.GoogleEmail2
Yesod.Auth.Hardcoded Yesod.Auth.Hardcoded
Yesod.Auth.Util.PasswordStore 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.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest) import Crypto.Hash (MD5, Digest)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.State import Control.Monad.Trans.State
import qualified Data.ByteArray as ByteArray import qualified Data.ByteArray as ByteArray
@ -175,12 +174,10 @@ instance RenderRoute Static where
instance ParseRoute Static where instance ParseRoute Static where
parseRoute (x, y) = Just $ StaticRoute x y parseRoute (x, y) = Just $ StaticRoute x y
instance (MonadThrow m, MonadIO m, MonadBaseControl IO m) instance MonadHandler m => YesodSubDispatch Static m where
=> YesodSubDispatch Static (HandlerT master m) where
yesodSubDispatch YesodSubRunnerEnv {..} req = yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ StaticRoute (pathInfo req) [] route = Just $ StaticRoute (pathInfo req) []
Static set = ysreGetSub $ yreSite $ ysreParentEnv Static set = ysreGetSub $ yreSite $ ysreParentEnv