packages feed

yesod-auth-simple (empty) → 1.1.0

raw patch · 32 files changed

+1980/−0 lines, 32 filesdep +aesondep +basedep +base16-bytestring

Dependencies added: aeson, base, base16-bytestring, base64-bytestring, blaze-html, bytestring, classy-prelude, classy-prelude-yesod, cryptonite, directory, email-validate, fast-logger, hspec, http-types, memory, monad-logger, persistent, persistent-sqlite, scrypt, shakespeare, text, time, vector, wai, yesod, yesod-auth, yesod-core, yesod-form, yesod-test, zxcvbn-hs

Files

+ ChangeLog.md view
@@ -0,0 +1,30 @@+# Revision history for `yesod-auth-simple`++This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).++## Unreleased++## 1.1.0 - 2022-05-23+++ Make it build with ghc 9 by getting rid of AuthHandler in the typeclass+  and use the more general MonadAuthHandler.++## 1.0.0 - 2022-05-04++### Added++* `YesodAuthSimple` class methods:+  - `isConfirmationPending` to check if an email is waiting for confirmation+  - `onEmailAlreadyExist` to specify an action if the email is already registered.+  - `confirmationEmailResentTemplate` to notify user that a confirmation email has been resent+* Route `getConfirmationEmailResentR` to redirect user after the confirmation email has been resent+* Functions `getError`, `setError`, `clearError` added to export list++### Changed++* `postRegisterR` implementation logic. If you don't implement the new `YesodAuthSimple` methods,+  it will work just like the old implementation++## 0.0.0  -- 2018-12-02++* First version. Not exactly ready for release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Jezen Thomas++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jezen Thomas nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,104 @@+# yesod-auth-simple++This library is a [Yesod](https://www.yesodweb.com) [subsite](https://www.yesodweb.com/book/creating-a-subsite) that serves as a basis for user management and authentication in the traditional way (that is, users and their credentials are stored in a database you control). It includes both the backend route handlers and the frontend UI for login, registration, and password resets, which can optionally be extended or replaced. As a user, you need to provide implementations of sending appropriate emails, and user persistence. Features include:++* Ready-to-go route handlers and UI for login, registration and password reset flows.+* Password hashing and salting is done via Colin Percival's [Scrypt](https://hackage.haskell.org/package/scrypt) implementation. Just write the functions that store the hashes in the database.+* Registration and password reset tokens are generated and hashed for you. You write your own read/write/delete persistence and code to send the emails.+* A colourful password strength meter with feedback using [zxcvbn](https://blogs.dropbox.com/tech/2012/04/zxcvbn-realistic-password-strength-estimation/) (Traditional password checking based on length is also supported).+* Sensible splitting of UI into subcomponents so that you can use, for example, just the password input and strength meter in your own larger-scale forms.+* Useful lifecycle hooks that can be used to implement features like rate-limiting and session invalidation on password changes.++## Installation++`yesod-auth-simple` is not yet on Hackage. For now, we recommend pulling directly from GitHub using Nix or Stack (instructions for Stack [here](https://docs.haskellstack.org/en/stable/faq/#i-need-to-use-a-package-or-version-of-a-package-that-is-not-available-on-hackage-what-should-i-do)). For nix, you will need to:++1. copy the included `yesod-auth-nix.nix` derivation function into your project somewhere,+2. change the `src` attribute to reference this remote repository (e.g., using [fetchgit](https://nixos.org/nixpkgs/manual/#chap-pkgs-fetchers)).+3. build your project using a nixpkgs config that adds this package to the `haskell.packages.overrides`. More details on this Nix and Haskell workflow can be found [here](https://github.com/Gabriel439/haskell-nix/blob/master/project1/README.md).++## Usage++The library is built around the `YesodAuthSimple` type class. To use this package, you should write an instance of this class for the same type that instatiates the `Yesod` and `YesodAuth` type classes. To make the final connection, add `Yesod.Auth.Simple.authSimple` to the `YesodAuth` instance's `authPlugins` list.++```haskell+data App = ...++instance Yesod App++instance YesodAuth App where+  -- Refer to documentation for yesod-auth: http://hackage.haskell.org/package/yesod-auth+  type AuthId App = Key User -- For some User datatype, often derived from Persistent models+  loginDest _ = HomeR+  logoutDest _ = HomeR+  authPlugins _ = [ authSimple ]+  getAuthId = return . fromPathPiece . credsIdent+  maybeAuthId = defaultMaybeAuthId++instance YesodAuthSimple App where+  type AuthSimpleId App = Key User -- Uses the same  User datatype as in YesodAuth++  passwordCheck = Zxcvbn Safe (Vec.fromList ["yesod"])++  insertUser email encryptedPass = -- Add the user to your database!+  updateUserPassword userId encryptedPass = ...++  getUserId userEmail = -- Look in the DB for a corresponding user ID if one exists+  getUserPassword userId = -- Look in the DB and return a Crypto.Scrypt.EncryptedPass+  getUserModified userId = ...++  -- The following functions should persist the hashed token for later lookup+  sendVerifyEmail email urlToSend hashedToken = ...+  sendResetPasswordEmail email urlToSend hashedToken = ...++  -- The following functions should return an email or user id if the token is valid+  matchRegistrationToken hashedToken = ...+  matchPasswordToken hashedToken = ...++  onRegistrationTokenUsed = -- e.g. invalidate the new user's token+  onPasswordUpdated  = -- e.g. invalidate sessions and any password reset tokens+  afterPasswordRoute = -- e.g. redirect to the homepage after resetting password+  onRegisterSuccess  = -- e.g. redirect them to the homepage after registering+```++The rest of the typeclass consists of various Yesod [widget](https://www.yesodweb.com/book/widgets) [templates](https://www.yesodweb.com/book/shakespearean-templates) with default implementations. Override any as you see fit. The default templates are exported at the module's top level, so you can use them inside your own larger container widgets.++All customised templates with password form inputs must include, in the form's POST body, an anti-CSRF token using `Yesod.Core.Handler.defaultCsrfParamName` with the value retrieved from `Yesod.Core.Handler.reqToken`. A common template idiom is the following:++```+<form>+  $maybe antiCsrfToken <- reqToken request+    <input type=hidden name=#{defaultCsrfParamName} value=#{antiCsrfToken}>+  ... rest of form+```++Full details on the class functions can be found in the Hackage docs. An example of writing an instance for testing purposes can be found [here](https://github.com/riskbook/yesod-auth-simple/blob/master/test/ExampleApp.hs).++The library provides Email and Password types for which you need a few Persist instances. You can choose from default text-derived instance as in the example, `citext` email instance for storing email in postgres, or write your own.++## Security notes++This library will send POST requests containing the user's password (including as they type it via an XHR when you choose to use the Zxcvbn strength algorithm). It is therefore **vital** that you do not log the request bodies of these routes to avoid storing passwords in plaintext logs on your server. Sensitive routes are currently: loginR, setPasswordR, confirmR, and passwordStrengthR. We are investigating ways to improve developer experience here.++Please also beware of logging the HTTP `Referrer` header and confirmation/reset URLs themselves, which at certain points will include the account confirmation or password reset token.++### NIST compliance++The library aims to support applications seeking [NIST SP 800-63B](https://pages.nist.gov/800-63-3/sp800-63b.html) AAL1 compliance. To the best of our understanding, the library provides a [compliant](https://pages.nist.gov/800-63-3/sp800-63b.html#sec5) "memorized secret authenticator", provided that the user implements rate-limiting (the `shouldPreventLoginAttempt` and `onLoginAttempt` class functions can be used for this).++The library cannot claim compliance with the guidelines overall (at a particular AAL) because: 1) the library does not handle everything covered there (for example, session management), 2) some template and route customisation could always override our compliant defaults, and 3) password reset functionality via email is problematic; in NIST terminology it is considered an "out of band authenticator" and the guidelines specifically prohibit the use of email for this.++Note that scrypt [uses](https://tools.ietf.org/html/rfc7914#page-7) HMAC-SHA256 and so is compliant with NIST's hashing requirements.++## More pleasing authentication URLs++By default, all route URLs from this library are quite verbose: `/auth/page/simple/<login|register|..>`. If you would like short URLs (e.g. `/login`), then you should:++1. Use the `urlParamRenderOverride` function in your `Yesod` instance to change all `PluginR "simple" _` routes plus the `LoginR` and `LogoutR` routes to their short versions. Tip: Case on the route types (e.g. `LoginR`) and return absolute URLs.+2. Ensure incoming requests to the short URLs route to the extended URL handlers. Tip: Check out `rewritePureWithQueries` and its documentation in the `wai-extra` package.++Note that step 1 is for Yesod's type-safe routing while step 2 is for HTTP requests themselves. We will try to ease the developer experience of this in the future if possible!++## Contributing++Get started by running `nix-shell` from the project root directory and then use `cabal` and `ghci` from there. Run the tests from inside ghci using the included `:test` command.
+ src/Yesod/Auth/Simple.hs view
@@ -0,0 +1,976 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{- | A Yesod plugin for traditional email/password authentication++ This plugin uses an alternative flow to Yesod.Auth.Email fom the yesod-auth+ package.++__Note:__ this plugin reserves the following session names for its needs:++ * @yesod-auth-simple-error@+ * @yesod-auth-simple-email@+ * @yas-set-password-token@+ * @yas-registration-token@+ * @yas-password-backup@+-}++module Yesod.Auth.Simple+  ( -- * Plugin+    YesodAuthSimple(..)+  , authSimple+    -- * Routes+  , loginR+  , registerR+  , resetPasswordR+  , resetPasswordEmailSentR+  , setPasswordTokenR+  , confirmTokenR+  , confirmR+  , userExistsR+  , registerSuccessR+  , confirmationEmailSentR+  , passwordStrengthR+    -- * Default widgets+  , loginTemplateDef+  , setPasswordTemplateDef+  , invalidTokenTemplateDef+  , userExistsTemplateDef+  , registerSuccessTemplateDef+  , resetPasswordEmailSentTemplateDef+  , confirmationEmailSentTemplateDef+  , confirmTemplateDef+  , resetPasswordTemplateDef+  , registerTemplateDef+  , passwordFieldTemplateBasic+  , passwordFieldTemplateZxcvbn+  , honeypotFieldTemplate+    -- * Tokens+  , genToken+  , encodeToken+  , hashAndEncodeToken+  , decodeToken+    -- * Error handlers+  , getError+  , setError+  , clearError+    -- * Misc+  , maxPasswordLength+    -- * Types+  , Email(..)+  , Password(..)+  , PW.Strength(..)+  , PasswordCheck(..)+  , PasswordStrength(..)+    -- * Re-export from Scrypt+  , EncryptedPass(..)+  , Pass(..)+  , encryptPassIO'+  ) where++import ClassyPrelude+import Crypto.Hash (Digest, SHA256)+import qualified Crypto.Hash as C+import Crypto.Random (getRandomBytes)+import Crypto.Scrypt (EncryptedPass(..), Pass(..), encryptPassIO', verifyPass')+import Data.Aeson+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.URL as B64Url+import Data.Function ((&))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Vector as Vec+import Network.HTTP.Types (badRequest400, tooManyRequests429)+import Network.Wai (responseBuilder)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Text.Email.Validate (canonicalizeEmail)+import Text.Hamlet (hamletFile)+import Text.Julius (juliusFile)+import Text.Lucius (luciusFile)+import qualified Text.Password.Strength as PW+import qualified Text.Password.Strength.Config as PW+import Yesod.Auth+import Yesod.Auth.Simple.Types+import Yesod.Core+import Yesod.Core.Json as J+import Yesod.Form (iopt, ireq, runInputPost, textField)++minPasswordLength :: Int+minPasswordLength = 8 -- min length required in NIST SP 800-63B++maxPasswordLength :: Int+maxPasswordLength = 150 -- zxcvbn takes too long after this point++confirmTokenR :: Text -> AuthRoute+confirmTokenR token = PluginR "simple" ["confirm", token]++confirmR :: AuthRoute+confirmR = PluginR "simple" ["confirm"]++confirmationEmailSentR :: AuthRoute+confirmationEmailSentR = PluginR "simple" ["confirmation-email-sent"]++confirmationEmailResentR :: AuthRoute+confirmationEmailResentR = PluginR "simple" ["confirmation-email-resent"]++loginR :: AuthRoute+loginR = PluginR "simple" ["login"]++registerR :: AuthRoute+registerR = PluginR "simple" ["register"]++registerSuccessR :: AuthRoute+registerSuccessR = PluginR "simple" ["register-success"]++resetPasswordEmailSentR :: AuthRoute+resetPasswordEmailSentR = PluginR "simple" ["reset-password-email-sent"]++resetPasswordR :: AuthRoute+resetPasswordR = PluginR "simple" ["reset-password"]++setPasswordR :: AuthRoute+setPasswordR = PluginR "simple" ["set-password"]++setPasswordTokenR :: Text -> AuthRoute+setPasswordTokenR token = PluginR "simple" ["set-password", token]++userExistsR :: AuthRoute+userExistsR = PluginR "simple" ["user-exists"]++passwordStrengthR :: AuthRoute+passwordStrengthR = PluginR "simple" ["password-strength"]++class (YesodAuth a, PathPiece (AuthSimpleId a)) => YesodAuthSimple a where+  -- | Alias for some UserId datatype, likely same as the one in YesodAuth+  -- Refer to documentation for yesod-auth: http://hackage.haskell.org/package/yesod-auth+  type AuthSimpleId a++  -- | route to redirect to after resetting password e.g. homepage+  afterPasswordRoute :: a -> Route a++  -- | find user by email e.g. `runDB $ getBy $ UniqueUser email`+  getUserId :: MonadAuthHandler a m => Email -> m (Maybe (AuthSimpleId a))++  -- | find user's password (encrypted), handling user not found case+  getUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> m EncryptedPass++  -- | return this content after successful user registration+  onRegisterSuccess :: MonadAuthHandler a m => m TypedContent++  -- | insert user to database with just email and password+  -- other mandatory fields are not supported+  insertUser :: MonadAuthHandler a m => Email -> EncryptedPass -> m (Maybe (AuthSimpleId a))++  -- | update record in database after validation+  updateUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> EncryptedPass -> m ()++  -- | Return time until which the user should not be allowed to log in.+  -- The time is returned so that the UI can provide a helpful message in the+  -- event that a legitimate user somehow triggers the rate-limiting mechanism.+  -- If the time is Nothing, the user may log in.+  shouldPreventLoginAttempt :: MonadAuthHandler a m =>+    Maybe (AuthSimpleId a) -> m (Maybe UTCTime)+  shouldPreventLoginAttempt _ = pure Nothing++  -- | Perform an action on a login attempt.+  onLoginAttempt :: MonadAuthHandler a m => Maybe (AuthSimpleId a)+                 -- ^ The user id of the given email, if one exists+                 -> Bool+                 -- ^ Whether the password given was correct. Always+                 -- False when user id is Nothing+                 -> m ()+  onLoginAttempt _ _ = pure ()++  -- | Called when someone requests registration.+  sendVerifyEmail :: MonadAuthHandler a m => Email -- ^ A valid email they've registered.+                  -> VerUrl -- ^ An verification URL (in absolute form).+                  -> Text   -- ^ A sha256 base64-encoded hash of the+                           -- verification token. You should store this in your+                           -- database.+                  -> m ()+  sendVerifyEmail _ url _ = liftIO . print $ url++  -- | Like 'sendVerifyEmail' but for password resets.+  sendResetPasswordEmail :: MonadAuthHandler a m => Email -> VerUrl -> Text -> m ()+  sendResetPasswordEmail _ url _ = liftIO . print $ url++  -- | Given a hashed and base64-encoded token from the user, look up+  -- if the token is still valid and return the associated email if so.+  matchRegistrationToken :: MonadAuthHandler a m => Text -> m (Maybe Email)++  {- | Сheck if a registration confirmation is pending for the given email.+    +    @since 1.0.0+  -}+  isConfirmationPending :: MonadAuthHandler a m => Email -> m Bool+  isConfirmationPending _ = pure False++  -- | Like 'matchRegistrationToken' but for password resets.+  matchPasswordToken :: MonadAuthHandler a m => Text -> m (Maybe (AuthSimpleId a))++  -- | Can be used to invalidate the registration token. This is+  -- different from 'onRegisterSuccess' because this will also be+  -- called for existing users who use the registration form as a+  -- one-time login link. Note that 'onPasswordUpdated' can handle the+  -- case where a password reset token is used.+  onRegistrationTokenUsed :: MonadAuthHandler a m => Email -> m ()+  onRegistrationTokenUsed _ = pure ()+  +  {- | What to do if the email specified during registration is already registered.+    +    @since 1.0.0+  -}+  onEmailAlreadyExist :: MonadAuthHandler a m => m TypedContent+  onEmailAlreadyExist = do+    let msg = "This email address is already in use. Please login to your existing account."+    redirectWithError registerR msg++  -- | Password field widget for a chosen PasswordCheck algorithm+  passwordFieldTemplate :: (AuthRoute -> Route a) -> WidgetFor a ()+  passwordFieldTemplate tp =+    case passwordCheck @a of+      Zxcvbn minStren extraWords' ->+        passwordFieldTemplateZxcvbn tp minStren extraWords'+      RuleBased _ -> passwordFieldTemplateBasic++  -- | A template for showing the user authentication form+  --+  -- While a default is provided, you should probably override this with a+  -- template that matches your own product's branding.+  loginTemplate :: (AuthRoute -> Route a)+    -> Maybe Text  -- ^ Error+    -> Maybe Text  -- ^ Email+    -> WidgetFor a ()+  loginTemplate = loginTemplateDef++  registerTemplate :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()+  registerTemplate = registerTemplateDef++  resetPasswordTemplate ::+       (AuthRoute -> Route a)+    -> Maybe Text+    -> WidgetFor a ()+  resetPasswordTemplate = resetPasswordTemplateDef++  confirmTemplate ::+       (AuthRoute -> Route a)+    -> Route a+    -> Email+    -> Maybe Text+    -> WidgetFor a ()+  confirmTemplate = confirmTemplateDef++  confirmationEmailSentTemplate :: WidgetFor a ()+  confirmationEmailSentTemplate = confirmationEmailSentTemplateDef++  {- | Template to notify user that a confirmation email has been resent.++    @since 1.0.0+  -}+  confirmationEmailResentTemplate :: WidgetFor a ()+  confirmationEmailResentTemplate = confirmationEmailSentTemplate++  resetPasswordEmailSentTemplate :: WidgetFor a ()+  resetPasswordEmailSentTemplate = resetPasswordEmailSentTemplateDef++  registerSuccessTemplate :: WidgetFor a ()+  registerSuccessTemplate = registerSuccessTemplateDef++  userExistsTemplate :: WidgetFor a ()+  userExistsTemplate = userExistsTemplateDef++  invalidPasswordTokenTemplate :: Text -> WidgetFor a ()+  invalidPasswordTokenTemplate = invalidTokenTemplateDef++  invalidRegistrationTokenTemplate :: Text -> WidgetFor a ()+  invalidRegistrationTokenTemplate = invalidTokenTemplateDef++  tooManyLoginAttemptsTemplate :: UTCTime -> WidgetFor a ()+  tooManyLoginAttemptsTemplate = tooManyLoginAttemptsTemplateDef++  setPasswordTemplate ::+       (AuthRoute -> Route a)+    -> Route a+    -> Maybe Text+    -> WidgetFor a ()+  setPasswordTemplate = setPasswordTemplateDef++  -- | Run after a user successfully changing the user's+  -- password. This is a good time to delete any password reset tokens+  -- for this user.+  onPasswordUpdated :: MonadAuthHandler a m => AuthSimpleId a -> m ()+  onPasswordUpdated _ = setMessage "Password has been updated"++  -- | Action called when a bot is detected+  onBotPost :: MonadAuthHandler a m => m ()+  onBotPost = pure ()++  -- | Provide suitable constructor e.g. `RuleBased 8`+  passwordCheck :: PasswordCheck+  passwordCheck = Zxcvbn PW.Safe Vec.empty++-- | This instance of AuthPlugin for inserting into `authPlugins` of YesodAuth+authSimple :: YesodAuthSimple m => AuthPlugin m+authSimple = AuthPlugin "simple" dispatch loginHandlerRedirect++loginHandlerRedirect :: (Route Auth -> Route a) -> WidgetFor a ()+loginHandlerRedirect tm = redirectTemplate $ tm loginR++dispatch :: YesodAuthSimple a => Text -> [Text] -> AuthHandler a TypedContent+dispatch method path = case (method, path) of+  ("GET",  ["register"])                  -> sr getRegisterR+  ("POST", ["register"])                  -> sr postRegisterR+  ("GET",  ["confirm", token])            -> sr $ getConfirmTokenR token+  ("GET",  ["confirm"])                   -> sr getConfirmR+  ("POST", ["confirm"])                   -> sr postConfirmR+  ("GET",  ["confirmation-email-sent"])   -> sr getConfirmationEmailSentR+  -- @since 1.0.0+  ("GET",  ["confirmation-email-resent"]) -> sr getConfirmationEmailResentR+  ("GET",  ["register-success"])          -> sr getRegisterSuccessR+  ("GET",  ["user-exists"])               -> sr getUserExistsR+  ("GET",  ["login"])                     -> sr getLoginR+  ("POST", ["login"])                     -> sr postLoginR+  ("GET",  ["set-password", token])       -> sr $ getSetPasswordTokenR token+  ("GET",  ["set-password"])              -> sr getSetPasswordR+  ("POST", ["set-password"])              -> sr postSetPasswordR+  ("GET",  ["reset-password"])            -> sr getResetPasswordR+  ("POST", ["reset-password"])            -> sr postResetPasswordR+  ("GET",  ["reset-password-email-sent"]) -> sr getResetPasswordEmailSentR+  -- NB: We use a POST instead of GET so that we don't send the password+  -- in the URL query string+  ("POST", ["password-strength"])         -> sr postPasswordStrengthR+  _                                       -> notFound+  where sr r = r >>= sendResponse++-- | Registration page+getRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent+getRegisterR = do+  mErr <- getError+  muid <- maybeAuthId+  tp   <- getRouteToParent+  case muid of+    Nothing -> selectRep . provideRep . authLayout $ do+      setTitle "Register a new account"+      registerTemplate tp mErr+    Just _ -> redirect $ toPathPiece ("/" :: String)++-- | Reset password page+getResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent+getResetPasswordR = do+  mErr <- getError+  tp   <- getRouteToParent+  selectRep . provideRep . authLayout $ do+    setTitle "Reset password"+    resetPasswordTemplate tp mErr++-- | Login page+getLoginR :: YesodAuthSimple a => AuthHandler a TypedContent+getLoginR = do+  mErr <- getError+  mEmail <- getEmail+  muid <- maybeAuthId+  tp   <- getRouteToParent+  case muid of+    Nothing -> selectRep . provideRep . authLayout $ do+      setTitle "Login"+      loginTemplate tp mErr mEmail+    Just _ -> redirect $ toPathPiece ("/" :: String)++-- | Name for a password-reset token to store in cookies+-- see getSetPasswordTokenR for motivation+-- `yas` is short for Yesod Auth Simple :)+passwordTokenSessionKey :: Text+passwordTokenSessionKey = "yas-set-password-token"++-- | Another key for registration tokens+registrationTokenSessionKey :: Text+registrationTokenSessionKey = "yas-registration-token"++genToken :: IO ByteString+genToken = getRandomBytes 24++-- | Hashes input via SHA256 and returns the hash encoded as base64 text+hashAndEncodeToken :: ByteString -> Text+hashAndEncodeToken bs = decodeUtf8 . B64.encode+               $ ByteArray.convert (C.hash bs :: Digest SHA256)++-- | encode to base64url form+encodeToken :: ByteString -> Text+encodeToken = decodeUtf8With lenientDecode . B64Url.encode++-- | Decode from base64url. Lenient decoding because this is random+-- input from the user and not all valid utf8 is valid base64+decodeToken :: Text -> ByteString+decodeToken = B64Url.decodeLenient . encodeUtf8++-- | Lookup and verify registration token+verifyRegisterTokenFromSession :: YesodAuthSimple a+  => AuthHandler a (Maybe Email)+verifyRegisterTokenFromSession =+  maybe (pure Nothing) matchRegistrationToken+    =<< lookupSession registrationTokenSessionKey++-- | Lookup and verify password token+verifyPasswordTokenFromSession :: YesodAuthSimple a+                               => AuthHandler a (Maybe (AuthSimpleId a))+verifyPasswordTokenFromSession =+  maybe (pure Nothing) matchPasswordToken+    =<< lookupSession passwordTokenSessionKey++-- | Delete registration token from cookie and maybe callback+markRegisterTokenAsUsed :: YesodAuthSimple a => Maybe Email -> AuthHandler a ()+markRegisterTokenAsUsed mEmail = do+  deleteSession registrationTokenSessionKey+  case mEmail of+    Just email -> onRegistrationTokenUsed email+    _          -> pure ()++-- | Accept registration form and send a verification link+postRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent+postRegisterR = do+  clearError+  (honeypot, email) <- runInputPost $ (,)+                      <$> iopt textField honeypotName+                      <*> ireq textField "email"+  mEmail <- fmap Email <$> validateAndNormalizeEmail email+  case mEmail of+    _ | isJust honeypot -> do+          onBotPost+          let msg = "An unexpected error occurred.\+                    \ Please try again or contact support\+                    \ if the problem persists."+          redirectWithError registerR msg+    Just email' -> do+      getUserId email' >>= \case+        -- User with that email already exists+        Just _  -> onEmailAlreadyExist+        Nothing -> do+          tp <- getRouteToParent+          renderUrl <- getUrlRender+          rawToken <- liftIO genToken+          let url = renderUrl . tp . confirmTokenR $ encodeToken rawToken+              hashed = hashAndEncodeToken rawToken+          route <- bool confirmationEmailSentR confirmationEmailResentR+                    <$> isConfirmationPending email'+          sendVerifyEmail email' url hashed+          redirect $ tp route+    Nothing -> do+      setError "Invalid email address"+      tp <- getRouteToParent+      redirect $ tp registerR++-- | Accept email and send a password reset link+postResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent+postResetPasswordR = do+  clearError+  ur    <- getUrlRender+  token <- liftIO genToken+  email <- runInputPost $ ireq textField "email"+  tp    <- getRouteToParent+  let url = ur . tp . setPasswordTokenR $ encodeToken token+      hashed = hashAndEncodeToken token+  sendResetPasswordEmail (Email email) url hashed+  redirect $ tp resetPasswordEmailSentR++-- | Target URL reached from account confirmation email+-- Move the token into a session cookie and redirect to the+-- token-less URL (in order to avoid referrer leakage). The+-- alternative is to invalidate the token immediately and embed a+-- new one in the html form, but this has worse UX+getConfirmTokenR :: Text -> AuthHandler a TypedContent+getConfirmTokenR token = do+  setSession registrationTokenSessionKey . hashAndEncodeToken . decodeToken $ token+  tp <- getRouteToParent+  redirect $ tp confirmR++-- | Validate registration token and present confirmation screen to continue+-- e.g. include form to set password+getConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent+getConfirmR = do+  mEmail <- verifyRegisterTokenFromSession+  case mEmail of+    Nothing -> do+      markRegisterTokenAsUsed Nothing+      invalidRegistrationTokenHandler+    Just email ->+      -- If user already registered, redirect to homepage as+      -- authenticated user. Otherwise, keep the token in the cookie+      -- and redirect to the confirm handler, checking and deleting+      -- the token only after the user sets up their password.+      getUserId email >>= maybe (doConfirm email) (redirectToHome email)+  where+    redirectToHome email uid = do+      markRegisterTokenAsUsed $ Just email+      setCredsRedirect $ Creds "simple" (toPathPiece uid) []+    doConfirm email = do tp <- getRouteToParent+                         confirmHandler (tp confirmR) email++-- | Response and perhaps explanation for invalid or expired password token+invalidPasswordTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent+invalidPasswordTokenHandler = do+  html <- authLayout $ do+    setTitle "Invalid token"+    invalidPasswordTokenTemplate invalidPasswordTokenMessage+  let contentType = [("Content-Type", "text/html")]+  renderHtmlBuilder html+    & responseBuilder badRequest400 contentType+    & sendWaiResponse++-- | Response and perhaps explanation for invalid or expired registration token+invalidRegistrationTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent+invalidRegistrationTokenHandler = do+  html <- authLayout $ do+    setTitle "Invalid token"+    invalidRegistrationTokenTemplate invalidRegistrationMessage+  let contentType = [("Content-Type", "text/html")]+  renderHtmlBuilder html+    & responseBuilder badRequest400 contentType+    & sendWaiResponse++-- | Next step after email verification, usually to set password+confirmHandler ::+     YesodAuthSimple a+  => Route a+  -> Email+  -> AuthHandler a TypedContent+confirmHandler registerUrl email = do+  mErr <- getError+  tp <- getRouteToParent+  selectRep . provideRep . authLayout $ do+    setTitle "Confirm account"+    confirmTemplate tp registerUrl email mErr++-- | Check registration token again, take password and try to create user+postConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent+postConfirmR = do+  clearError+  okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName+  mEmail <- verifyRegisterTokenFromSession+  case mEmail of+    _ | not okCsrf -> redirectWithError confirmR invalidCsrfMessage+    Nothing -> invalidRegistrationTokenHandler+    Just email -> do+      password <- runInputPost $ ireq textField "password"+      createUser email (Pass . encodeUtf8 $ password)++-- | Create user with valid password and return success page (or redirect)+createUser :: forall m. YesodAuthSimple m+           => Email -> Pass -> AuthHandler m TypedContent+createUser email password = do+  check <- liftIO $ strengthToEither+          <$> checkPasswordStrength (passwordCheck @m) password+  case check of+    Left msg -> do+      setError msg+      tp <- getRouteToParent+      redirect $ tp confirmR+    Right _ -> do+      markRegisterTokenAsUsed $ Just email+      encrypted <- liftIO $ encryptPassIO' password+      insertUser email encrypted >>= \case+        Just uid -> do+          let creds = Creds "simple" (toPathPiece uid) []+          setCreds False creds+          onRegisterSuccess+        Nothing -> do+          tp <- getRouteToParent+          redirect $ tp userExistsR++-- | Confirmation to show after sending verification email+getConfirmationEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent+getConfirmationEmailSentR = selectRep . provideRep . authLayout $ do+  setTitle "Confirmation email sent"+  confirmationEmailSentTemplate++{- | Confirmation to show after resending verification email.++  @since 1.0.0+-}+getConfirmationEmailResentR :: YesodAuthSimple a => AuthHandler a TypedContent+getConfirmationEmailResentR = selectRep . provideRep . authLayout $ do+  setTitle "Confirmation email resent"+  confirmationEmailResentTemplate++-- | Confirmation to show after sending password reset email+getResetPasswordEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent+getResetPasswordEmailSentR = selectRep . provideRep . authLayout $ do+  setTitle "Reset password email sent"+  resetPasswordEmailSentTemplate++-- | Another option for responding on successful registration+getRegisterSuccessR :: AuthHandler a TypedContent+getRegisterSuccessR = do+  setMessage "Account created. Welcome!"+  redirect ("/" :: Text)++-- | Redirected to when `insertUser` does not return UserID+getUserExistsR :: YesodAuthSimple a => AuthHandler a TypedContent+getUserExistsR = selectRep . provideRep . authLayout $ do+  setTitle "User already exists"+  userExistsTemplate++-- | JSON endpoint for validating password+postPasswordStrengthR :: forall a. (YesodAuthSimple a) => AuthHandler a J.Value+postPasswordStrengthR = do+  okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName+  if not okCsrf+    then pure . toJSON $ BadPassword PW.Risky $ Just invalidCsrfMessage+    else do+      password <- runInputPost (ireq textField "password")+      let pass = Pass . encodeUtf8 $ password+      liftIO $ toJSON <$> checkPasswordStrength (passwordCheck @a) pass++-- | Validate password for given parameters with Zxcvbn library+checkPassWithZxcvbn ::+     PW.Strength+  -> Vector Text+  -> Day+  -> Text+  -> PasswordStrength+checkPassWithZxcvbn minStrength' extraWords' day password =+  let conf = PW.addCustomFrequencyList extraWords' PW.en_US+      guesses = PW.score conf day password+      stren = PW.strength guesses+  in if stren >= minStrength' then GoodPassword stren+     else BadPassword stren $ Just "The password is not strong enough"++-- | Validate password with simple length rule+checkPassWithRules :: Int -> Text -> PasswordStrength+checkPassWithRules minLen password+  | T.length password >= minLen = GoodPassword PW.Safe+  | otherwise = BadPassword PW.Weak . Just . T.pack+                $ "Password must be at least " <> show minLen <> " characters"++strengthToEither :: PasswordStrength -> Either Text PW.Strength+strengthToEither (GoodPassword stren) = Right stren+strengthToEither (BadPassword _ (Just err)) = Left err+strengthToEither (BadPassword _ Nothing) =+  Left "The password is not strong enough"++getPWStrength :: PasswordStrength -> PW.Strength+getPWStrength (GoodPassword stren)  = stren+getPWStrength (BadPassword stren _) = stren++-- | Explain password strength with a given validator+checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength+checkPasswordStrength check pass =+  case decodeUtf8' (getPass pass) of+    Left _ -> pure $ BadPassword PW.Weak $ Just "Invalid characters in password"+    Right password ->+      if not satisfiesMaxLen+      then pure . BadPassword PW.Weak . Just+           $ "Password exceeds maximum length of "+           <> T.pack (show maxPasswordLength)+      else case check of+        RuleBased minLen ->+          pure $ checkPassWithRules (max minLen minPasswordLength) password+        Zxcvbn minStren extraWords' -> do+          today <- utctDay <$> getCurrentTime+          let pwstren = checkPassWithZxcvbn minStren extraWords' today password+          pure $+            if satisfiesMinLen+            then pwstren+            -- Although we always prevent passwords below the minimum+            -- length, we do not score it as Weak invariably. This+            -- prevents the password meter from sticking at the lowest+            -- level until after you input a safe password of min length+            else BadPassword (min (getPWStrength pwstren) (pred minStren))+                 . Just $ "The password must be at least "+                 <> T.pack (show minPasswordLength) <> " characters"+      where (boundedPw, extra) = T.splitAt maxPasswordLength password+            satisfiesMinLen = T.length boundedPw >= minPasswordLength+            satisfiesMaxLen = T.null extra++normalizeEmail :: Text -> Text+normalizeEmail = T.toLower++validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)+validateAndNormalizeEmail email = case canonicalizeEmail $ encodeUtf8 email of+  Just bytes ->+      return $ Just $ normalizeEmail $ decodeUtf8With lenientDecode bytes+  Nothing -> return Nothing++-- | Session name used for the errors.+errorSessionName :: Text+errorSessionName = "yesod-auth-simple-error"++-- | Session name used for the email storage.+emailSessionName :: Text+emailSessionName = "yesod-auth-simple-email"++{- | Get the error session (see 'errorSessionName') if present. It also clears+up the session after.+-}+getError :: AuthHandler a (Maybe Text)+getError = do+  mErr <- lookupSession errorSessionName+  clearError+  return mErr++-- | Sets up the error session ('errorSessionName') to the given value.+setError :: MonadHandler m => Text -> m ()+setError = setSession errorSessionName++-- | Clears up the error session ('errorSessionName').+clearError :: AuthHandler a ()+clearError = deleteSession errorSessionName++{- | Get the email session (see 'emailSessionName') if present. It also clears+up the session after.+-}+getEmail :: AuthHandler a (Maybe Text)+getEmail = do+  mEmail <- lookupSession emailSessionName+  clearEmail+  return mEmail++-- | Sets up the email session ('emailSessionName') to the given value.+setEmail :: MonadHandler m => Text -> m ()+setEmail = setSession emailSessionName++-- | Clears up the email session ('emailSessionName').+clearEmail :: AuthHandler a ()+clearEmail = deleteSession emailSessionName++-- | Accept login form, check attempts limit and authenticate or redirect user+postLoginR :: YesodAuthSimple a => AuthHandler a TypedContent+postLoginR = do+  clearError+  clearEmail+  okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName+  if not okCsrf+    then redirectWithError loginR invalidCsrfMessage+    else do+      (email, password') <- runInputPost $ (,)+        <$> ireq textField "email"+        <*> ireq textField "password"+      setEmail email+      let password = Pass . encodeUtf8 $ password'+      mUid <- getUserId (Email email)+      mLockedOut <- shouldPreventLoginAttempt mUid+      case (mLockedOut, mUid) of+        (Just expires, _) -> tooManyLoginAttemptsHandler expires+        (_, Just uid) -> do+          storedPassword <- getUserPassword uid+          if verifyPass' password storedPassword+            then do+              onLoginAttempt (Just uid) True+              setCredsRedirect $ Creds "simple" (toPathPiece uid) []+            else do+              onLoginAttempt (Just uid) False+              wrongEmailOrPasswordRedirect+        _ -> do+          onLoginAttempt Nothing False+          wrongEmailOrPasswordRedirect++tooManyLoginAttemptsHandler ::+     YesodAuthSimple a+  => UTCTime+  -> AuthHandler a TypedContent+tooManyLoginAttemptsHandler expires = do+  html <- authLayout $ do+    setTitle "Too many login attempts"+    tooManyLoginAttemptsTemplate expires+  let contentType = [("Content-Type", "text/html")]+  renderHtmlBuilder html+    & responseBuilder tooManyRequests429 contentType+    & sendWaiResponse++redirectTo :: AuthRoute -> AuthHandler a b+redirectTo route = do+  tp <- getRouteToParent+  redirect $ tp route++redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent+redirectWithError route err = do+  setError err+  redirectTo route++wrongEmailOrPasswordRedirect :: AuthHandler a TypedContent+wrongEmailOrPasswordRedirect =+  redirectWithError loginR "Wrong email or password"++invalidCsrfMessage :: Text+invalidCsrfMessage =+  "Invalid anti-forgery token. \+  \Please try again in a new browser tab or window. \+  \Contact support if the problem persists."++invalidRegistrationMessage :: Text+invalidRegistrationMessage =+  "Invalid registration link. \+  \Please try registering again and contact support if the problem persists"++invalidPasswordTokenMessage :: Text+invalidPasswordTokenMessage =+  "Invalid password reset token. \+  \Please try again and contact support if the problem persists."++-- | Target URL reached from password reset email+-- Move the token into a session cookie and redirect to the+-- token-less URL (in order to avoid referrer leakage). The+-- alternative is to invalidate the token immediately and embed a+-- new one in the html form, but this has worse UX+getSetPasswordTokenR :: Text -> AuthHandler a TypedContent+getSetPasswordTokenR token = do+  setSession passwordTokenSessionKey . hashAndEncodeToken . decodeToken $ token+  tp <- getRouteToParent+  redirect $ tp setPasswordR++-- | Validate password token and prompt for new password+getSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent+getSetPasswordR = do+  mUid <- verifyPasswordTokenFromSession+  case mUid of+    Nothing -> invalidPasswordTokenHandler+    Just _ -> do+      tp <- getRouteToParent+      mErr <- getError+      selectRep . provideRep . authLayout $ do+        setTitle "Set password"+        setPasswordTemplate tp (tp setPasswordR) mErr++-- | Set a new password for the user+postSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent+postSetPasswordR = do+  clearError+  okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName+  mUid <- verifyPasswordTokenFromSession+  case mUid of+    _ | not okCsrf -> redirectWithError setPasswordR invalidCsrfMessage+    Nothing -> do+      deleteSession passwordTokenSessionKey+      invalidPasswordTokenHandler+    Just uid -> do+      password <- runInputPost $ ireq textField "password"+      setPass uid (Pass . encodeUtf8 $ password)++-- | Check and update password, callback, then redirect to user page+setPass :: forall a. YesodAuthSimple a+  => AuthSimpleId a+  -> Pass+  -> AuthHandler a TypedContent+setPass uid password = do+  check <- liftIO $ strengthToEither+          <$> checkPasswordStrength (passwordCheck @a) password+  case check of+    Left msg -> do+      setError msg+      tp <- getRouteToParent+      redirect $ tp setPasswordR+    Right _ -> do+      encrypted <- liftIO $ encryptPassIO' password+      _         <- updateUserPassword uid encrypted+      onPasswordUpdated uid+      deleteSession passwordTokenSessionKey+      setCredsRedirect $ Creds "simple" (toPathPiece uid) []++redirectTemplate :: Route a -> WidgetFor a ()+redirectTemplate destUrl = do+  toWidget $(whamletFile "templates/redirect.hamlet")+  toWidget [julius|window.location = "@{destUrl}";|]++csrfTokenTemplate :: WidgetFor a ()+csrfTokenTemplate = do+  request <- getRequest+  $(whamletFile "templates/csrf-token.hamlet")++loginTemplateDef ::+     (AuthRoute -> Route a)+  -> Maybe Text+  -> Maybe Text+  -> WidgetFor a ()+loginTemplateDef toParent mErr mEmail = $(whamletFile "templates/login.hamlet")++passwordFieldTemplateBasic :: WidgetFor a ()+passwordFieldTemplateBasic =+  $(whamletFile "templates/password-field-basic.hamlet")++zxcvbnJsUrl :: Text+zxcvbnJsUrl = "https://cdn.jsdelivr.net/npm/zxcvbn@4.4.2/dist/zxcvbn.js"++passwordFieldTemplateZxcvbn ::+     (AuthRoute -> Route a)+  -> PW.Strength+  -> Vector Text+  -> WidgetFor a ()+passwordFieldTemplateZxcvbn toParent minStren extraWords' = do+  let extraWordsStr = T.unwords . toList $ extraWords'+      blankPasswordScore = BadPassword PW.Risky Nothing+  mCsrfToken <- reqToken <$> getRequest+  addScriptRemote zxcvbnJsUrl+  toWidget $(hamletFile "templates/password-field-zxcvbn.hamlet")+  toWidget $(luciusFile "templates/password-field-zxcvbn.lucius")+  toWidget $(juliusFile "templates/password-field-zxcvbn.julius")++setPasswordTemplateDef ::+     forall a. YesodAuthSimple a+  => (AuthRoute -> Route a)+  -> Route a+  -> Maybe Text+  -> WidgetFor a ()+setPasswordTemplateDef toParent url mErr =+  let pwField = passwordFieldTemplate @a toParent+   in $(whamletFile "templates/set-password.hamlet")++invalidTokenTemplateDef :: Text -> WidgetFor a ()+invalidTokenTemplateDef msg = $(whamletFile "templates/invalid-token.hamlet")++tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()+tooManyLoginAttemptsTemplateDef expires =+  let formatted = formatTime defaultTimeLocale "%d/%m/%_Y %T" expires+   in $(whamletFile "templates/too-many-login-attempts.hamlet")++userExistsTemplateDef :: WidgetFor a ()+userExistsTemplateDef = $(whamletFile "templates/user-exists.hamlet")++registerSuccessTemplateDef :: WidgetFor a ()+registerSuccessTemplateDef = $(whamletFile "templates/register-success.hamlet")++resetPasswordEmailSentTemplateDef :: WidgetFor a ()+resetPasswordEmailSentTemplateDef =+  $(whamletFile "templates/reset-password-email-sent.hamlet")++confirmationEmailSentTemplateDef :: WidgetFor a ()+confirmationEmailSentTemplateDef =+  $(whamletFile "templates/confirmation-email-sent.hamlet")++confirmTemplateDef ::+     forall a. YesodAuthSimple a+  => (AuthRoute -> Route a)+  -> Route a+  -> Email+  -> Maybe Text+  -> WidgetFor a ()+confirmTemplateDef toParent confirmUrl (Email email) mErr =+  let pwField = passwordFieldTemplate @a toParent+   in $(whamletFile "templates/confirm.hamlet")++resetPasswordTemplateDef ::+     (AuthRoute -> Route a)+  -> Maybe Text+  -> WidgetFor a ()+resetPasswordTemplateDef toParent mErr =+  $(whamletFile "templates/reset-password.hamlet")++honeypotName :: Text+honeypotName = "yas-password-backup"++honeypotFieldTemplate :: WidgetFor a ()+honeypotFieldTemplate = do+  toWidget [lucius| .#{honeypotName} { display:none !important; } |]+  toWidget $(hamletFile "templates/honeypot-field.hamlet")++registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()+registerTemplateDef toParent mErr = $(whamletFile "templates/register.hamlet")
+ src/Yesod/Auth/Simple/Instance/Persist/EmailText.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Yesod.Auth.Simple.Instance.Persist.EmailText where++import ClassyPrelude+import Database.Persist.Sql+import Yesod.Auth.Simple.Types++instance PersistFieldSql Email where+  sqlType = const SqlString++instance PersistField Email where+  toPersistValue (Email e) = toPersistValue e+  fromPersistValue (PersistText e) = Right $ Email e+  fromPersistValue e               = Left $ pack "Not a PersistText: " <> tshow e
+ src/Yesod/Auth/Simple/Instance/Persist/EmailTextCI.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE LambdaCase #-}+module Yesod.Auth.Simple.Instance.Persist.EmailTextCI where++import ClassyPrelude+import Database.Persist.Sql+import Yesod.Auth.Simple.Types++instance PersistFieldSql Email where+  sqlType _ = SqlOther $ pack "citext"++instance PersistField Email where+  toPersistValue (Email e) = toPersistValue e+  fromPersistValue = \case+    -- use `PersistLiteral_ Escaped bs` in newer persistent+    PersistDbSpecific bs -> Right $ Email (decodeUtf8 bs)+    e -> Left $ pack "Not a PersistDbSpecific: " <> tshow e
+ src/Yesod/Auth/Simple/Instance/Persist/PasswordText.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Yesod.Auth.Simple.Instance.Persist.PasswordText where++import ClassyPrelude+import Database.Persist.Sql+import Yesod.Auth.Simple.Types++instance PersistFieldSql Password where+  sqlType = const SqlString++instance PersistField Password where+  toPersistValue (Password e) = toPersistValue e+  fromPersistValue (PersistText e) = Right $ Password e+  fromPersistValue e               = Left $ pack "Not a PersistText: " <> tshow e
+ src/Yesod/Auth/Simple/Types.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Auth.Simple.Types where++import ClassyPrelude+import Data.Aeson+import qualified Text.Password.Strength as PW++newtype PasswordReq = PasswordReq { unPasswordReq :: Text }++-- | `extraWords` are common words, likely in the application domain,+-- that should be noted in the zxcvbn password strength check. These+-- words will not be banned in passwords, but they will be noted as+-- less secure than they could have been otherwise.+data PasswordCheck = RuleBased { minChars :: Int }+                   | Zxcvbn { minStrength :: PW.Strength+                            , extraWords  :: Vector Text }++data PasswordStrength = GoodPassword PW.Strength+                      | BadPassword PW.Strength (Maybe Text)++instance ToJSON PasswordStrength where+  toJSON (GoodPassword stren) =+    object ["isAcceptable" .= True, "score" .= fromEnum stren]+  toJSON (BadPassword stren mErr) =+    object [ "isAcceptable" .= False+           , "score" .= fromEnum stren+           , "error" .= toJSON mErr ]++instance FromJSON PasswordReq where+  parseJSON = withObject "req" $ \o -> do+    password <- o .: "password"+    return $ PasswordReq password++newtype Email = Email { unEmail :: Text }+  deriving (Show, ToJSON, FromJSON)++instance Eq Email where+  Email e1 == Email e2 = toLower e1 == toLower e2++newtype Password = Password Text+  deriving(Eq, ToJSON, FromJSON)++instance Show Password where+  show _ = "<redacted>"++type VerUrl = Text
+ templates/confirm.hamlet view
@@ -0,0 +1,12 @@+$newline never+$maybe err <- mErr+  <div class="alert">#{err}++<.confirm>+  <h1>Set Your Password+  <form method="post" action="@{confirmUrl}">+    ^{csrfTokenTemplate}+    <p>#{email}+    ^{pwField}+    <button type="submit">Set Password+
+ templates/confirmation-email-sent.hamlet view
@@ -0,0 +1,7 @@+$newline never+<.confirmation-email-sent">+  <h1>Email sent+  <p>+    A confirmation email has been sent to your address.+    Click on the link in the email to complete the registration.+
+ templates/csrf-token.hamlet view
@@ -0,0 +1,4 @@+$newline never+$maybe antiCsrfToken <- reqToken request+  <input type=hidden name=#{defaultCsrfParamName} value=#{antiCsrfToken}>+
+ templates/honeypot-field.hamlet view
@@ -0,0 +1,5 @@+$newline never+<fieldset class="#{honeypotName}">+  <label for="#{honeypotName}">+  <input type="text" name="#{honeypotName}" tabindex="none" autocomplete="off">+
+ templates/invalid-token.hamlet view
@@ -0,0 +1,5 @@+$newline never+<.invalid-token>+  <h1>Invalid key+  <p>#{msg}+
+ templates/login.hamlet view
@@ -0,0 +1,21 @@+$newline never+$maybe err <- mErr+  <div class="alert">#{err}++<h1>Sign in+<form method="post" action="@{toParent loginR}">+  ^{csrfTokenTemplate}+  <fieldset>+    <label for="email">Email+    $maybe email <- mEmail+      <input type="email" name="email" value=#{email} required>+    $nothing+      <input type="email" name="email" autofocus required>+  <fieldset>+    <label for="password">Password+    <input type="password" name="password" required :isJust mEmail:autofocus>+  <button type="submit">Sign in+  <p>+    <a href="@{toParent resetPasswordR}">Forgot password?+  <p class="need-to-register">+    Need an account? <a href="@{toParent registerR}">Register</a>.
+ templates/password-field-basic.hamlet view
@@ -0,0 +1,5 @@+$newline never+<fieldset>+  <label for="password">Password+  <input type="password" name="password" autofocus required>+
+ templates/password-field-zxcvbn.hamlet view
@@ -0,0 +1,12 @@+$newline never+<fieldset>+  <label for="password">Password+  <input#password type="password" name="password" autofocus required>+  <#yas--extra-words data-extra-words="#{extraWordsStr}">+  <#yas--password-feedback>+    <.yas--password-meter-container>+      <.yas--password-meter.yas--strength-init>+    <.yas--password-errors>+      <p.yas--password-warning>+      <.yas--password-suggestions>+
+ templates/password-field-zxcvbn.julius view
@@ -0,0 +1,110 @@+var yas__extraWordsEl = document.getElementById("yas__extra-words");+var yas__extraWords = [];+if (yas__extraWordsEl) {+  var str = yas__extraWordsEl.getAttribute("data-extra-words");+  if (Boolean(str)) { yas__extraWords = str.split(" "); }+}++var yas__passwordFeedback = document.getElementById("yas--password-feedback");+var yas__passwordMeter = yas__passwordFeedback.querySelector(".yas--password-meter");+var yas__passwordErrors = yas__passwordFeedback.querySelector(".yas--password-errors");++function yas_showError() {+  var warningEl = yas__passwordErrors.querySelector(".yas--password-warning");+  warningEl.appendChild(document.createTextNode("Error requesting password strength"));+}++function yas_updateFeedback (password, strength) {+  var gotScore = typeof strength.score === "number";+  var score, feedback, jsResult;+  if (!gotScore || strength.score <= 2 || strength.score < #{toJSON $ fromEnum minStren}) {+    jsResult = zxcvbn(password, yas__extraWords);+    feedback = jsResult.feedback;+  }++  if (gotScore) { score = strength.score; }+  else {          score = jsResult.score; }++  yas__passwordMeter.classList.add("yas--strength-" + score);+  yas__passwordMeter.classList.remove("yas--strength-init");+  for (var i=0; i<5; i++) {+    if (i !== score) {+      yas__passwordMeter.classList.remove("yas--strength-" + i);+    }+  }++  var warningEl = yas__passwordErrors.querySelector(".yas--password-warning");+  while (warningEl.firstChild) { warningEl.removeChild(warningEl.firstChild); }++  var tips = yas__passwordErrors.querySelector(".yas--password-suggestions");+  while (tips && tips.firstChild) { tips.removeChild(tips.firstChild); }++  if (Boolean(password) && score < #{toJSON $ fromEnum minStren}) {+    var warning;+    if (Boolean(strength.error)) {+      warning = strength.error;+    } else {+      warning = "The password is not strong enough";+    }+    if (Boolean(feedback.warning)) {+      warning = warning + ". " + feedback.warning;+    }+    warningEl.appendChild(document.createTextNode(warning));++    if (feedback.suggestions.length > 0) {+      var suggestionList = document.createElement("ul");+      for (var i=0; i<feedback.suggestions.length; i++) {+        var li = document.createElement("li");+        var txt = document.createTextNode(feedback.suggestions[i]);+        li.classList.add("yas--suggestion");+        li.appendChild(txt);+        suggestionList.appendChild(li);+      }+      tips.appendChild(suggestionList);+    }+  }+}++var yas_currentReq = 0;+function yas_getPasswordStrength(password) {+  var req = new XMLHttpRequest();+  var reqNum = yas_currentReq + 1;+  req.onreadystatechange = function(resp) {+    if (req.readyState === XMLHttpRequest.DONE) {+      if (req.status === 200) {+        var resp = JSON.parse(req.responseText);+        if (reqNum <= yas_currentReq) {+          yas_updateFeedback(password, resp);+        }+      } else {+        yas_updateFeedback("", #{toJSON blankPasswordScore});+        yas_showError();+      }+    }+  };+  req.open("POST", "@{toParent passwordStrengthR}", true);+  req.setRequestHeader("Content-Type", "application/x-www-form-urlencoded");+  req.send(#{defaultCsrfParamName} + "=" + #{fromMaybe "no-csrf-token" mCsrfToken}+           + "&password=" + encodeURIComponent(password));+  yas_currentReq += 1;+}++function yas_debounce(delay, fn) {+  var timeout;+  return function () {+    if (timeout) { clearTimeout(timeout); }+    timeout = setTimeout(fn.apply.bind(fn, this, arguments), delay);+  };+}++var yas_getPasswordStrengthDeb = yas_debounce(200, yas_getPasswordStrength);++function yas_onPasswordChange(e) {+  if (Boolean(e.target.value) && e.target.value.length < #{toJSON maxPasswordLength}) {+      yas_getPasswordStrengthDeb(e.target.value);+  } else if (!Boolean(e.target.value)) {+    yas_updateFeedback("", #{toJSON blankPasswordScore});+  }+}++document.getElementById("password").addEventListener("input", yas_onPasswordChange);
+ templates/password-field-zxcvbn.lucius view
@@ -0,0 +1,38 @@+.yas--extra-words { display: none; }+.yas--password-meter-container {+  height: 5px;+  background-color: #C7C7C7;+  .yas--password-meter {+    height: 100%;+    transition: background-color 1s, margin-right 1s;+  }+  .yas--password-meter.yas--strength-init {+    margin-right: 100%;+  }+  .yas--password-meter.yas--strength-0 {+    background-color: #ff0000;+    margin-right: 90%;+  }+  .yas--password-meter.yas--strength-1 {+    background-color: #ff0000;+    margin-right: 75%;+  }+  .yas--password-meter.yas--strength-2 {+    background-color: #ffa500;+    margin-right: 50%;+  }+  .yas--password-meter.yas--strength-3 {+    background-color: #008000;+    margin-right: 25%;+  }+  .yas--password-meter.yas--strength-4 {+    background-color: #008000;+    margin-right: 0%;+  }+ }+ .yas--password-suggestions ul {+   margin-left: 2em;+   margin-bottom: 0;+   list-style: disc;+   font-size: 90%;+ }
+ templates/redirect.hamlet view
@@ -0,0 +1,4 @@+$newline never+<p>Content has moved, click+  <a href="@{destUrl}">here+
+ templates/register-success.hamlet view
@@ -0,0 +1,4 @@+$newline never+<.register-success>+  <h1>Account created!+
+ templates/register.hamlet view
@@ -0,0 +1,19 @@+$newline never+$maybe err <- mErr+  <div class="alert">#{err}++<.register>+  <h1>Register new account+  <form method="post" action="@{toParent registerR}">+    ^{honeypotFieldTemplate}+    <fieldset>+      <label for="email">Email+      <input#email+        type="email"+        name="email"+        placeholder="Enter your email address"+        autofocus+        required>+    <button type="submit">Register+    <p>Already have an account? <a href="@{toParent loginR}">Sign in</a>.+
+ templates/reset-password-email-sent.hamlet view
@@ -0,0 +1,6 @@+$newline never+<.password-reset-email-sent>+  <h1>Email Sent!+  <p>An email has been sent to your address provided that a corresponding user account exists in our system.+  <p>Click on the link in the email to complete the password reset.+
+ templates/reset-password.hamlet view
@@ -0,0 +1,13 @@+$newline never+$maybe err <- mErr+  <div class="alert">#{err}++<.reset-password>+  <h1>Reset Password+  <p>Did you forget your password? No problem.+  <p>Give us your email address, and we'll send you reset instructions.+  <form method="post" action="@{toParent resetPasswordR}">+    <fieldset>+      <label for="email">Email+      <input type="email" name="email" autofocus required>+    <button type="submit">Reset
+ templates/set-password.hamlet view
@@ -0,0 +1,10 @@+$newline never+$maybe err <- mErr+  <div class="alert">#{err}++<h1>Set new password+<form method="post" action="@{url}">+  ^{csrfTokenTemplate}+  ^{pwField}+  <button type="submit">Save+
+ templates/too-many-login-attempts.hamlet view
@@ -0,0 +1,5 @@+$newline never+<.too-many-attempts>+  <h1>Too many login attempts+  <p>You have been locked out from your account until #{formatted} GMT+
+ templates/user-exists.hamlet view
@@ -0,0 +1,5 @@+$newline never+<.user-exists>+  <h1>Failed to create account+  <p>User already exists+
+ test/ExampleApp.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module ExampleApp where++import ClassyPrelude.Yesod+import Data.Coerce (coerce)+import qualified Data.Vector as Vec+import Database.Persist.Sql+import Yesod.Auth+import Yesod.Auth.Simple+import Yesod.Auth.Simple.Instance.Persist.EmailText ()+import Yesod.Auth.Simple.Instance.Persist.PasswordText ()+import Yesod.Core.Types (Logger)++data App = App+  { appLogger   :: Logger+  , appConnPool :: ConnectionPool+  }++instance RenderRoute App => Yesod App++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+User+  email Email+  password Password+  UniqueUser email+  deriving Show++Token+  email Email+  hashed Text+  deriving Show+|]+++mkYesod "App" [parseRoutes|+/auth AuthR Auth getAuth+/ HomeR GET+|]++instance YesodAuth App where+  type AuthId App = Key User+  loginDest _ = HomeR+  logoutDest _ = HomeR+  authPlugins _ = [ authSimple ]+  getAuthId = return . fromPathPiece . credsIdent+  maybeAuthId = defaultMaybeAuthId++getHomeR :: Handler ()+getHomeR = pure ()++++instance YesodPersist App where+  type YesodPersistBackend App = SqlBackend++  runDB :: SqlPersistT Handler a -> Handler a+  runDB db = getsYesod appConnPool >>= runSqlPool db+++getTestToken ::+  ( PersistStoreWrite (YesodPersistBackend (HandlerSite m))+  , YesodPersist (HandlerSite m)+  , MonadHandler m+  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend)+  => Email -> m Text+getTestToken email = do+  t <- liftIO genToken+  storeToken email $ hashAndEncodeToken t+  pure $ encodeToken t++storeToken ::+  ( PersistStoreWrite (YesodPersistBackend (HandlerSite f))+  , YesodPersist (HandlerSite f)+  , MonadHandler f+  , BaseBackend (YesodPersistBackend (HandlerSite f)) ~ SqlBackend)+  => Email -> Text -> f ()+storeToken e t = void . liftHandler . runDB . insert $ Token e t++instance YesodAuthSimple App where+  type AuthSimpleId App = Key User++  getUserId email' = liftHandler . runDB $ do+    let email = Email . toLower . coerce $ email'+    res <- getBy $ UniqueUser email+    return $ case res of+      Just (Entity uid _) -> Just uid+      _                   -> Nothing++  getUserPassword = do+    let mkPass = EncryptedPass . encodeUtf8 . coerce . userPassword+    liftHandler . runDB . fmap mkPass . get404++  afterPasswordRoute = error "forced afterPasswordRoute"+  updateUserPassword = error "forced updateUserPassword"++  sendVerifyEmail email _ = storeToken email+  sendResetPasswordEmail email _ = storeToken email++  matchRegistrationToken hashed = liftHandler . runDB $ do+    ents <- selectList [TokenHashed ==. hashed] [LimitTo 1]+    pure $ tokenEmail . entityVal <$> listToMaybe ents++  matchPasswordToken hashed = liftHandler . runDB $ do+    ents <- selectList [TokenHashed ==. hashed] [LimitTo 1]+    -- mEmail <- userEmail . entityVal <$> listToMaybe ents+    case tokenEmail . entityVal <$> listToMaybe ents of+      Just em -> fmap (fmap entityKey) $ getBy $ UniqueUser em+      Nothing -> pure Nothing++  onRegisterSuccess = sendResponseStatus ok200 ()+  insertUser _email _pass = pure . Just $ (toSqlKey 1 :: Key User)+  passwordCheck = Zxcvbn Safe (Vec.fromList ["yesod"])++instance YesodAuthPersist App++instance RenderMessage App FormMessage where+  renderMessage _ _ = defaultFormMessage
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module TestImport+  ( module TestImport+  , module X+  ) where++import ClassyPrelude as X hiding (Handler, delete, deleteBy)+import Control.Monad.Logger (runLoggingT)+import Database.Persist as X hiding (get)+import Database.Persist.Sql+       (SqlPersistM, runMigration, runSqlPersistMPool, runSqlPool)+import Database.Persist.Sqlite (createSqlitePool)+import ExampleApp as X+import System.Directory+import System.Log.FastLogger (newStdoutLoggerSet)+import Test.Hspec as X+import Yesod hiding (get)+import Yesod.Auth.Simple as X+import Yesod.Core as X+import Yesod.Core.Unsafe (fakeHandlerGetLogger)+import Yesod.Default.Config2 (makeYesodLogger)+import Yesod.Test as X++withApp :: SpecWith (TestApp App) -> Spec+withApp = before $ do+  appLogger <- newStdoutLoggerSet 1 >>= makeYesodLogger++  let mkFoundation appConnPool = App {..}+      tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"+      logFunc = messageLoggerSource tempFoundation appLogger++  removeIfExists "auth.sqlite3"+  pool <- flip runLoggingT logFunc $ createSqlitePool "auth.sqlite3" 10+  runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc+  pure (mkFoundation pool, defaultMiddlewaresNoLogging)++runHandler :: Handler a -> YesodExample App a+runHandler handler = do+  app <- getTestYesod+  fakeHandlerGetLogger appLogger app handler++runDB' :: SqlPersistM a -> YesodExample App a+runDB' query = do+  app <- getTestYesod+  liftIO $ runDBWithApp app query++runDBWithApp :: App -> SqlPersistM a -> IO a+runDBWithApp app query = runSqlPersistMPool query (appConnPool app)++removeIfExists :: FilePath -> IO ()+removeIfExists f = do+  fileExists <- doesFileExist f+  when fileExists (removeFile f)++-- | Follow a redirect and discard the result+followRedirect_ :: Yesod a => YesodExample a ()+followRedirect_ = void followRedirect
+ test/Yesod/Auth/Simple/TypesSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Auth.Simple.TypesSpec (spec) where++import Data.Aeson (encode)+import TestImport++spec :: Spec+spec =++  describe "Password" $ do++    describe "Show instance" $+      it "redacts password hash" $+        show (Password "strongpass hashed") `shouldBe` "<redacted>"++    describe "ToJSON instance" $+      it "redacts password" $+        encode (Password "strongpass hashed") `shouldBe` "\"strongpass hashed\""
+ test/Yesod/Auth/SimpleSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Yesod.Auth.SimpleSpec (spec) where++import qualified Data.Text as T+import TestImport++register :: Text -> YesodExample App ()+register email = request $ do+  setMethod "POST"+  setUrl $ AuthR registerR+  byLabelExact "Email" email++confirm :: Text -> YesodExample App ()+confirm password = request $ do+  addToken+  setMethod "POST"+  setUrl $ AuthR confirmR+  byLabelExact "Password" password++spec :: Spec+spec = withApp $ do++  describe "registration" $ do++    it "renders the registration form" $ do+      get $ AuthR registerR+      statusIs 200+      htmlCount "input[type=email]" 1+      htmlCount "button[type=submit]" 1++    describe "with a valid email address" $++      it "renders the confirmation email sent page" $ do+        let email = "user@example.com"+        get $ AuthR registerR+        register email+        followRedirect_+        statusIs 200+        bodyContains "Email sent"++    describe "with an invalid email address" $++      it "returns the user to the registration form with an error" $ do+        let email = "not_an_email"+        ur <- runHandler getUrlRender+        get $ AuthR registerR+        register email+        followRedirect >>=+          assertEq "path is registration form" (Right (ur (AuthR registerR)))++  describe "confirmation" $ do++    describe "with a weak password" $++      it "returns the user to the confirmation form with an error" $ do+        let email = "user@example.com"+        ur <- runHandler getUrlRender+        t <- runHandler . getTestToken $ Email email+        get $ AuthR $ confirmTokenR t+        followRedirect_+        -- NB: The following password would be fine without the+        -- commonDomainWords definition+        confirm "hello yesod 123"+        followRedirect >>=+          assertEq "path is confirmation form" (Right (ur (AuthR confirmR)))++    describe "with a password that is too long" $+      it "caps length at 150" $ do+        let email = "user@example.com"+            -- Not using a simple, eg, "a" replicate because that+            -- causes a bug hopefully soon fixed:+            -- github.com/sthenauth/zxcvbn-hs/issues/2+            password = T.replicate 12 "one two three" -- 156 chars+        ur <- runHandler getUrlRender+        t <- runHandler . getTestToken $ Email email+        get $ AuthR $ confirmTokenR t+        followRedirect_+        confirm password+        followRedirect >>=+          assertEq "path is confirmation form" (Right (ur (AuthR confirmR)))++    describe "with an adequately strong password" $++      it "inserts a new user" $ do+        let email = "user@example.com"+        ur <- runHandler getUrlRender+        get $ AuthR registerR+        register email+        token <- runHandler . getTestToken $ Email email+        get $ AuthR $ confirmTokenR token+        followRedirect_+        request $ do+          setMethod "POST"+          setUrl $ AuthR confirmR+          addToken_ "form"+          byLabelExact "Password" "really difficult yesod password here"+        followRedirect >>=+          assertNotEq "path is not confirmation form" (Right (ur (AuthR confirmR)))++    describe "with an invalid token" $++      it "renders the invalid token page" $ do+        let token = "not_a_valid_token"+        get $ AuthR registerR+        request $ do+          setMethod "POST"+          setUrl $ AuthR registerR+          byLabelExact "Email" "user@example.com"+        get $ AuthR $ confirmTokenR token+        followRedirect_+        statusIs 400++    describe "with an email that is not unique" $++      it "automatically authenticates the existing user" $ do+        encrypted <- liftIO $ encryptPassIO' $ Pass "strongpass"+        let userEmail = Email  "user@example.com"+            userPassword = Password . decodeUtf8 . getEncryptedPass $ encrypted+        runDB' . insert_ $ User{..}++        token <- runHandler $ getTestToken userEmail -- encryptRegisterToken userEmail+        get $ AuthR $ confirmTokenR token+        followRedirect_+        statusIs 303+        ur <- runHandler getUrlRender+        followRedirect >>= assertEq "redirection successful" (Right $ ur HomeR)
+ yesod-auth-simple.cabal view
@@ -0,0 +1,123 @@+Cabal-Version:          2.2+Name:                   yesod-auth-simple+Version:                1.1.0+Author:                 Jezen Thomas <jezen@jezenthomas.com>+Maintainer:             Jezen Thomas <jezen@jezenthomas.com>+License:                BSD-3-Clause+License-File:           LICENSE+Build-Type:             Simple+Extra-Source-Files:+    README.md+  , ChangeLog.md+  , templates/*.hamlet+  , templates/*.julius+  , templates/*.lucius+Category:               Web, Yesod+Synopsis:               Traditional email/pass auth for Yesod.+Description:+  This is an authentication plugin for the Yesod web framework. It provides the+  user with a traditional email and password interface to authenticate themselves+  with your web application.+  .+  This is originally adapted from prasmussen/glot-www++Library+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+  GHC-Options:          -Wall+  Default-Extensions:   NoImplicitPrelude+  Other-Extensions: TemplateHaskell+  Exposed-Modules:+    Yesod.Auth.Simple+    Yesod.Auth.Simple.Instance.Persist.EmailText+    Yesod.Auth.Simple.Instance.Persist.EmailTextCI+    Yesod.Auth.Simple.Instance.Persist.PasswordText+  Build-Depends:+      base >= 4 && < 5+    , aeson+    , base16-bytestring+    , base64-bytestring+    , bytestring+    , classy-prelude        >= 0.10.2+    , classy-prelude-yesod  >= 1.1+    , cryptonite+    , email-validate+    , http-types+    , memory+    , scrypt+    , text+    , time+    , wai+    , blaze-html+    , vector+    , zxcvbn-hs+    , yesod-auth >= 1.6+    , yesod-core >= 1.6+    , yesod-form >= 1.6+    , persistent >= 2.8.2+    , shakespeare++  Other-Modules:+    Yesod.Auth.Simple.Types++Common test-properties+  Default-Language:     Haskell2010+  Hs-Source-Dirs:       src, test+  Ghc-Options:          -Wall+  Default-Extensions:   NoImplicitPrelude+  Build-Tool-Depends:   hspec-discover:hspec-discover -any+  Build-Depends:+      base >= 4 && < 5+    , hspec+    , aeson+    , base64-bytestring+    , blaze-html+    , bytestring+    , classy-prelude        >= 0.10.2+    , classy-prelude-yesod  >= 1.1+    , cryptonite+    , directory+    , email-validate+    , fast-logger+    , http-types+    , memory+    , monad-logger+    , persistent >= 2.8.2+    , persistent-sqlite+    , scrypt+    , text+    , time+    , vector+    , wai+    , yesod+    , yesod-test+    , yesod-auth >= 1.6+    , yesod-form >=1.6+    , yesod-core >=1.6.15+    , zxcvbn-hs+    , shakespeare++  Other-Modules:+    ExampleApp+    TestImport+    Yesod.Auth.Simple+    Yesod.Auth.Simple.Instance.Persist.EmailText+    Yesod.Auth.Simple.Instance.Persist.EmailTextCI+    Yesod.Auth.Simple.Instance.Persist.PasswordText+    Yesod.Auth.Simple.Types+    Yesod.Auth.SimpleSpec+    Yesod.Auth.Simple.TypesSpec++Test-Suite spec+  Import:               test-properties+  Type:                 exitcode-stdio-1.0+  Main-Is:              Spec.hs++Executable yesod-auth-simple-test+  Import:               test-properties+  Other-Extensions: TemplateHaskell+  Main-Is:              Spec.hs++Source-Repository head+  Type:                 git+  Location:             https://github.com/riskbook/yesod-auth-simple