yesod-auth-hashdb 1.3.0.1 → 1.7.1.7
raw patch · 13 files changed
Files
- ChangeLog.md +126/−0
- Yesod/Auth/HashDB.hs +316/−280
- stack.yaml +4/−0
- test/ExampleData.hs +92/−0
- test/IntegrationTest.hs +131/−0
- test/NonDBTests.hs +100/−0
- test/TestSite.hs +151/−0
- test/TestTools.hs +145/−0
- test/integration.hs +30/−0
- test/main.hs +7/−0
- test/stack.yaml +7/−0
- test/standalone-testsite.cabal +38/−0
- yesod-auth-hashdb.cabal +76/−13
+ ChangeLog.md view
@@ -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
Yesod/Auth/HashDB.hs view
@@ -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 <pyr@doynton.org> -- 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: <https://github.com/yesodweb/yesod/issues/668>.------ 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__+-- __<https://github.com/paul-rouse/yesod-auth-hashdb/blob/master/Upgrading.md>__ ----- 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+--+-- > <form method="post" action="@{action}">+-- > <input name="username">+-- > <input type="password" name="password">+-- > <input type="submit" value="Login">+--+-- 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- <div id="header">- <h1>Login+authHashDB :: HashDBPersist site user =>+ (Text -> Maybe (Unique user)) -> AuthPlugin site+authHashDB = authHashDBWithForm defaultForm - <div id="login">- <form method="post" action="@{tm login}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login"> - <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }--|]+-- | Like 'authHashDB', but with an extra parameter to supply a custom HTML+-- form.+--+-- The custom form should be specified as a function which takes a route to+-- use as the form action, and returns a Widget containing the form. The+-- form must use the supplied route as its action URL, and, when submitted,+-- it must send two text fields called "username" and "password".+--+-- Please see the example in the documentation at the head of this module.+--+-- Since 1.3.2+--+authHashDBWithForm :: forall site user.+ HashDBPersist site user =>+ (Route site -> WidgetFor site ())+ -> (Text -> Maybe (Unique user))+ -> AuthPlugin site+authHashDBWithForm form uniq =+ AuthPlugin "hashdb" dispatch $ \tm -> form (tm login) where+ dispatch :: Text -> [Text] -> AuthHandler site TypedContent dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse dispatch _ _ = notFound -------------------------------------------------------------------- Predefined datatype-----------------------------------------------------------------+defaultForm :: Yesod app => Route app -> WidgetFor app ()+defaultForm loginRoute = do+ request <- getRequest+ let mtok = reqToken request+ toWidget [hamlet|+ $newline never+ <div id="header">+ <h1>Login --- | Generate data base instances for a valid user-share [mkPersist sqlSettings, mkMigrate "migrateUsers"]- [persistUpperCase|-User- username Text Eq- password Text- salt Text- UniqueUser username- deriving Typeable-|]+ <div id="login">+ <form method="post" action="@{loginRoute}">+ $maybe tok <- mtok+ <input type=hidden name=#{defaultCsrfParamName} value=#{tok}>+ <table>+ <tr>+ <th>Username:+ <td>+ <input id="x" name="username" autofocus="" required>+ <tr>+ <th>Password:+ <td>+ <input type="password" name="password" required>+ <tr>+ <td> + <td>+ <input type="submit" value="Login"> -instance HashDBUser (UserGeneric backend) where- userPasswordHash = Just . userPassword- userPasswordSalt = Just . userSalt- setSaltAndPasswordHash s h u = u { userSalt = s- , userPassword = h- }+ <script>+ if (!("autofocus" in document.createElement("input"))) {+ document.getElementById("x").focus();+ }++ |]+++-- | The route, in the parent site, to which the username and password+-- should be sent in order to log in. This function is particularly+-- useful in constructing a 'loginHandler' function which provides a+-- JSON response. See the \"JSON Interface\" section above for more+-- details.+--+-- Since 1.6+submitRouteHashDB :: YesodAuth site => AuthHandler site (Route site)+submitRouteHashDB = do+ toParent <- getRouteToParent+ return $ toParent login
+ stack.yaml view
@@ -0,0 +1,4 @@+resolver: lts-17.9+packages:+- .+extra-deps: []
+ test/ExampleData.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+module ExampleData (+ OldStyleUser (..),+ NewStyleUser (..),+ mypassword,+ changedpw,+ equivpassword,+ equivchangedpw,+ oldStyleValidUser,+ oldStyleBadUser1,+ oldStyleBadUser2,+ oldStyleUpgradedUser,+ newStyleValidUser,+ newStyleBadUser,+ stronger+) where++import Yesod.Auth.HashDB (HashDBUser(..), defaultStrength)+import Data.Text (Text)++-- OldStyleUser is retained in the tests so that naive (incorrect)+-- upgrading can be tested; the naive upgrade consists of removing+-- the `userPasswordSalt` method without setting new passwords which+-- have empty salt.+data OldStyleUser = OldStyleUser {+ oldStyleName :: Text,+ oldStylePass :: Maybe Text,+ oldStyleSalt :: Maybe Text+ } deriving (Eq, Show)++instance HashDBUser OldStyleUser where+ userPasswordHash = oldStylePass+ setPasswordHash h u = u { oldStyleSalt = Just "",+ oldStylePass = Just h+ }++data NewStyleUser = NewStyleUser {+ newStyleName :: Text,+ newStylePass :: Maybe Text+ } deriving (Eq, Show)++instance HashDBUser NewStyleUser where+ userPasswordHash = newStylePass+ setPasswordHash h u = u { newStylePass = Just h }++mypassword :: Text+mypassword = "mypassword"+changedpw :: Text+changedpw = "changedpw"++-- These are equivalent to the above if each character is truncated to 8 bits+equivpassword :: Text+equivpassword = "\x46d\x479\x470\x461\x473\x473\x477\x46f\x472\x464"+equivchangedpw :: Text+equivchangedpw = "\xbc63\xbc68\xbc61\xbc6e\xbc67\xbc65\xbc64\xbc70\xbc77"++oldStyleValidUser :: OldStyleUser+oldStyleValidUser =+ OldStyleUser "foo"+ (Just "8e3e33029e71b4e25ba95a00a88c4bfeb93d766a")+ (Just "somesalt")++oldStyleBadUser1 :: OldStyleUser+oldStyleBadUser1 =+ OldStyleUser "bar"+ Nothing+ (Just "pepper")++oldStyleBadUser2 :: OldStyleUser+oldStyleBadUser2 =+ OldStyleUser "baz"+ (Just "8e3e33029e71b4e25ba95a00a88c4bfeb93d766a")+ Nothing++oldStyleUpgradedUser :: OldStyleUser+oldStyleUpgradedUser =+ OldStyleUser "foo"+ (Just "sha256|17|GkImOI0oV9RyOE3oJpYKRg==|KPPYL9JaP6UQjwLVvRsK3Pw2tl1LWyjqlh11jjKRQVM=")+ (Just "somesalt")++newStyleValidUser :: NewStyleUser+newStyleValidUser =+ NewStyleUser "fox"+ (Just "sha256|14|2hL7cNopkA/dGy/5CQTuSg==|CUTPW6ICMISSjohFep851f9PdqIn7Y4B75/I77BvEYM=")++newStyleBadUser :: NewStyleUser+newStyleBadUser =+ NewStyleUser "bad"+ Nothing++stronger :: Int+stronger = defaultStrength + 2
+ test/IntegrationTest.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module IntegrationTest (+ withApp,+ integrationSpec+) where++import BasicPrelude+import Data.Aeson (FromJSON, parseJSON, (.:))+import qualified Data.Aeson as JSON+import Network.Wai.Test (simpleBody)+import Test.Hspec (Spec, SpecWith, before,+ describe, it)+import qualified Yesod.Test as YT++import TestSite (App, Route(..))+import TestTools++type MyTestApp = YT.TestApp App+withApp :: App -> SpecWith (YT.TestApp App) -> Spec+withApp app = before $ return (app, id)++authUrl :: Text+authUrl = "http://localhost:3000/auth/login"++data AuthUrl = AuthUrl Text deriving (Eq, Show)+instance FromJSON AuthUrl where+ parseJSON (JSON.Object v) = AuthUrl <$> v .: "authentication_url"+ parseJSON _ = mempty++loginUrl :: Text+loginUrl = "http://localhost:3000/auth/page/hashdb/login"++data LoginUrl = LoginUrl Text deriving (Eq, Show)+instance FromJSON LoginUrl where+ parseJSON (JSON.Object v) = LoginUrl <$> v .: "loginUrl"+ parseJSON _ = mempty++successMsg :: Text+successMsg = "Login Successful"++data SuccessMsg = SuccessMsg Text deriving (Eq, Show)+instance FromJSON SuccessMsg where+ parseJSON (JSON.Object v) = SuccessMsg <$> v .: "message"+ parseJSON _ = mempty++getBodyJSON :: FromJSON a => YT.YesodExample site (Maybe a)+getBodyJSON = do+ resp <- YT.getResponse+ let body = simpleBody <$> resp+ result = JSON.decode =<< body+ return result++integrationSpec :: SpecWith MyTestApp+integrationSpec = do+ describe "The home page" $ do+ it "can be accessed" $ do+ YT.get HomeR+ YT.statusIs 200++ describe "The protected page" $ do+ it "requires login" $ do+ needsLogin GET ("/prot" :: Text)+ it "looks right after login by a valid user" $ do+ _ <- doLogin "paul" "MyPassword"+ YT.get ProtectedR+ YT.statusIs 200+ YT.bodyContains "OK, you are logged in so you are allowed to see this!"+ it "can't be accessed after login then logout" $ do+ _ <- doLogin "paul" "MyPassword"+ YT.get $ AuthR LogoutR+ -- That `get` will get the form from Yesod.Core.Handler.redirectToPost+ -- which will not be submitted automatically without javascript+ YT.bodyContains "please click on the button below to be redirected"+ -- so we do the redirection ourselves:+ YT.request $ do+ YT.setMethod "POST"+ YT.setUrl $ AuthR LogoutR+ -- yesod-core-1.4.19 added the CSRF token to the redirectToPost form+ YT.addToken+ YT.get HomeR+ YT.statusIs 200+ YT.bodyContains "Your current auth ID: Nothing"+ YT.get ProtectedR+ YT.statusIs 303++ describe "Login" $ do+ it "fails when incorrect password given" $ do+ loc <- doLoginPart1 "paul" "WrongPassword"+ checkFailedLogin loc+ it "fails when unknown user name given" $ do+ loc <- doLoginPart1 "xyzzy" "WrongPassword"+ checkFailedLogin loc++ describe "JSON Login" $ do+ it "JSON access to protected page gives JSON object with auth URL" $ do+ YT.request $ do+ YT.setMethod "GET"+ YT.setUrl ProtectedR+ YT.addRequestHeader ("Accept", "application/json")+ YT.statusIs 401+ auth <- getBodyJSON+ YT.assertEq "Authentication URL" auth (Just $ AuthUrl authUrl)+ it "Custom loginHandler using submitRouteHashDB has correct URL in JSON" $ do+ YT.request $ do+ YT.setMethod "GET"+ YT.setUrl authUrl+ YT.addRequestHeader ("Accept", "application/json")+ YT.statusIs 200+ login <- getBodyJSON+ YT.assertEq "Login URL" login (Just $ LoginUrl loginUrl)+ -- This example needs yesod-test >= 1.5.0.1, since older ones use wrong+ -- content type for JSON (https://github.com/yesodweb/yesod/issues/1063).+ it "Sending JSON username and password produces JSON success message" $ do+ -- This first request is only to get the CSRF token cookie, used below+ YT.request $ do+ YT.setMethod "GET"+ YT.setUrl authUrl+ YT.addRequestHeader ("Accept", "application/json")+ YT.request $ do+ YT.setMethod "POST"+ YT.setUrl loginUrl+ YT.addRequestHeader ("Accept", "application/json")+ YT.addRequestHeader ("Content-Type", "application/json; charset=utf-8")+ YT.setRequestBody "{\"username\":\"paul\",\"password\":\"MyPassword\"}"+ -- CSRF token is being checked, since yesod-core >= 1.4.14 is forced+ YT.addTokenFromCookie+ YT.statusIs 200+ msg <- getBodyJSON+ YT.assertEq "Login success" msg (Just $ SuccessMsg successMsg)
+ test/NonDBTests.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+module NonDBTests (+ nonDBTests+) where++import Test.Hspec+import Yesod.Auth.HashDB+import Data.Text (pack, isInfixOf)++import ExampleData++-- For consistent layout of "it" items, we sometimes have a redundant "do":+{-# ANN nonDBTests ("HLint: ignore Redundant do"::String) #-}++nonDBTests :: Spec+nonDBTests = do++ describe "validatePass" $ do++ context "Naively upgraded old-style valid user" $ do+ it "no longer checks good password (wrong format, so Just False)" $+ validatePass oldStyleValidUser mypassword `shouldBe` Just False+ it "no longer checks bad password (wrong format, so Just False)" $+ validatePass oldStyleValidUser changedpw `shouldBe` Just False++ context "Naively upgraded old-style user with no password hash" $ do+ it "fails validation giving Nothing" $+ validatePass oldStyleBadUser1 mypassword `shouldBe` Nothing++ context "Naively upgraded old-style user with no salt" $ do+ it "fails validation (wrong format, so Just False)" $+ validatePass oldStyleBadUser2 mypassword `shouldBe` Just False++ context "Previously upgraded old-style user" $ do+ it "no longer verifies with correct password as it still needs salt" $+ validatePass oldStyleUpgradedUser mypassword `shouldBe` Just False+ it "fails validation with a wrong password giving Just False" $+ validatePass oldStyleUpgradedUser changedpw `shouldBe` Just False++ context "New style valid user" $ do+ it "verifies OK with correct password" $+ validatePass newStyleValidUser mypassword `shouldBe` Just True+ it "fails validation with a wrong password giving Just False" $+ validatePass newStyleValidUser changedpw `shouldBe` Just False++ context "New-style user with no password hash" $ do+ it "fails validation giving Nothing" $+ validatePass newStyleBadUser mypassword `shouldBe` Nothing+++ describe "upgradePasswordHash" $ do++ context "Upgrade of naively upgraded old-style password hash" $ do+ it "is Nothing if the user has a password (format is wrong)" $ do+ newuser <- upgradePasswordHash defaultStrength oldStyleValidUser+ newuser `shouldBe` Nothing+ it "is Nothing if there is no password hash" $ do+ newuser <- upgradePasswordHash defaultStrength oldStyleBadUser1+ newuser `shouldBe` Nothing++ context "Upgrade of previously upgraded old-style user" $ do+ it "silently succeeds producing a password which won't verify as it still needs salt" $ do+ newuser <- upgradePasswordHash defaultStrength oldStyleUpgradedUser+ case newuser of+ Nothing -> expectationFailure "should not produce Nothing"+ Just u -> validatePass u mypassword `shouldBe` Just False++ context "Upgrade of new-style password hash to stronger setting" $ do+ it "really does have a hash containing the new strength" $ do+ newuser <- upgradePasswordHash stronger newStyleValidUser+ let s = pack $ "|" ++ show stronger ++ "|"+ found = fmap (s `isInfixOf`) $ newuser >>= newStylePass+ found `shouldBe` Just True+ it "still verifies with the same password" $ do+ newuser <- upgradePasswordHash stronger newStyleValidUser+ let valid = newuser >>= flip validatePass mypassword+ valid `shouldBe` Just True+ it "is Nothing if there is no password hash" $ do+ newuser <- upgradePasswordHash stronger newStyleBadUser+ newuser `shouldBe` Nothing+++ describe "setPassword" $ do+ it "produces hash which verifies OK starting from old-style user" $ do+ newuser <- setPassword changedpw oldStyleValidUser+ validatePass newuser changedpw `shouldBe` Just True+ it "produces empty salt (in the case of old-style user)" $ do+ newuser <- setPassword changedpw oldStyleValidUser+ oldStyleSalt newuser `shouldBe` Just ""+ it "produces hash which verifies OK starting from new-style user" $ do+ newuser <- setPassword changedpw newStyleValidUser+ validatePass newuser changedpw `shouldBe` Just True+++ describe "Only the bottom 8 bits of password characters are used" $ do+ it "when verifying new-style password hash" $+ validatePass newStyleValidUser equivpassword `shouldBe` Just True+ it "when setting a new password" $ do+ newuser <- setPassword equivchangedpw oldStyleValidUser+ validatePass newuser changedpw `shouldBe` Just True
+ test/TestSite.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 802+-- Retain support for older compilers, assuming dependency versions which do too+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++module TestSite (+ User(..),+ migrateAll,+ App(..),+ Route(..),+ Handler,+ runDB+) where++import Control.Monad (when)+import Data.Text+import Database.Persist.Sqlite+import Network.HTTP.Client.Conduit (Manager)+import Yesod+import Yesod.Auth+import Yesod.Auth.HashDB (HashDBUser(..), authHashDB,+ submitRouteHashDB)+import Yesod.Auth.Message (AuthMessage (InvalidLogin))+++-- Trivial example site needing authentication+--+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+User+ name Text+ password Text Maybe+ UniqueUser name+ deriving Show+|]++instance HashDBUser User where+ userPasswordHash = userPassword+ setPasswordHash h u = u { userPassword = Just h }++data App = App+ { appHttpManager :: Manager+ , appDBConnection :: SqlBackend+ }++#if !MIN_VERSION_yesod_core(1,6,0)+#define liftHandler lift+#define doRunDB runDB+getAppHttpManager :: App -> Manager+getAppHttpManager = appHttpManager+#else+#define doRunDB liftHandler $ runDB+getAppHttpManager :: (MonadHandler m, HandlerSite m ~ App) => m Manager+getAppHttpManager = appHttpManager <$> getYesod+#endif++mkYesod "App" [parseRoutes|+/ HomeR GET+/prot ProtectedR GET+/auth AuthR Auth getAuth+|]++instance Yesod App where+ approot = ApprootStatic "http://localhost:3000"++ authRoute _ = Just $ AuthR LoginR++ isAuthorized ProtectedR _ = do+ mu <- maybeAuthId+ return $ case mu of+ Nothing -> AuthenticationRequired+ Just _ -> Authorized+ -- Other pages (HomeR and AuthR _) do not require login+ isAuthorized _ _ = return Authorized++ -- CSRF middleware requires yesod-core-1.4.14, yesod-test >= 1.5 is+ -- required so that tests can get at the token.+ yesodMiddleware = defaultCsrfMiddleware . defaultYesodMiddleware++instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend+ runDB action = do+ master <- getYesod+ runSqlConn action $ appDBConnection master++instance YesodAuth App where+ type AuthId App = UserId++ loginDest _ = HomeR+ logoutDest _ = HomeR++ authenticate creds = doRunDB $ do+ x <- getBy $ UniqueUser $ credsIdent creds+ case x of+ Just (Entity uid _) -> return $ Authenticated uid+ Nothing -> return $ UserError InvalidLogin++ authPlugins _ = [ authHashDB (Just . UniqueUser) ]++ authHttpManager = getAppHttpManager++ loginHandler = do+ submission <- submitRouteHashDB+ render <- liftHandler 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++instance YesodAuthPersist App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++getHomeR :: Handler Html+getHomeR = do+ mauth <- maybeAuth+ let mname = userName . entityVal <$> mauth+ defaultLayout+ [whamlet|+ <p>Your current auth ID: #{show mname}+ $maybe _ <- mname+ <p>+ <a href=@{AuthR LogoutR}>Logout+ $nothing+ <p>+ <a href=@{AuthR LoginR}>Go to the login page+ <p><a href=@{ProtectedR}>Go to protected page+ |]++-- This page requires a valid login+getProtectedR :: Handler Html+getProtectedR = defaultLayout+ [whamlet|+ <p>OK, you are logged in so you are allowed to see this!+ <p><a href=@{HomeR}>Go to home page+ |]
+ test/TestTools.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+module TestTools (+ assertFailure,+ urlPath,+ needsLogin,+ doLogin,+ doLoginPart1,+ doLoginPart2,+ checkFailedLogin,+ StdMethod(..)+) where++import TestSite (App(..))+import BasicPrelude+import qualified Prelude (show)+import Data.Text (pack, unpack)+import Data.ByteString.Lazy (toStrict)+import Yesod.Core (RedirectUrl)+import Yesod.Test+import qualified Data.ByteString.Char8 as BC+import Network.URI (URI(uriPath), parseURI)+import Network.HTTP.Types (StdMethod(..), renderStdMethod, Status(..))+import Network.Wai.Test (SResponse(..))++-- Adjust as necessary to the url prefix in the Testing configuration+testRoot :: ByteString+testRoot = "http://localhost:3000"++-- Adjust as necessary for the path part of the url for a page to force login+forceLogin :: ByteString+forceLogin = "/prot"++-- Adjust as necessary for the expected path part of the URL after login+afterLogin :: ByteString+afterLogin = "/prot"++-- Force failure by swearing that black is white, and pigs can fly...+assertFailure :: String -> YesodExample App ()+assertFailure msg = assertEq msg True False++-- Convert an absolute URL (eg extracted from responses) to just the path+-- for use in test requests.+urlPath :: Text -> Text+urlPath = pack . maybe "" uriPath . parseURI . unpack++-- Internal use only - actual urls are ascii, so exact encoding is irrelevant+urlPathB :: ByteString -> Text+urlPathB = urlPath . decodeUtf8++-- Stages in login process, used below+firstRedirect :: RedirectUrl App url =>+ StdMethod -> url -> YesodExample App (Maybe ByteString)+firstRedirect method url = do+ request $ do+ setMethod $ renderStdMethod method+ setUrl url+ extractLocation -- We should get redirected to the login page++assertLoginPage :: ByteString -> YesodExample App ()+assertLoginPage loc = do+ assertEq "correct login redirection location"+ (testRoot ++ "/auth/login") loc+ get $ urlPathB loc+ statusIs 200+ bodyContains "Login"++submitLogin :: Text -> Text -> YesodExample App (Maybe ByteString)+submitLogin user pass = do+ -- Ideally we would extract this url from the login form on the current page+ request $ do+ setMethod "POST"+ setUrl $ urlPathB $ testRoot ++ "/auth/page/hashdb/login"+ addPostParam "username" user+ addPostParam "password" pass+ addToken+ extractLocation -- Successful login should redirect to the home page++extractLocation :: YesodExample App (Maybe ByteString)+extractLocation = do+ withResponse ( \ SResponse { simpleStatus = s, simpleHeaders = h } -> do+ let code = statusCode s+ assertEq ("Expected a 302 or 303 redirection status "+ ++ "but received " ++ Prelude.show code)+ (code `elem` [302,303])+ True+ return $ lookup "Location" h+ )++-- Check that accessing the url with the given method requires login, and+-- that it redirects us to what looks like the login page. Note that this is+-- *not* an ajax request, whatever the method, so the redirection *should*+-- result in the HTML login page.+--+needsLogin :: RedirectUrl App url => StdMethod -> url -> YesodExample App ()+needsLogin method url = do+ mbloc <- firstRedirect method url+ maybe (assertFailure "Should have location header") assertLoginPage mbloc++-- Do a login (using hashdb auth). This just attempts to go to the home+-- url, and follows through the login process. It should probably be the+-- first thing in each "it" spec.+--+-- To allow testing of the login process itself, doLogin is split into two+-- parts.+--+doLogin :: Text -> Text -> YesodExample App (Maybe ByteString)+doLogin user pass = do+ redir <- doLoginPart1 user pass+ doLoginPart2 redir++doLoginPart1 :: Text -> Text -> YesodExample App (Maybe ByteString)+doLoginPart1 user pass = do+ mbloc <- firstRedirect GET $ urlPathB $ testRoot ++ forceLogin+ maybe (assertFailure "Should have location header") assertLoginPage mbloc+ submitLogin user pass++doLoginPart2 :: Maybe ByteString -> YesodExample App (Maybe ByteString)+doLoginPart2 mbloc2 = do+ maybe (assertFailure "Should have second location header")+ (assertEq "Check after-login redirection" $ testRoot ++ afterLogin)+ mbloc2+ -- Now get the home page to obtain the sessAuth value+ get ("/" :: Text)+ statusIs 200+ resp <- getResponse+ let sessAuth = (fmap simpleBody resp) >>= findSessAuth+ return sessAuth+ where+ findSessAuth body =+ let stmt = snd $ BC.breakSubstring "var sessAuth =" $ toStrict body+ parts = BC.split '"' stmt+ in case parts of+ (_:sa:_) -> Just sa+ _ -> Nothing++-- Use this instead of doLoginPart2 if the login is expected to fail+--+checkFailedLogin :: Maybe ByteString -> YesodExample App ()+checkFailedLogin mbloc2 = do+ maybe (assertFailure "Should have second location header")+ assertLoginPage+ mbloc2+ bodyContains "Invalid username/password combination"
+ test/integration.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.Trans.Resource (runResourceT)+import Control.Monad.Logger (runStderrLoggingT)+import Database.Persist.Sqlite+import Network.HTTP.Client.Conduit (newManager)+import Test.Hspec (hspec)+import Yesod+import Yesod.Auth.HashDB (setPassword)++#ifndef STANDALONE+import IntegrationTest+#endif+import TestSite++main :: IO ()+main = runStderrLoggingT $ withSqliteConn ":memory:" $ \conn -> liftIO $ do+ runResourceT $ flip runSqlConn conn $ do+ runMigration migrateAll+ validUser <- setPassword "MyPassword" $ User "paul" Nothing+ insert_ validUser+ mgr <- newManager+#ifdef STANDALONE+ -- Run as a stand-alone server - see the cabal file in this directory+ warp 3000 $ App mgr conn+#else+ -- Otherwise run the tests+ hspec $ withApp (App mgr conn) integrationSpec+#endif
+ test/main.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec++import NonDBTests++main :: IO ()+main = hspec nonDBTests
+ test/stack.yaml view
@@ -0,0 +1,7 @@+# Used for building standalone-testsite+packages:+- ..+- .+extra-deps: []+resolver: lts-17.9+compiler-check: newer-minor
+ test/standalone-testsite.cabal view
@@ -0,0 +1,38 @@+name: standalone-testsite+version: 0.1.2+license: MIT+author: Paul Rouse+maintainer: Paul Rouse <pyr@doynton.org>+synopsis: Stand-alone version of test for Yesod.Auth.HashDB+category: Web, Yesod+stability: Stable+cabal-version: >= 1.10+build-type: Simple+homepage: https://github.com/paul-rouse/yesod-auth-hashdb+bug-reports: https://github.com/paul-rouse/yesod-auth-hashdb/issues+description:+ Stand-alone integration test for Yesod.Auth.HashDB, run as a server.+ .+ Normally the integration test is run using Yesod.Test. However, it+ may be handy to build the example server as a stand-alone application+ and debug it. To do so, use this cabal file and the accompanying+ stack.yaml. STANDALONE is used in integration.hs to replace+ the tests with code which uses warp to make a server.++executable integration+ main-is: integration.hs+ hs-source-dirs: .+ ghc-options: -Wall+ cpp-options: -DSTANDALONE+ other-modules: TestSite+ build-depends: base >= 4 && < 5+ , hspec+ , http-conduit+ , monad-logger+ , persistent-sqlite+ , resourcet+ , text+ , yesod+ , yesod-auth+ , yesod-auth-hashdb+ , yesod-core
yesod-auth-hashdb.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-hashdb-version: 1.3.0.1+version: 1.7.1.7 license: MIT license-file: LICENSE author: Patrick Brisbin, later changes Paul Rouse@@ -7,24 +7,87 @@ synopsis: Authentication plugin for Yesod. category: Web, Yesod stability: Stable-cabal-version: >= 1.6.0+cabal-version: >= 1.10 build-type: Simple-homepage: http://www.yesodweb.com/-description: This package is the Yesod.Auth.HashDB plugin, originally included in yesod-auth, but now modified to be more secure and placed in a separate package.+homepage: https://github.com/paul-rouse/yesod-auth-hashdb+bug-reports: https://github.com/paul-rouse/yesod-auth-hashdb/issues+description:+ This package is the Yesod.Auth.HashDB plugin, originally included as part+ of yesod-auth, but now modified to be more secure and placed in a separate+ package.+ .+ It provides authentication using hashed passwords stored in a database,+ and works best in situations where an administrator is involved in+ setting up a user with an initial password.+ .+ The complete login process, including a default form, is implemented by+ this plugin, but the application developer must design the interfaces+ for setting up users and allowing them to change their own passwords,+ since only the low-level password-setting functions are provided by this+ package. (Note that other authentication plugins may be more appropriate+ if you wish to use email verification to set up accounts).+extra-source-files: ChangeLog.md+ stack.yaml+ test/stack.yaml+ test/standalone-testsite.cabal library- build-depends: base >= 4 && < 5- , bytestring >= 0.9.1.4 && < 0.11- , yesod-core >= 1.2 && < 1.3- , yesod-auth >= 1.3 && < 1.4- , text >= 0.7 && < 2.0- , yesod-persistent >= 1.2 && < 1.3- , yesod-form >= 1.3 && < 1.4- , pwstore-fast >= 2.2 && < 2.5- , cryptohash >= 0.8 && < 0.12+ build-depends: base >= 4.8 && < 5+ , bytestring >= 0.9.1.4+ , yesod-core >= 1.4.19 && < 1.7+ , yesod-auth >= 1.4.18 && < 1.7+ , text >= 0.7+ , yesod-persistent >= 1.2+ , persistent >= 2.1+ , yesod-form >= 1.4 && < 1.8+ , aeson exposed-modules: Yesod.Auth.HashDB ghc-options: -Wall+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ ghc-options: -Wall+ default-language: Haskell2010+ other-modules: ExampleData+ NonDBTests+ build-depends: base >= 4.8 && < 5+ , yesod-auth-hashdb+ , hspec+ , text++test-suite integration+ type: exitcode-stdio-1.0+ main-is: integration.hs+ hs-source-dirs: test+ ghc-options: -Wall+ default-language: Haskell2010+ other-modules: IntegrationTest+ , TestSite+ , TestTools+ build-depends: base >= 4.8 && < 5+ , aeson+ , bytestring+ , basic-prelude+ , containers+ , hspec >= 2.0.0+ , http-conduit+ , http-types+ , monad-logger+ , network-uri+ , persistent-sqlite >= 2.1+ , resourcet+ , text+ , unordered-containers+ , wai-extra+ , yesod+ , yesod-auth >= 1.4.18 && < 1.5 || >= 1.6.1 && < 1.7+ , yesod-auth-hashdb+ , yesod-core+ , yesod-test >= 1.5.0.1 source-repository head type: git