diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,126 @@ +## 1.7.1.6 + +* Bump upper bound on `yesod-form` to allow 1.7 + +## 1.7.1.3 + +* Support `persistent-2.11` [#8](https://github.com/paul-rouse/yesod-auth-hashdb/pull/8) + +## 1.7.1.2 + +* Fix test to allow use of persistent-template-2.8 + +## 1.7.1.1 + +* Fix test and relax upper bound for persistent-2.10 / persistent-template-2.7 +* Replace use of deprecated `requireJsonBody` + +## 1.7.1 + +* Relax upper bounds to allow persistent-2.9 (for GHC 8.6 versions of Stackage nightly) +* Remove testing of GHC below 8.0.2, and lts below 9 + +## 1.7 + +* Update for changes in yesod version 1.6, but retain compatibility with previous versions +* Remove support for GHC below 7.10, and lts below 6 + +## 1.6.2 + +* Use `PasswordStore` from `yesod-auth` instead of `pwstore-fast` (uses `cryptonite` instead of `cryptohash`) + +## 1.6.1 + +* Relax upper bound on persistent + +## 1.6.0.1 + +* Fix serious documentation layout problem caused by typo + +## 1.6 + +This release completes the breaking changes started in 1.5. For details +of upgrading, please see +[Upgrading.md](https://github.com/paul-rouse/yesod-auth-hashdb/blob/master/Upgrading.md). + +* Complete removal of compatibility with old databases designed for versions before 1.3 +* Add JSON support + +## 1.5.1.3 + +* Fix test failure with basic-prelude >= 0.6 (#6) + +## 1.5.1.2 + +* Relax upper bound to allow persistent-2.6 + +## 1.5.1.1 + +* Minor documentation improvement +* Reduce external-library dependencies for tests + +## 1.5.1 + +* Include CSRF token in default form + +## 1.5 + +This release can break both old code and old database entries. For details +of upgrading, please see +[Upgrading.md](https://github.com/paul-rouse/yesod-auth-hashdb/blob/master/Upgrading.md). + +* First phase of removing compatibility with old databases designed for versions before 1.3 +* Remove deprecated utilities (`getAuthIdHashDB` and pre-defined `User` data type) + +## 1.4.3 + +* Changes to work with persistent-2.5 + +## 1.4.2.2 + +* Relax upper bound to allow persistent-2.2.* + +## 1.4.2.1 + +* Add ChangeLog + +## 1.4.2 + +* Deprecate `getAuthIdHashDB` (see [#5](https://github.com/paul-rouse/yesod-auth-hashdb/issues/5)) + +## 1.4.1.2 + +* Use internationalized messages +* Increase `defaultStrength` + +## 1.4.1.1 + +* Minor documentation change + +## 1.4.1 + +* Expose additional validation function which does not need to read the database +* Deprecate compatibility with old data which includes a salt field + +## 1.4.0 + +* Changes for Yesod 1.4 + +## 1.3.2 + +* Documentation improvement + +## 1.3.1 + +* Optional custom login form +* Deprecate predefined `User` data type +* Changes for Persistent 2 + +## 1.3.0.1 + +* Version bounds +* Minor documentation changes + +## 1.3 + +* First release as a separate package, not part of yesod-auth diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -1,197 +1,219 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Auth.HashDB --- Copyright : (c) Patrick Brisbin 2010, Paul Rouse 2014 +-- Copyright : (c) Patrick Brisbin 2010, Paul Rouse 2014-2016 -- License : MIT -- -- Maintainer : Paul Rouse -- Stability : Stable -- Portability : Portable -- --- A yesod-auth AuthPlugin designed to look users up in Persist where --- their user id's and a hash of their password is stored. --- --- This module was removed from @yesod-auth-1.3.0.0@ and is now --- maintained separately. --- Versions of this module prior to @yesod-auth-1.3@ used a relatively weak --- hashing algorithm (a single round of SHA1) which does not provide --- adequate protection against an attacker who discovers the hashed passwords. --- See: . --- --- It has now been rewritten to use "Crypto.PasswordStore", but this has been --- done in a way which preserves compatibility both with the API and --- with databases which have been set up using older versions of this module. --- There are two levels of database compatibility: --- --- * The verification code recognises both the old and new hash formats, --- so passwords can be verified against database entries which still --- contain old-style hashes. --- --- * The function 'upgradePasswordHash' can be used to migrate --- existing user records to use the new format hash. Unlike --- freshly created password hashes, entries converted this way --- must still have the old salt field, since the old hash function --- remains part of the algorithm needed for verification. (The --- new hash is layered on top of the old one.) --- --- On the other hand, new passwords set up by 'setPassword' or --- 'setPasswordStrength' no longer use a separate salt field, so new users --- of this module need only provide a single password field in the user data, --- and can ignore the salt. +-- A Yesod authentication plugin designed to look users up in a Persistent +-- database where the hash of their password is stored. -- --- In a system which has been migrated from the old format, passwords --- which are reset using the new format will have an empty salt field. --- Once all the entries are of this form, it is safe to change the model --- to remove the salt, and change the 'HashDBUser' instance accordingly. +-- __Releases 1.6 finishes the process of removing compatibility with old__ +-- __(pre 1.3) databases. Please see__ +-- ____ -- --- To use this in a Yesod application, it must be an instance of --- YesodPersist, and the username and hashed-passwords should be added --- to the database. The followng steps give an outline of what is required. +-- To use this in a Yesod application, the foundation data type must be an +-- instance of YesodPersist, and the username and hashed passwords should +-- be added to the database. The following steps give an outline of what +-- is required. -- -- You need a database table to store user records: in a scaffolded site it -- might look like: -- -- > User --- > name Text -- user name used by HashDB +-- > name Text -- user name used to uniquely identify users -- > password Text Maybe -- password hash for HashDB -- > UniqueUser name -- -- Create an instance of 'HashDBUser' for this data type: -- +-- > import Yesod.Auth.HashDB (HashDBUser(..)) +-- > .... -- > instance HashDBUser User where -- > userPasswordHash = userPassword --- > setPasswordHash h p = p { userPassword = Just h } +-- > setPasswordHash h u = u { userPassword = Just h } -- -- In the YesodAuth instance declaration for your app, include 'authHashDB' -- like so: -- +-- > import Yesod.Auth.HashDB (authHashDB) +-- > .... -- > instance YesodAuth App where -- > .... -- > authPlugins _ = [ authHashDB (Just . UniqueUser), .... ] --- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser) +-- > getAuthId creds = ... -- Perhaps modify scaffolding: see below -- --- @AuthR@ should be your authentication route, and the function --- @(Just . UniqueUser)@ supplied to both 'authHashDB' and --- 'getAuthIdHashDB' takes a 'Text' and produces a 'Unique' value to --- look up in the User table. 'getAuthIdHashDB' is just a convenience --- for the case when 'HashDB' is the only plugin, and something else --- would be needed when other plugins are used as well. +-- The argument to 'authHashDB' is a function which takes a 'Text' and +-- produces a 'Maybe' containing a 'Unique' value to look up in the User +-- table. The example @(Just . UniqueUser)@ shown here works for the +-- model outlined above. -- --- You can create password hashes manually as follows, if you need to --- initialise the database: +-- In the scaffolding, the definition of @getAuthId@ contains code to +-- add a user who is not already in the database. Depending on how users +-- are administered, this may not make sense when using HashDB, so consider +-- whether it should be removed. -- +-- For a real application, the developer should provide some sort of +-- of administrative interface for setting passwords; it needs to call +-- 'setPassword' and save the result in the database. However, if you +-- need to initialise the database by hand, you can generate the correct +-- password hash as follows: +-- -- > ghci -XOverloadedStrings --- > > import Crypto.PasswordStore --- > > makePassword "MyPassword" 14 +-- > > import Yesod.Auth.Util.PasswordStore +-- > > makePassword "MyPassword" 17 -- --- where \"14\" is the default strength parameter used in this module. +-- where \"17\" is the default strength parameter ('defaultStrength') used +-- in this module. -- +-- == Custom Login Form +-- +-- Instead of using the built-in HTML form, a custom one can be supplied +-- by using 'authHashDBWithForm' instead of 'authHashDB'. +-- +-- The custom form needs to be given as a function returning a Widget, since +-- it has to build in the supplied "action" URL, and it must provide two text +-- fields called "username" and "password". For example, the following +-- modification of the outline code given above would replace the default +-- form with a very minimal one which has no labels and a simple layout. +-- +-- > instance YesodAuth App where +-- > .... +-- > authPlugins _ = [ authHashDBWithForm myform (Just . UniqueUser), .... ] +-- > +-- > myform :: Route App -> Widget +-- > myform action = $(whamletFile "templates/loginform.hamlet") +-- +-- where templates/loginform.hamlet contains +-- +-- >
+-- > +-- > +-- > +-- +-- If a CSRF token needs to be embedded in a custom form, code must be +-- included in the widget to add it - see @defaultForm@ in the source +-- code of this module for an example. +-- +-- == JSON Interface +-- +-- This plugin provides sufficient tools to build a complete JSON-based +-- authentication flow. We assume that a design goal is to avoid URLs +-- being built into the client, so all of the URLs needed are passed in +-- JSON data. +-- +-- To start the process, Yesod's defaultErrorHandler produces a JSON +-- response if the HTTP Accept header gives \"application/json\" +-- precedence over HTML. For a NotAuthenticated error, the status is +-- 401 and the response contains the URL to use for authentication: this +-- is the route which will be handled by the loginHandler method of the +-- YesodAuth instance, which normally returns a login form. +-- +-- Leaving the loginHandler aside for a moment, the final step - supported +-- by this plugin since version 1.6 - is to POST the credentials for +-- authentication in a JSON object. This object must include the +-- properties "username" and "password". In the HTML case this would be +-- the form submission, but here we want to use JSON instead. +-- +-- In a JSON interface, the purpose of the loginHandler is to tell the +-- client the URL for submitting the credentials. This requires a +-- custom loginHandler, since the default one generates HTML only. +-- It can find the correct URL by using the 'submitRouteHashDB' +-- function defined in this module. +-- +-- Writing the loginHandler is made a little messy by the fact that its +-- type allows only HTML content. A work-around is to send JSON as a +-- short-circuit response, but we still make the choice using selectRep +-- so as to get its matching of content types. Here is an example which +-- is geared around using HashDB on its own, supporting both JSON and HTML +-- clients: +-- +-- > instance YesodAuth App where +-- > .... +-- > loginHandler = do +-- > submission <- submitRouteHashDB +-- > render <- lift getUrlRender +-- > typedContent@(TypedContent ct _) <- selectRep $ do +-- > provideRepType typeHtml $ return emptyContent +-- > -- Dummy: the real Html version is at the end +-- > provideJson $ object [("loginUrl", toJSON $ render submission)] +-- > when (ct == typeJson) $ +-- > sendResponse typedContent -- Short-circuit JSON response +-- > defaultLoginHandler -- Html response +-- ------------------------------------------------------------------------------- module Yesod.Auth.HashDB ( HashDBUser(..) - , Unique (..) , defaultStrength , setPasswordStrength , setPassword + , validatePass , upgradePasswordHash - -- * Authentication + -- * Interface to database and Yesod.Auth , validateUser , authHashDB - , getAuthIdHashDB - -- * Predefined data type - , User - , UserGeneric (..) - , UserId - , EntityField (..) - , migrateUsers + , authHashDBWithForm + , submitRouteHashDB ) where -import Yesod.Persist -import Yesod.Form -import Yesod.Auth -import Yesod.Core -import Control.Applicative ((<$>), (<*>)) -import Data.Typeable - +import Yesod.Auth.Util.PasswordStore (makePassword, strengthenPassword, + verifyPassword, passwordStrength) +import Data.Aeson ((.:?)) import qualified Data.ByteString.Char8 as BS (pack, unpack) -import qualified Crypto.Hash as CH (SHA1, Digest, hash) -import Data.Text (Text, pack, unpack, append) -import Data.Maybe (fromMaybe) -import Crypto.PasswordStore (makePassword, verifyPassword, - passwordStrength, strengthenPassword) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, unpack) +import Yesod.Auth +import qualified Yesod.Auth.Message as Msg +import Yesod.Core +import Yesod.Form +import Yesod.Persist --- | Default strength used for passwords (see "Crypto.PasswordStore" for --- details). -defaultStrength :: Int -defaultStrength = 14 +#if !MIN_VERSION_yesod_core(1,6,0) +type HandlerFor site a = HandlerT site IO a +type WidgetFor site a = WidgetT site IO () +#define liftHandler lift +#endif --- | Interface for data type which holds user info. It's just a --- collection of getters and setters -class HashDBUser user where - -- | Retrieve password hash from user data - userPasswordHash :: user -> Maybe Text - -- | Retrieve salt for password from user data. This is needed only for - -- compatibility with old database entries, which contain the salt - -- as a separate field. New implementations do not require a separate - -- salt field in the user data, and should leave this as the default. - userPasswordSalt :: user -> Maybe Text - userPasswordSalt _ = Just "" +#if !MIN_VERSION_yesod_core(1,6,11) +#define requireInsecureJsonBody requireJsonBody +#endif - -- | Callback for 'setPassword' and 'upgradePasswordHash'. Produces a - -- version of the user data with the hash set to the new value. - -- - -- This is the method which you should define for new applications, which - -- do not require compatibility with databases containing hashes written - -- by previous versions of this module. If you do need compatibility, - -- define 'setSaltAndPasswordHash' instead. - setPasswordHash :: Text -- ^ Password hash - -> user -> user - setPasswordHash = setSaltAndPasswordHash "" +-- | Default strength used for passwords (see "Yesod.Auth.Util.PasswordStore" +-- for details). +defaultStrength :: Int +defaultStrength = 17 - setUserHashAndSalt :: Text -- ^ Salt - -> Text -- ^ Password hash - -> user -> user - setUserHashAndSalt = - error "Define setSaltAndPasswordHash to get old-database compatibility" +-- | The type representing user information stored in the database should +-- be an instance of this class. It just provides the getter and setter +-- used by the functions in this module. +class HashDBUser user where + -- | Getter used by 'validatePass' and 'upgradePasswordHash' to + -- retrieve the password hash from user data + -- + userPasswordHash :: user -> Maybe Text - -- | Callback used in 'upgradePasswordHash' when compatibility is needed - -- with old-style hashes (including ones already upgraded using - -- 'upgradePasswordHash'). This is not required for new applications, - -- which do not have a separate salt field in user data: please define - -- 'setPasswordHash' instead. - -- - -- The default implementation produces a runtime error, and will only be - -- called if a non-empty salt value needs to be set for compatibility - -- with an old database. - setSaltAndPasswordHash :: Text -- ^ Salt - -> Text -- ^ Password hash - -> user -> user - setSaltAndPasswordHash = setUserHashAndSalt + -- | Setter used by 'setPassword' and 'upgradePasswordHash'. Produces a + -- version of the user data with the hash set to the new value. + -- + setPasswordHash :: Text -- ^ Password hash + -> user -> user - {-# MINIMAL userPasswordHash, (setPasswordHash | (userPasswordSalt, setSaltAndPasswordHash)) #-} -{-# DEPRECATED setUserHashAndSalt "Please use setSaltAndPasswordHash instead" #-} + {-# MINIMAL userPasswordHash, setPasswordHash #-} --- | Calculate salted hash using SHA1. Retained for compatibility with --- hashes in existing databases, but will not be used for new passwords. -saltedHash :: Text -- ^ Salt - -> Text -- ^ Password - -> Text -saltedHash salt pw = - pack $ show (CH.hash $ BS.pack $ unpack $ append salt pw :: CH.Digest CH.SHA1) - --- | Calculate a new-style password hash using "Crypto.PasswordStore". +-- | Calculate a new-style password hash using "Yesod.Auth.Util.PasswordStore". passwordHash :: MonadIO m => Int -> Text -> m Text passwordHash strength pwd = do h <- liftIO $ makePassword (BS.pack $ unpack pwd) strength @@ -202,6 +224,9 @@ -- hashed password. Unlike previous versions of this module, no separate -- salt field is required for new passwords (but it may still be required -- for compatibility while old password hashes remain in the database). +-- +-- This function does not change the database; the calling application +-- is responsible for saving the data which is returned. setPasswordStrength :: (MonadIO m, HashDBUser user) => Int -> Text -> user -> m user setPasswordStrength strength pwd u = do hashed <- passwordHash strength pwd @@ -211,81 +236,104 @@ setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user setPassword = setPasswordStrength defaultStrength +-- | Validate a plaintext password against the hash in the user data structure. +-- +-- The result distinguishes two types of validation failure, which may +-- be useful in an application which supports multiple authentication +-- methods: +-- +-- * Just False - the user has a password set up, but the given one does +-- not match it +-- +-- * Nothing - the user does not have a password ('userPasswordHash' returns +-- Nothing) +-- +-- Since 1.4.1 +-- +validatePass :: HashDBUser u => u -> Text -> Maybe Bool +validatePass user passwd = do + hash <- userPasswordHash user + -- NB plaintext password characters are truncated to 8 bits here, + -- and also in passwordHash above (the hash is already 8 bit). + -- This is for historical compatibility, but in practice it is + -- unlikely to reduce the entropy of most users' alphabets by much. + let hash' = BS.pack $ unpack hash + passwd' = BS.pack $ unpack passwd + if passwordStrength hash' > 0 + -- Will give >0 for valid hash format, else treat as if wrong password + then return $ verifyPassword passwd' hash' + else return False + -- | Upgrade existing user credentials to a stronger hash. The existing --- hash may have been produced either by previous versions of this module, --- which used a weak algorithm, or from a weaker setting in the current +-- hash will have been produced from a weaker setting in the current -- algorithm. Use this function to produce an updated user record to -- store in the database. -- --- To allow transitional use, starting from hashes produced by older --- versions of this module, and upgrading them to the new format, --- we have to use the hash alone, without knowledge of the user's --- plaintext password. In this case, we apply the new algorithm to the --- old hash, resulting in both hash functions, old and new, being used --- one on top of the other; this situation is recognised by the hash --- having the new format while the separate salt field is non-empty. +-- As of version 1.5 this function cannot be used to upgrade a hash +-- which has a non-empty separate salt field. Such entries would have +-- been produced originally by versions of this module prior to 1.3, +-- but may have been upgraded using earlier versions of this function. -- -- Returns Nothing if the user has no password (ie if 'userPasswordHash' u --- is 'Nothing' and/or 'userPasswordSalt' u is 'Nothing'). +-- is 'Nothing') or if the password hash is not in the correct format. +-- upgradePasswordHash :: (MonadIO m, HashDBUser user) => Int -> user -> m (Maybe user) upgradePasswordHash strength u = do - let old = do h <- userPasswordHash u - s <- userPasswordSalt u - return (h, s) + let old = userPasswordHash u case old of - Just (oldHash, oldSalt) -> do + Just oldHash -> do let oldHash' = BS.pack $ unpack oldHash if passwordStrength oldHash' > 0 then - -- Already a new-style hash, so only strengthen it as needed + -- Valid hash format, so strengthen it as needed let newHash = pack $ BS.unpack $ strengthenPassword oldHash' strength - in if oldSalt == "" - then return $ Just $ setPasswordHash newHash u - else return $ Just $ setSaltAndPasswordHash oldSalt newHash u + in return $ Just $ setPasswordHash newHash u else do - -- Old-style hash: do extra layer of hash with the new algorithm - newHash <- passwordHash strength oldHash - return $ Just $ setSaltAndPasswordHash oldSalt newHash u + -- Invalid hash format (perhaps from old version of this module) + return Nothing Nothing -> return Nothing ---------------------------------------------------------------- --- Authentication +-- Interface to database and Yesod.Auth ---------------------------------------------------------------- +-- | Constraint for types of interface functions in this module +-- +type HashDBPersist master user = + ( YesodAuthPersist master + , PersistUnique (YesodPersistBackend master) + , AuthEntity master ~ user +#if MIN_VERSION_persistent(2,5,0) + , PersistEntityBackend user ~ BaseBackend (YesodPersistBackend master) +#else + , PersistEntityBackend user ~ YesodPersistBackend master +#endif + , HashDBUser user + , PersistEntity user + ) + +-- Internal data type for receiving JSON encoded username and password +data UserPass = UserPass (Maybe Text) (Maybe Text) + +instance FromJSON UserPass where + parseJSON (Object v) = UserPass <$> + v .:? "username" <*> + v .:? "password" + parseJSON _ = pure $ UserPass Nothing Nothing + -- | Given a user ID and password in plaintext, validate them against --- the database values. This function retains compatibility with --- databases containing hashes produced by previous versions of this --- module, although they are less secure and should be upgraded as --- soon as possible. They can be upgraded using 'upgradePasswordHash', --- or by insisting that users set new passwords. -validateUser :: ( YesodPersist yesod - , b ~ YesodPersistBackend yesod - , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user - , PersistUnique (b (HandlerT yesod IO)) - , PersistEntity user - , HashDBUser user - ) => +-- the database values. This function simply looks up the user id in the +-- database and calls 'validatePass' to do the work. +-- +validateUser :: HashDBPersist site user => Unique user -- ^ User unique identifier - -> Text -- ^ Password in plaint-text - -> HandlerT yesod IO Bool + -> Text -- ^ Password in plaintext + -> HandlerFor site Bool validateUser userID passwd = do - -- Checks that hash and password match - let validate u = do hash <- userPasswordHash u - salt <- userPasswordSalt u - let hash' = BS.pack $ unpack hash - passwd' = BS.pack $ unpack - $ if salt == "" then passwd - else - -- Extra layer for an upgraded old hash - saltedHash salt passwd - if passwordStrength hash' > 0 - -- Will give >0 for new-style hash, else fall back - then return $ verifyPassword passwd' hash' - else return $ hash == saltedHash salt passwd - -- Get user data - user <- runDB $ getBy userID - return $ fromMaybe False $ validate . entityVal =<< user + -- Get user data + user <- runDB $ getBy userID + return $ fromMaybe False $ flip validatePass passwd . entityVal =<< user login :: AuthRoute @@ -294,116 +342,104 @@ -- | Handle the login form. First parameter is function which maps -- username (whatever it might be) to unique user ID. -postLoginR :: ( YesodAuth y, YesodPersist y - , HashDBUser user, PersistEntity user - , b ~ YesodPersistBackend y - , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user - , PersistUnique (b (HandlerT y IO)) - ) - => (Text -> Maybe (Unique user)) - -> HandlerT Auth (HandlerT y IO) TypedContent +-- +-- Since version 1.6, the data may be submitted as a JSON object. +-- See the \"JSON Interface\" section above for more details. +postLoginR :: HashDBPersist site user => + (Text -> Maybe (Unique user)) + -> AuthHandler site TypedContent postLoginR uniq = do - (mu,mp) <- lift $ runInputPost $ (,) - <$> iopt textField "username" - <*> iopt textField "password" + ct <- lookupHeader "Content-Type" + let jsonContent = ((== "application/json") . simpleContentType) <$> ct + UserPass mu mp <- + case jsonContent of + Just True -> requireInsecureJsonBody -- We already know content type! + _ -> liftHandler $ runInputPost $ UserPass + <$> iopt textField "username" + <*> iopt textField "password" - isValid <- lift $ fromMaybe (return False) + isValid <- liftHandler $ fromMaybe (return False) (validateUser <$> (uniq =<< mu) <*> mp) if isValid - then lift $ setCredsRedirect $ Creds "hashdb" (fromMaybe "" mu) [] - else do - tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) "Invalid username/password" + then liftHandler $ setCredsRedirect $ Creds "hashdb" (fromMaybe "" mu) [] + else loginErrorMessageI LoginR Msg.InvalidUsernamePass --- | A drop in for the getAuthId method of your YesodAuth instance which --- can be used if authHashDB is the only plugin in use. -getAuthIdHashDB :: ( YesodAuth master, YesodPersist master - , HashDBUser user, PersistEntity user - , Key user ~ AuthId master - , b ~ YesodPersistBackend master - , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user - , PersistUnique (b (HandlerT master IO)) - ) - => (AuthRoute -> Route master) -- ^ your site's Auth Route - -> (Text -> Maybe (Unique user)) -- ^ gets user ID - -> Creds master -- ^ the creds argument - -> HandlerT master IO (Maybe (AuthId master)) -getAuthIdHashDB authR uniq creds = do - muid <- maybeAuthId - case muid of - -- user already authenticated - Just uid -> return $ Just uid - Nothing -> do - x <- case uniq (credsIdent creds) of - Nothing -> return Nothing - Just u -> runDB (getBy u) - case x of - -- user exists - Just (Entity uid _) -> return $ Just uid - Nothing -> do - _ <- loginErrorMessage (authR LoginR) "User not found" - return Nothing - -- | Prompt for username and password, validate that against a database -- which holds the username and a hash of the password -authHashDB :: ( YesodAuth m, YesodPersist m - , HashDBUser user - , PersistEntity user - , b ~ YesodPersistBackend m - , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user - , PersistUnique (b (HandlerT m IO))) - => (Text -> Maybe (Unique user)) -> AuthPlugin m -authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet| -$newline never -