diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,240 @@
+# ChangeLog for yesod-auth
+
+## 1.6.12.1
+
+* Support `yesod-core` 1.7
+
+## 1.6.12.0
+
+* Add `afterPasswordRouteHandler` [#1863](https://github.com/yesodweb/yesod/pull/1863)
+* Use crypton instead of cryptonite [#1838](https://github.com/yesodweb/yesod/pull/1838)
+* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)
+
+
+## 1.6.11.3
+
+* Add Romanian translation [#1809](https://github.com/yesodweb/yesod/pull/1809)
+
+## 1.6.11.2
+
+* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)
+
+## 1.6.11.1
+
+* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)
+
+## 1.6.11
+
+* Add support for aeson 2
+
+## 1.6.10.5
+
+* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)
+
+## 1.6.10.4
+
+* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)
+
+## 1.6.10.3
+
+* Relax bounds for yesod-form 1.7
+
+## 1.6.10.2
+
+* Relax bounds for persistent 2.12
+
+## 1.6.10.1
+
+* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)
+
+## 1.6.10
+
+* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`
+* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration
+* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password
+* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)
+
+## 1.6.9
+
+* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)
+* Exposed `defaultRegisterHelper` as default implementation for the above methods
+
+## 1.6.8.1
+
+* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
+* Remove unnecessary deriving of Typeable
+
+## 1.6.8
+
+* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)
+
+## 1.6.7
+
+* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)
+
+## 1.6.6
+
+* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)
+
+## 1.6.5
+
+* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)
+
+## 1.6.4.1
+
+* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)
+
+## 1.6.4
+
+* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)
+* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389)
+To configure this new functionality:
+ 1. Define `addUnverifiedWithPass`, e.g:
+ ```
+ addUnverified email verkey = liftHandler $ runDB $ do
+ void $ insert $ UserLogin email Nothing (Just verkey) False
+ return email
+
+ addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do
+ void $ insert $ UserLogin email (Just pass) (Just verkey) False
+ return email
+ ```
+ 2. Add a `password` field to your client forms.
+
+## 1.6.3
+
+* Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)
+
+## 1.6.2
+
+* Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)
+
+## 1.6.1
+
+* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)
+
+## 1.6.0
+
+* Upgrade to yesod-core 1.6.0
+
+## 1.4.21
+
+* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)
+
+## 1.4.20
+
+* Extend `YesodAuthEmail` to support extensible password hashing via
+ `hashAndSaltPassword` and `verifyPassword` functions
+
+## 1.4.19
+
+* Adjust English localization to distinguish between "log in" (verb) and "login" (noun)
+
+## 1.4.18
+
+* Expose Yesod.Auth.Util.PasswordStore
+
+## 1.4.17.3
+
+* Some translation fixes
+
+## 1.4.17.2
+
+* Move to cryptonite from cryptohash
+
+## 1.4.17.1
+
+* Some translation fixes
+
+## 1.4.17
+
+* Add Show instance for user credentials `Creds`
+* Export pid type for identifying plugin
+* Fix warnings
+* Allow for a custom Email Login DOM with `emailLoginHandler`
+
+## 1.4.16
+
+* Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330)
+* Document JSON endpoints of Yesod.Auth.Email
+
+## 1.4.15
+
+* Add JSON endpoints to Yesod.Auth.Email module
+* Export croatianMessage from Message module
+* Minor Haddock rendering fixes at Auth.Email module
+
+## 1.4.14
+
+* Remove Google OpenID link [#1309](https://github.com/yesodweb/yesod/pull/1309)
+* Add CSRF Security check in `registerHelperFunction` [#1302](https://github.com/yesodweb/yesod/pull/1302)
+
+## 1.4.13.5
+
+* Translation fix
+
+## 1.4.13.4
+
+* Improved translations
+* peristent 2.6
+
+## 1.4.13.3
+
+* Doc update (and a warning)
+
+## 1.4.13.1
+
+* Add CSRF token to login form from `Yesod.Auth.Dummy` [#1205](https://github.com/yesodweb/yesod/pull/1205)
+
+## 1.4.13
+
+* Add a CSRF token to the login form from `Yesod.Auth.Hardcoded`, making it compatible with the CSRF middleware [#1161](https://github.com/yesodweb/yesod/pull/1161)
+* Multiple session messages. [#1187](https://github.com/yesodweb/yesod/pull/1187)
+
+## 1.4.12
+
+* Deprecated Yesod.Auth.GoogleEmail
+
+## 1.4.11
+
+Add Yesod.Auth.Hardcoded
+
+## 1.4.9
+
+* Expose defaultLoginHandler
+
+## 1.4.8
+
+* GoogleEmail2: proper error message when permission denied
+
+## 1.4.7
+
+* add a runHttpRequest function for handling HTTP errors
+
+## 1.4.6
+
+* Use nonce package to generate verification keys and CSRF tokens [#1011](https://github.com/yesodweb/yesod/pull/1011)
+
+## 1.4.5
+
+* Adds export of email verify route [#980](https://github.com/yesodweb/yesod/pull/980)
+
+## 1.4.4
+
+* Add AuthenticationResult and authenticate function [#959](https://github.com/yesodweb/yesod/pull/959)
+
+## 1.4.3
+
+* Added means to fetch user's Google profile [#936](https://github.com/yesodweb/yesod/pull/936)
+
+## 1.4.2
+
+* Perform `onLogout` before session cleaning [#923](https://github.com/yesodweb/yesod/pull/923)
+
+## 1.4.1.3
+
+[Updated french translation of Yesod.Auth.Message. #904](https://github.com/yesodweb/yesod/pull/904)
+
+## 1.4.1
+
+Dutch translation added.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,12 @@
+## yesod-auth
+
+This package provides a pluggable mechanism for allowing users to authenticate
+with your site. It comes with a number of common plugins, such as OpenID,
+BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available
+from Hackage as well. If you've written such an add-on, please notify me so
+that it can be added to this description.
+
+* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.
+* [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod
+* [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
+* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs
--- a/Yesod/Auth.hs
+++ b/Yesod/Auth.hs
@@ -1,14 +1,18 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Yesod.Auth
( -- * Subsite
Auth
@@ -17,8 +21,7 @@
, AuthPlugin (..)
, getAuth
, YesodAuth (..)
- , YesodAuthPersist
- , AuthEntity
+ , YesodAuthPersist (..)
-- * Plugin interface
, Creds (..)
, setCreds
@@ -27,13 +30,18 @@
, loginErrorMessage
, loginErrorMessageI
-- * User functions
+ , AuthenticationResult (..)
, defaultMaybeAuthId
+ , defaultLoginHandler
+ , maybeAuthPair
, maybeAuth
, requireAuthId
+ , requireAuthPair
, requireAuth
-- * Exception
, AuthException (..)
-- * Helper
+ , MonadAuthHandler
, AuthHandler
-- * Internal
, credsKey
@@ -46,14 +54,14 @@
import Control.Monad.Trans.Maybe
import Yesod.Auth.Routes
-import Data.Aeson
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as Map
import Data.Monoid (Endo)
-import Network.HTTP.Conduit (Manager)
+import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
+import Network.HTTP.Client.TLS (getGlobalManager)
import qualified Network.Wai as W
@@ -64,22 +72,31 @@
import Yesod.Form (FormMessage)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
-import Network.HTTP.Types (unauthorized401)
-import Control.Monad.Trans.Resource (MonadResourceBase)
+import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
+import Data.Kind (Type)
type AuthRoute = Route Auth
-type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
+type MonadAuthHandler master m = (MonadHandler 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
+-- | The result of an authentication based on credentials
+--
+-- @since 1.4.4
+data AuthenticationResult master
+ = Authenticated (AuthId master) -- ^ Authenticated successfully
+ | UserError AuthMessage -- ^ Invalid credentials provided by user
+ | ServerError Text -- ^ Some other error
+
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
- , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
+ , apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
}
getAuth :: a -> Auth
@@ -90,14 +107,14 @@
{ credsPlugin :: Text -- ^ How the user was authenticated
, credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
, credsExtra :: [(Text, Text)]
- }
+ } deriving (Show)
class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
type AuthId master
-- | specify the layout. Uses defaultLayout by default
- authLayout :: WidgetT master IO () -> HandlerT master IO Html
- authLayout = defaultLayout
+ authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
+ authLayout = liftHandler . defaultLayout
-- | Default destination on successful login, if no other
-- destination exists.
@@ -107,20 +124,53 @@
-- destination exists.
logoutDest :: master -> Route master
+ -- | Perform authentication based on the given credentials.
+ --
+ -- Default implementation is in terms of @'getAuthId'@
+ --
+ -- @since: 1.4.4
+ authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
+ authenticate creds = do
+ muid <- getAuthId creds
+
+ return $ maybe (UserError Msg.InvalidLogin) Authenticated muid
+
-- | Determine the ID associated with the set of credentials.
- getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
+ --
+ -- Default implementation is in terms of @'authenticate'@
+ --
+ getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
+ getAuthId creds = do
+ auth <- authenticate creds
+ return $ case auth of
+ Authenticated auid -> Just auid
+ _ -> Nothing
+
-- | Which authentication backends to use.
authPlugins :: master -> [AuthPlugin master]
-- | What to show on the login page.
+ --
+ -- By default this calls 'defaultLoginHandler', which concatenates
+ -- plugin widgets and wraps the result in 'authLayout'. Override if
+ -- you need fancy widget containers, additional functionality, or an
+ -- entirely custom page. For example, in some applications you may
+ -- want to prevent the login page being displayed for a user who is
+ -- already logged in, even if the URL is visited explicitly; this can
+ -- be done by overriding 'loginHandler' in your instance declaration
+ -- with something like:
+ --
+ -- > instance YesodAuth App where
+ -- > ...
+ -- > loginHandler = do
+ -- > ma <- lift maybeAuthId
+ -- > when (isJust ma) $
+ -- > lift $ redirect HomeR -- or any other Handler code you want
+ -- > defaultLoginHandler
+ --
loginHandler :: AuthHandler master Html
- loginHandler = do
- tp <- getRouteToParent
- lift $ authLayout $ do
- setTitleI Msg.LoginTitle
- master <- getYesod
- mapM_ (flip apLogin tp) (authPlugins master)
+ loginHandler = defaultLoginHandler
-- | Used for i18n of messages provided by this package.
renderAuthMessage :: master
@@ -134,19 +184,27 @@
redirectToReferer :: master -> Bool
redirectToReferer _ = False
+ -- | When being redirected to the login page should the current page
+ -- be set to redirect back to. Default is 'True'.
+ --
+ -- @since 1.4.21
+ redirectToCurrent :: master -> Bool
+ redirectToCurrent _ = True
+
-- | Return an HTTP connection manager that is stored in the foundation
-- 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 -> Manager
+ authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
+ authHttpManager = liftIO getGlobalManager
-- | Called on a successful login. By default, calls
- -- @setMessageI NowLoggedIn@.
- onLogin :: HandlerT master IO ()
- onLogin = setMessageI Msg.NowLoggedIn
+ -- @addMessageI "success" NowLoggedIn@.
+ onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
+ onLogin = addMessageI "success" Msg.NowLoggedIn
-- | Called on logout. By default, does nothing
- onLogout :: HandlerT master IO ()
+ onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
onLogout = return ()
-- | Retrieves user credentials, if user is authenticated.
@@ -157,129 +215,154 @@
-- especially useful for creating an API to be accessed via some means
-- other than a browser.
--
- -- Since 1.2.0
- maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
+ -- @since 1.2.0
+ maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
default maybeAuthId
- :: ( YesodAuth master
- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
- , b ~ YesodPersistBackend master
- , Key val ~ AuthId master
- , PersistStore (b (HandlerT master IO))
- , PersistEntity val
- , YesodPersist master
- , Typeable val
- )
- => HandlerT master IO (Maybe (AuthId master))
+ :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
+ => m (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls
- -- @setMessage@ and redirects to @dest@.
- onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
+ -- @addMessage@ with "error" as status and redirects to @dest@.
+ onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
onErrorHtml dest msg = do
- setMessage $ toHtml msg
+ addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest
+ -- | runHttpRequest gives you a chance to handle an HttpException and retry
+ -- The default behavior is to simply execute the request which will throw an exception on failure
+ --
+ -- 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
+ :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
+ => Request
+ -> (Response BodyReader -> m a)
+ -> m a
+ runHttpRequest req inner = do
+ man <- authHttpManager
+ withRunInIO $ \run -> withResponse req man $ run . inner
+
+ {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}
+
+{-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}
+
-- | Internal session key used to hold the authentication information.
--
--- Since 1.2.3
+-- @since 1.2.3
credsKey :: Text
credsKey = "_ID"
-- | Retrieves user credentials from the session, if user is authenticated.
--
-- This function does /not/ confirm that the credentials are valid, see
--- 'maybeAuthIdRaw' for more information.
+-- 'maybeAuthIdRaw' for more information. The first call in a request
+-- does a database request to make sure that the account is still in the database.
--
--- Since 1.1.2
+-- @since 1.1.2
defaultMaybeAuthId
- :: ( YesodAuth master
- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
- , b ~ YesodPersistBackend master
- , Key val ~ AuthId master
- , PersistStore (b (HandlerT master IO))
- , PersistEntity val
- , YesodPersist master
- , Typeable val
- ) => HandlerT master IO (Maybe (AuthId master))
-defaultMaybeAuthId = do
- ms <- lookupSession credsKey
- case ms of
- Nothing -> return Nothing
- Just s ->
- case fromPathPiece s of
- Nothing -> return Nothing
- Just aid -> fmap (fmap entityKey) $ cachedAuth aid
+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
+ => m (Maybe (AuthId master))
+defaultMaybeAuthId = runMaybeT $ do
+ s <- MaybeT $ lookupSession credsKey
+ aid <- MaybeT $ return $ fromPathPiece s
+ _ <- MaybeT $ cachedAuth aid
+ return aid
-cachedAuth :: ( YesodAuth master
- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
- , b ~ YesodPersistBackend master
- , Key val ~ AuthId master
- , PersistStore (b (HandlerT master IO))
- , PersistEntity val
- , YesodPersist master
- , Typeable val
- ) => AuthId master -> HandlerT master IO (Maybe (Entity val))
-cachedAuth aid = runMaybeT $ do
- a <- MaybeT $ fmap unCachedMaybeAuth
- $ cached
- $ fmap CachedMaybeAuth
- $ runDB
- $ get aid
- return $ Entity aid a
+cachedAuth
+ :: ( MonadHandler m
+ , YesodAuthPersist master
+ , Typeable (AuthEntity master)
+ , HandlerSite m ~ master
+ )
+ => AuthId master
+ -> m (Maybe (AuthEntity master))
+cachedAuth
+ = fmap unCachedMaybeAuth
+ . cached
+ . fmap CachedMaybeAuth
+ . getAuthEntity
-loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
- => Route child
- -> AuthMessage
- -> HandlerT child (HandlerT master m) TypedContent
+-- | Default handler to show the login page.
+--
+-- This is the default 'loginHandler'. It concatenates plugin widgets and
+-- wraps the result in 'authLayout'. See 'loginHandler' for more details.
+--
+-- @since 1.4.9
+defaultLoginHandler :: AuthHandler master Html
+defaultLoginHandler = do
+ tp <- getRouteToParent
+ authLayout $ do
+ setTitleI Msg.LoginTitle
+ master <- getYesod
+ mapM_ (flip apLogin tp) (authPlugins master)
+
+
+loginErrorMessageI
+ :: Route Auth
+ -> AuthMessage
+ -> AuthHandler master TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
- lift $ loginErrorMessageMasterI (toParent dest) msg
+ loginErrorMessageMasterI (toParent dest) msg
-loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
- => Route master
- -> AuthMessage
- -> HandlerT master m TypedContent
+loginErrorMessageMasterI
+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
+ => Route master
+ -> AuthMessage
+ -> m TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
-- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status
-loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
- => Route master
+loginErrorMessage
+ :: (MonadHandler m, YesodAuth (HandlerSite m))
+ => Route (HandlerSite m)
-> Text
- -> HandlerT master m TypedContent
+ -> m TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
-messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
-messageJson401 msg html = selectRep $ do
+messageJson401
+ :: MonadHandler m
+ => Text
+ -> m Html
+ -> m TypedContent
+messageJson401 = messageJsonStatus unauthorized401
+
+messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
+messageJson500 = messageJsonStatus internalServerError500
+
+messageJsonStatus
+ :: MonadHandler m
+ => Status
+ -> Text
+ -> m Html
+ -> m TypedContent
+messageJsonStatus status msg html = selectRep $ do
provideRep html
provideRep $ do
let obj = object ["message" .= msg]
- void $ sendResponseStatus unauthorized401 obj
+ void $ sendResponseStatus status obj
return obj
provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
-setCredsRedirect :: YesodAuth master
- => Creds master -- ^ new credentials
- -> HandlerT master IO TypedContent
+setCredsRedirect
+ :: (MonadHandler m, YesodAuth (HandlerSite m))
+ => Creds (HandlerSite m) -- ^ new credentials
+ -> m TypedContent
setCredsRedirect creds = do
y <- getYesod
- maid <- getAuthId creds
- case maid of
- Nothing ->
- case authRoute y of
- Nothing -> do
- messageJson401 "Invalid Login" $ authLayout $
- toWidget [shamlet|
Invalid login|]
- Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
- Just aid -> do
+ auth <- authenticate creds
+ case auth of
+ Authenticated aid -> do
setSession credsKey $ toPathPiece aid
onLogin
res <- selectRep $ do
@@ -288,43 +371,74 @@
provideJsonMessage "Login Successful"
sendResponse res
+ UserError msg ->
+ case authRoute y of
+ Nothing -> do
+ msg' <- renderMessage' msg
+ messageJson401 msg' $ authLayout $ -- TODO
+ toWidget [whamlet|
_{msg}|]
+ Just ar -> loginErrorMessageMasterI ar msg
+
+ ServerError msg -> do
+ $(logError) msg
+
+ case authRoute y of
+ Nothing -> do
+ msg' <- renderMessage' Msg.AuthError
+ messageJson500 msg' $ authLayout $
+ toWidget [whamlet|
_{Msg.AuthError}|]
+ Just ar -> loginErrorMessageMasterI ar Msg.AuthError
+
+ where
+ renderMessage' msg = do
+ langs <- languages
+ master <- getYesod
+ 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
- -> Creds master -- ^ new credentials
- -> HandlerT master IO ()
+setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
+ => Bool -- ^ if HTTP redirects should be done
+ -> Creds (HandlerSite m) -- ^ new credentials
+ -> m ()
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
- else do maid <- getAuthId creds
- case maid of
- Nothing -> return ()
- Just aid -> setSession credsKey $ toPathPiece aid
+ else do auth <- authenticate creds
+ case auth of
+ Authenticated aid -> setSession credsKey $ toPathPiece aid
+ _ -> return ()
-- | same as defaultLayoutJson, but uses authLayout
-authLayoutJson :: (YesodAuth site, ToJSON j)
- => WidgetT site IO () -- ^ HTML
- -> HandlerT site IO j -- ^ JSON
- -> HandlerT site IO 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
-- | Clears current user credentials for the session.
--
--- Since 1.1.7
-clearCreds :: YesodAuth master
- => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
- -> HandlerT master IO ()
+-- @since 1.1.7
+clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
+ => Bool -- ^ if HTTP, redirect to 'logoutDest'
+ -> m ()
clearCreds doRedirects = do
- y <- getYesod
+ onLogout
deleteSession credsKey
- when doRedirects $ do
- onLogout
- redirectUltDest $ logoutDest y
+ y <- getYesod
+ aj <- acceptsJson
+ case (aj, doRedirects) of
+ (True, _) -> sendResponse successfulLogout
+ (False, True) -> redirectUltDest (logoutDest y)
+ _ -> return ()
+ where successfulLogout = object ["message" .= msg]
+ msg :: Text
+ msg = "Logged out successfully!"
getCheckR :: AuthHandler master TypedContent
-getCheckR = lift $ do
+getCheckR = do
creds <- maybeAuthId
authLayoutJson (do
setTitle "Authentication Status"
@@ -340,12 +454,12 @@
Not logged in.
|]
jsonCreds creds =
- Object $ Map.fromList
+ toJSON $ Map.fromList
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
-setUltDestReferer' :: AuthHandler master ()
-setUltDestReferer' = lift $ do
+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
+setUltDestReferer' = do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
@@ -353,14 +467,16 @@
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
-getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
+getLogoutR = do
+ tp <- getRouteToParent
+ setUltDestReferer' >> redirectToPost (tp LogoutR)
postLogoutR :: AuthHandler master ()
-postLogoutR = lift $ clearCreds True
+postLogoutR = clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
- master <- lift getYesod
+ master <- getYesod
env <- waiRequest
let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) (authPlugins master) of
@@ -371,67 +487,118 @@
-- with the user\'s database identifier to get the value in the database. This
-- assumes that you are using a Persistent database.
--
--- Since 1.1.0
-maybeAuth :: ( YesodAuth master
- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
- , b ~ YesodPersistBackend master
+-- @since 1.1.0
+maybeAuth :: ( YesodAuthPersist master
+ , val ~ AuthEntity master
, Key val ~ AuthId master
- , PersistStore (b (HandlerT master IO))
, PersistEntity val
- , YesodPersist master
, Typeable val
- ) => HandlerT master IO (Maybe (Entity val))
-maybeAuth = runMaybeT $ do
+ , MonadHandler m
+ , HandlerSite m ~ master
+ ) => m (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)
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => m (Maybe (AuthId master, AuthEntity master))
+maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId
- MaybeT $ cachedAuth aid
+ ae <- MaybeT $ cachedAuth aid
+ return (aid, ae)
-newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
- deriving Typeable
--- | Constraint which states that the given site is an instance of @YesodAuth@
--- and that its @AuthId@ is in fact a persistent @Key@ for the given value.
--- This is the common case in Yesod, and means that you can easily look up the
--- full informatin on a given user.
---
--- Since 1.2.0
-type YesodAuthPersist master =
- ( YesodAuth master
- , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))
- ~ PersistEntityBackend (AuthEntity master)
- , Key (AuthEntity master) ~ AuthId master
- , PersistStore (YesodPersistBackend master (HandlerT master IO))
- , PersistEntity (AuthEntity master)
- , YesodPersist master
- , Typeable (AuthEntity master)
- )
+newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
--- | If the @AuthId@ for a given site is a persistent ID, this will give the
--- value for that entity. E.g.:
+-- | Class which states that the given site is an instance of @YesodAuth@
+-- and that its @AuthId@ is a lookup key for the full user information in
+-- a @YesodPersist@ database.
--
--- > type AuthId MySite = UserId
--- > AuthEntity MySite ~ User
+-- The default implementation of @getAuthEntity@ assumes that the @AuthId@
+-- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the
+-- given value. This is the common case in Yesod, and means that you can
+-- easily look up the full information on a given user.
--
--- Since 1.2.0
-type AuthEntity master = KeyEntity (AuthId master)
+-- @since 1.4.0
+class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
+ -- | If the @AuthId@ for a given site is a persistent ID, this will give the
+ -- value for that entity. E.g.:
+ --
+ -- > type AuthId MySite = UserId
+ -- > AuthEntity MySite ~ User
+ --
+ -- @since 1.2.0
+ type AuthEntity master :: Type
+ type AuthEntity master = KeyEntity (AuthId master)
+ getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
+ => AuthId master -> m (Maybe (AuthEntity master))
+
+ default getAuthEntity
+ :: ( YesodPersistBackend master ~ backend
+ , PersistRecordBackend (AuthEntity master) backend
+ , Key (AuthEntity master) ~ AuthId master
+ , PersistStore backend
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => AuthId master -> m (Maybe (AuthEntity master))
+ getAuthEntity = liftHandler . runDB . get
+
+
+type family KeyEntity key
+type instance KeyEntity (Key x) = x
+
-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
--- authenticated.
+-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
--- Since 1.1.0
-requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
-requireAuthId = maybeAuthId >>= maybe redirectLogin return
+-- @since 1.1.0
+requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
+requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
--- authenticated.
+-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
--- Since 1.1.0
-requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
-requireAuth = maybeAuth >>= maybe redirectLogin return
+-- @since 1.1.0
+requireAuth :: ( YesodAuthPersist master
+ , val ~ AuthEntity master
+ , Key val ~ AuthId master
+ , PersistEntity val
+ , Typeable val
+ , MonadHandler m
+ , HandlerSite m ~ master
+ ) => m (Entity val)
+requireAuth = maybeAuth >>= maybe handleAuthLack return
-redirectLogin :: Yesod master => HandlerT master IO a
+-- | 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)
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => m (AuthId master, AuthEntity master)
+requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
+
+handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
+handleAuthLack = do
+ aj <- acceptsJson
+ if aj then notAuthenticated else redirectLogin
+
+redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin = do
y <- getYesod
- setUltDestCurrent
+ when (redirectToCurrent y) setUltDestCurrent
case authRoute y of
Just z -> redirect z
Nothing -> permissionDenied "Please configure authRoute"
@@ -440,10 +607,10 @@
renderMessage = renderAuthMessage
data AuthException = InvalidFacebookResponse
- deriving (Show, Typeable)
+ deriving Show
instance Exception AuthException
-instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
+instance YesodAuth master => YesodSubDispatch Auth master where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html
diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs
--- a/Yesod/Auth/BrowserId.hs
+++ b/Yesod/Auth/BrowserId.hs
@@ -1,8 +1,12 @@
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
+-- module is no longer recommended for use.
module Yesod.Auth.BrowserId
+ {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
( authBrowserId
, createOnClick, createOnClickOverride
, def
@@ -16,11 +20,10 @@
import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
-import Text.Hamlet (hamlet)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Control.Monad (when, unless)
-import Text.Julius (julius, rawJS)
+import Text.Julius (rawJS)
import Network.URI (uriPath, parseURI)
import Data.FileEmbed (embedFile)
import Data.ByteString (ByteString)
@@ -68,20 +71,21 @@
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
- master <- lift getYesod
audience <-
case bisAudience of
Just a -> return a
Nothing -> do
r <- getUrlRender
- return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
- memail <- lift $ checkAssertion audience assertion (authHttpManager master)
+ tm <- getRouteToParent
+ return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
+ manager <- authHttpManager
+ memail <- checkAssertion audience assertion manager
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent
- lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
- Just email -> lift $ setCredsRedirect Creds
+ loginErrorMessage (tm LoginR) "BrowserID login error."
+ Just email -> setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
@@ -114,7 +118,7 @@
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
@@ -163,5 +167,5 @@
-- name.
createOnClick :: BrowserIdSettings
-> (Route Auth -> Route master)
- -> WidgetT master IO Text
+ -> WidgetFor master Text
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing
diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs
--- a/Yesod/Auth/Dummy.hs
+++ b/Yesod/Auth/Dummy.hs
@@ -1,30 +1,77 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# 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.
+-- their identifier. This is not intended for real world use, just for
+-- testing. This plugin supports form submissions via JSON (since 1.6.8).
+--
+-- = Using the JSON Login Endpoint
+--
+-- We are assuming that you have declared `authRoute` as follows
+--
+-- @
+-- Just $ AuthR LoginR
+-- @
+--
+-- If you are using a different one, then you have to adjust the
+-- endpoint accordingly.
+--
+-- @
+-- Endpoint: \/auth\/page\/dummy
+-- Method: POST
+-- JSON Data: {
+-- "ident": "my identifier"
+-- }
+-- @
+--
+-- Remember to add the following headers:
+--
+-- - Accept: application\/json
+-- - Content-Type: application\/json
+
module Yesod.Auth.Dummy
( authDummy
) where
-import Yesod.Auth
-import Yesod.Form (runInputPost, textField, ireq)
-import Text.Hamlet (hamlet)
-import Yesod.Core
+import Data.Aeson.Types (Parser, Result (..))
+import qualified Data.Aeson.Types as A (parseEither, withObject)
+import Data.Text (Text)
+import Yesod.Auth
+import Yesod.Core
+import Yesod.Form (ireq, runInputPost, textField)
+identParser :: Value -> Parser Text
+identParser = A.withObject "Ident" (.: "ident")
+
authDummy :: YesodAuth m => AuthPlugin m
authDummy =
AuthPlugin "dummy" dispatch login
where
+ dispatch :: Text -> [Text] -> AuthHandler m TypedContent
dispatch "POST" [] = do
- ident <- lift $ runInputPost $ ireq textField "ident"
- lift $ setCredsRedirect $ Creds "dummy" ident []
+ (jsonResult :: Result Value) <- parseCheckJsonBody
+ eIdent <- case jsonResult of
+ Success val -> return $ A.parseEither identParser val
+ Error err -> return $ Left err
+ case eIdent of
+ Right ident ->
+ setCredsRedirect $ Creds "dummy" ident []
+ Left _ -> do
+ ident <- runInputPost $ ireq textField "ident"
+ setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound
url = PluginR "dummy" []
- login authToMaster =
+ login authToMaster = do
+ request <- getRequest
toWidget [hamlet|
$newline never