yesod-auth-account 1.1.0.1 → 1.2.0

raw patch · 7 files changed

+230/−227 lines, 7 filesdep +hspecdep ~persistentdep ~yesod-authdep ~yesod-corePVP ok

version bump matches the API change (PVP)

Dependencies added: hspec

Dependency ranges changed: persistent, yesod-auth, yesod-core, yesod-form, yesod-persistent

API changes (from Hackage documentation)

Files

• Yesod/Auth/Account.hs +125/−134
• example.hs +3/−2
• tests/BasicTests.hs +33/−33
• tests/Foundation.hs +13/−2
• tests/NewAccount.hs +45/−46
• tests/main.hs +4/−4
• yesod-auth-account.cabal +7/−6

@@ -51,7 +51,7 @@ --   just logs a message so during development this class requires no implementation. -- -- * Make your master site and database an instance of 'YesodAuthAccount'.  There is only---   one required function which must be implemented ('runAccountDatabase') although there+--   one required function which must be implemented ('runAccountDB') although there --   are several functions you can override in this class to customize the behavior of this --   module. --@@ -113,14 +113,12 @@ import Control.Monad.Reader hiding (lift) import Data.Char (isAlphaNum) import System.Random (newStdGen, randoms)-import Text.Blaze.Html (toHtml) import qualified Crypto.PasswordStore as PS import qualified Data.ByteString as B import qualified Data.ByteString.Base64.URL as B64 import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Database.Persist as P-import qualified Database.Persist.Query.Internal as P (Update)  import Yesod.Core import Yesod.Form@@ -181,7 +179,7 @@ -- >    renderMessage _ _ = defaultFormMessage -- > -- >instance YesodPersist MyApp where--- >    type YesodPersistBackend MyApp = SqlPersist+-- >    type YesodPersistBackend MyApp = SqlPersistT -- >    runDB action = do -- >        MyApp pool <- getYesod -- >        runSqlPool action pool@@ -194,6 +192,7 @@ -- >    authPlugins _ = [accountPlugin] -- >    authHttpManager _ = error "No manager needed" -- >    onLogin = return ()+-- >    maybeAuthId = lookupSession "_ID" -- > -- >instance AccountSendEmail MyApp -- >@@ -215,7 +214,7 @@ -- >main :: IO () -- >main = withSqlitePool "test.db3" 10 $ \pool -> do -- >    runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool--- >    warpDebug 3000 $ MyApp pool+-- >    warp 3000 $ MyApp pool -- accountPlugin :: YesodAuthAccount db master => AuthPlugin master accountPlugin = AuthPlugin "account" dispatch loginWidget@@ -308,7 +307,8 @@ -- You can embed this form into your own pages if you want a custom rendering of this -- form or to include a login form on your own pages. The form submission should be -- posted to 'loginFormPostTargetR'.-loginForm :: YesodAuthAccount db master => AForm s master LoginData+loginForm :: (MonadHandler m, YesodAuthAccount db master, HandlerSite m ~ master)+          => AForm m LoginData loginForm = LoginData <$> areq (checkM checkValidUsername textField) userSettings Nothing                       <*> areq passwordField pwdSettings Nothing     where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing []@@ -318,9 +318,9 @@ -- -- This is the widget used in the default implementation of 'loginHandler'. -- The widget also includes links to the new account and reset password pages.-loginWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> GWidget s master ()+loginWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> WidgetT master IO () loginWidget tm = do-    ((_,widget), enctype) <- lift $ runFormPostNoToken $ renderDivs loginForm+    ((_,widget), enctype) <- liftHandlerT $ runFormPostNoToken $ renderDivs loginForm     [whamlet| <div .loginDiv>     <form method=post enctype=#{enctype} action=@{tm loginFormPostTargetR}>@@ -331,15 +331,15 @@         <a href="@{tm resetPasswordR}">_{MsgForgotPassword} |] -postLoginR :: YesodAuthAccount db master => GHandler Auth master RepHtml+postLoginR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) RepHtml postLoginR = do-    ((result, _), _) <- runFormPostNoToken $ renderDivs loginForm+    ((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm     mr <- getMessageRender     muser <- case result of                 FormMissing -> invalidArgs ["Form is missing"]                 FormFailure msg -> return $ Left msg                 FormSuccess (LoginData uname pwd) -> do-                    mu <- runAccountDB $ loadUser uname+                    mu <- lift $ runAccountDB $ loadUser uname                     case mu of                         Nothing -> return $ Left [mr MsgInvalidUserOrPwd]                         Just u -> return $@@ -347,14 +347,13 @@                                 then Right u                                 else Left [mr MsgInvalidUserOrPwd]     -    tm <- getRouteToMaster     case muser of         Left errs -> do             setMessage $ toHtml $ T.concat errs-            redirect $ tm LoginR+            redirect LoginR          Right u -> if userEmailVerified u-                        then do setCreds True $ Creds "account" (username u) []+                        then do lift $ setCreds True $ Creds "account" (username u) []                                 -- setCreds should redirect so we will never get here                                 badMethod                         else unregisteredLogin u@@ -402,7 +401,11 @@ -- form into a larger form where you prompt for more information during account -- creation.  In this case, the NewAccountData should be passed to 'createNewAccount' -- from inside 'postNewAccountR'.-newAccountForm :: (YesodAuth m, RenderMessage m FormMessage) => AForm s m NewAccountData+newAccountForm :: (YesodAuth master+                  , RenderMessage master FormMessage+                  , MonadHandler m+                  , HandlerSite m ~ master+                  ) => AForm m NewAccountData newAccountForm = NewAccountData <$> areq textField userSettings Nothing                                 <*> areq emailField emailSettings Nothing                                 <*> areq passwordField pwdSettings1 Nothing@@ -413,9 +416,9 @@           pwdSettings2  = FieldSettings (SomeMessage Msg.ConfirmPass) Nothing Nothing Nothing []  -- | A default rendering of the 'newAccountForm' using renderDivs.-newAccountWidget :: (YesodAuth m, RenderMessage m FormMessage) => (Route Auth -> Route m) -> GWidget s m ()+newAccountWidget :: (YesodAuth master, RenderMessage master FormMessage) => (Route Auth -> Route master) -> WidgetT master IO () newAccountWidget tm = do-    ((_,widget), enctype) <- lift $ runFormPost $ renderDivs newAccountForm+    ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs newAccountForm     [whamlet| <div .newaccountDiv>     <form method=post enctype=#{enctype} action=@{tm newAccountR}>@@ -431,7 +434,7 @@ -- be run first in your handler.  Note that this action does not check if the passwords -- are equal. If an error occurs (username exists, etc.) this will set a message and -- redirect to 'newAccountR'.-createNewAccount :: YesodAuthAccount db master => NewAccountData -> (Route Auth -> Route master) -> GHandler s master (UserAccount db)+createNewAccount :: YesodAuthAccount db master => NewAccountData -> (Route Auth -> Route master) -> HandlerT master IO (UserAccount db) createNewAccount (NewAccountData u email pwd _) tm = do     muser <- runAccountDB $ loadUser u     case muser of@@ -453,34 +456,36 @@     setMessageI $ Msg.ConfirmationEmailSent email     return new -getVerifyR :: YesodAuthAccount db master => Username -> T.Text -> GHandler Auth master ()+getVerifyR :: YesodAuthAccount db master => Username -> T.Text -> HandlerT Auth (HandlerT master IO) () getVerifyR uname k = do-    tm <- getRouteToMaster-    muser <- runAccountDB $ loadUser uname+    muser <- lift $ runAccountDB $ loadUser uname     case muser of-        Nothing -> do setMessageI Msg.InvalidKey-                      redirect $ tm LoginR+        Nothing -> do lift $ setMessageI Msg.InvalidKey+                      redirect LoginR         Just user -> do when (    userEmailVerifyKey user == ""                                 || userEmailVerifyKey user /= k                                || userEmailVerified user                              ) $ do-                            setMessageI Msg.InvalidKey-                            redirect $ tm LoginR-                        runAccountDB $ verifyAccount user+                            lift $ setMessageI Msg.InvalidKey+                            redirect LoginR+                        lift $ runAccountDB $ verifyAccount user                         setMessageI MsgEmailVerified-                        setCreds True $ Creds "account" uname []+                        lift $ setCreds True $ Creds "account" uname []  -- | A form to allow the user to request the email validation be resent. -- -- Intended for use in 'unregisteredLogin'.  The result should be posted to -- 'resendVerifyR'.-resendVerifyEmailForm :: RenderMessage m FormMessage => Username -> AForm s m Username+resendVerifyEmailForm :: (RenderMessage master FormMessage+                         , MonadHandler m+                         , HandlerSite m ~ master+                         ) => Username -> AForm m Username resendVerifyEmailForm u = areq hiddenField "" $ Just u  -- | A default rendering of 'resendVerifyEmailForm'-resendVerifyEmailWidget :: RenderMessage m FormMessage => Username -> (Route Auth -> Route m) -> GWidget s m ()+resendVerifyEmailWidget :: RenderMessage master FormMessage => Username -> (Route Auth -> Route master) -> WidgetT master IO () resendVerifyEmailWidget u tm = do-    ((_,widget), enctype) <- lift $ runFormPost $ renderDivs $ resendVerifyEmailForm u+    ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs $ resendVerifyEmailForm u     [whamlet| <div .resendVerifyEmailDiv>     <form method=post enctype=#{enctype} action=@{tm resendVerifyR}>@@ -488,25 +493,24 @@         <input type=submit value=_{MsgResendVerifyEmail}> |] -postResendVerifyEmailR :: YesodAuthAccount db master => GHandler Auth master ()+postResendVerifyEmailR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) () postResendVerifyEmailR = do-    ((result, _), _) <- runFormPost $ renderDivs $ resendVerifyEmailForm ""+    ((result, _), _) <- lift $ runFormPost $ renderDivs $ resendVerifyEmailForm ""     muser <- case result of                 FormMissing -> invalidArgs ["Form is missing"]                 FormFailure msg -> invalidArgs msg-                FormSuccess uname -> runAccountDB $ loadUser uname+                FormSuccess uname -> lift $ runAccountDB $ loadUser uname      case muser of         -- The username is a hidden field so it should be correct.  No need to set a message or redirect.         Nothing -> invalidArgs ["Invalid username"]          Just u  -> do             key <- newVerifyKey-            tm <- getRouteToMaster-            runAccountDB $ setVerifyKey u key+            lift $ runAccountDB $ setVerifyKey u key             render <- getUrlRender-            sendVerifyEmail (username u) (userEmail u) $ render $ tm $ verifyR (username u) key-            setMessageI $ Msg.ConfirmationEmailSent (userEmail u)-            redirect $ tm LoginR+            lift $ sendVerifyEmail (username u) (userEmail u) $ render $ verifyR (username u) key+            lift $ setMessageI $ Msg.ConfirmationEmailSent (userEmail u)+            redirect LoginR  --------------------------------------------------------------------------------------------------- @@ -537,14 +541,17 @@ -- | A form for the user to request that an email be sent to them to allow them to reset -- their password.  This form contains a field for the username (plus the CSRF token). -- The form should be posted to 'resetPasswordR'.-resetPasswordForm :: RenderMessage m FormMessage => AForm s m Username+resetPasswordForm :: (RenderMessage master FormMessage+                     , MonadHandler m+                     , HandlerSite m ~ master+                     ) => AForm m Username resetPasswordForm = areq textField userSettings Nothing     where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing []  -- | A default rendering of 'resetPasswordForm'.-resetPasswordWidget :: RenderMessage m FormMessage => (Route Auth -> Route m) -> GWidget s m ()+resetPasswordWidget :: RenderMessage master FormMessage => (Route Auth -> Route master) -> WidgetT master IO () resetPasswordWidget tm = do-    ((_,widget), enctype) <- lift $ runFormPost $ renderDivs resetPasswordForm+    ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs resetPasswordForm     [whamlet| <div .resetPasswordDiv>     <form method=post enctype=#{enctype} action=@{tm resetPasswordR}>@@ -552,33 +559,32 @@         <input type=submit value=_{MsgSendResetPwdEmail}> |] -postResetPasswordR :: YesodAuthAccount db master => GHandler Auth master RepHtml+postResetPasswordR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) RepHtml postResetPasswordR = do-    allow <- allowPasswordReset <$> getYesod+    allow <- allowPasswordReset <$> lift getYesod     unless allow notFound-    tm <- getRouteToMaster-    ((result, _), _) <- runFormPost $ renderDivs resetPasswordForm+    ((result, _), _) <- lift $ runFormPost $ renderDivs resetPasswordForm     mdata <- case result of                 FormMissing -> invalidArgs ["Form is missing"]                 FormFailure msg -> return $ Left msg-                FormSuccess uname -> Right <$> runAccountDB (loadUser uname)+                FormSuccess uname -> Right <$> lift (runAccountDB (loadUser uname))      case mdata of         Left errs -> do             setMessage $ toHtml $ T.concat errs-            redirect $ tm LoginR+            redirect LoginR          Right Nothing -> do             setMessageI MsgInvalidUsername-            redirect $ tm resetPasswordR+            redirect resetPasswordR          Right (Just u) -> do key <- newVerifyKey-                             runAccountDB $ setNewPasswordKey u key+                             lift $ runAccountDB $ setNewPasswordKey u key                              render <- getUrlRender-                             sendNewPasswordEmail (username u) (userEmail u) $ render $ tm $ newPasswordR (username u) key+                             lift $ sendNewPasswordEmail (username u) (userEmail u) $ render $ newPasswordR (username u) key                              -- Don't display the email in the message since anybody can request the resend.                              setMessageI MsgResetPwdEmailSent-                             redirect $ tm LoginR+                             redirect LoginR  -- | The data for setting a new password. data NewPasswordData = NewPasswordData {@@ -590,10 +596,10 @@  -- | The form for setting a new password. It contains hidden fields for the username and key and prompts -- for the passwords.  This form should be posted to 'setPasswordR'.-newPasswordForm :: (YesodAuth m, RenderMessage m FormMessage)+newPasswordForm :: (YesodAuth master, RenderMessage master FormMessage, MonadHandler m, HandlerSite m ~ master)                 => Username                  -> T.Text -- ^ key-                -> AForm s m NewPasswordData+                -> AForm m NewPasswordData newPasswordForm u k = NewPasswordData <$> areq hiddenField "" (Just u)                                       <*> areq hiddenField "" (Just k)                                       <*> areq passwordField pwdSettings1 Nothing@@ -602,10 +608,10 @@           pwdSettings2 = FieldSettings (SomeMessage Msg.ConfirmPass) Nothing Nothing Nothing []  -- | A default rendering of 'newPasswordForm'.-newPasswordWidget :: YesodAuthAccount db master => UserAccount db -> (Route Auth -> Route master) -> GWidget s master ()+newPasswordWidget :: YesodAuthAccount db master => UserAccount db -> (Route Auth -> Route master) -> WidgetT master IO () newPasswordWidget user tm = do     let key = userResetPwdKey user-    ((_,widget), enctype) <- lift $ runFormPost $ renderDivs (newPasswordForm (username user) key)+    ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs (newPasswordForm (username user) key)     [whamlet| <div .newpassDiv>     <p>_{Msg.SetPass}@@ -614,38 +620,36 @@         <input type=submit value=_{Msg.SetPassTitle}> |] -getNewPasswordR :: YesodAuthAccount db master => Username -> T.Text -> GHandler Auth master RepHtml+getNewPasswordR :: YesodAuthAccount db master => Username -> T.Text -> HandlerT Auth (HandlerT master IO) RepHtml getNewPasswordR uname k = do-    allow <- allowPasswordReset <$> getYesod+    allow <- allowPasswordReset <$> lift getYesod     unless allow notFound-    muser <- runAccountDB $ loadUser uname-    tm <- getRouteToMaster+    muser <- lift $ runAccountDB $ loadUser uname     case muser of         Just user | userResetPwdKey user /= "" && userResetPwdKey user == k ->             setPasswordHandler user -        _ -> do setMessageI Msg.InvalidKey-                redirect $ tm LoginR+        _ -> do lift $ setMessageI Msg.InvalidKey+                redirect LoginR -postSetPasswordR :: YesodAuthAccount db master => GHandler Auth master ()+postSetPasswordR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) () postSetPasswordR = do-    allow <- allowPasswordReset <$> getYesod+    allow <- allowPasswordReset <$> lift getYesod     unless allow notFound-    tm <- getRouteToMaster-    ((result,_), _) <- runFormPost $ renderDivs (newPasswordForm "" "")+    ((result,_), _) <- lift $ runFormPost $ renderDivs (newPasswordForm "" "")     mnew <- case result of                 FormMissing -> invalidArgs ["Form is missing"]                 FormFailure msg -> return $ Left msg                 FormSuccess d | newPasswordPwd1 d == newPasswordPwd2 d -> return $ Right d-                FormSuccess d -> do setMessageI Msg.PassMismatch-                                    redirect $ tm $ newPasswordR (newPasswordUser d) (newPasswordKey d)+                FormSuccess d -> do lift $ setMessageI Msg.PassMismatch+                                    redirect $ newPasswordR (newPasswordUser d) (newPasswordKey d)      case mnew of         Left errs -> do             setMessage $ toHtml $ T.concat errs-            redirect $ tm LoginR+            redirect LoginR -        Right d -> do muser <- runAccountDB $ loadUser (newPasswordUser d)+        Right d -> do muser <- lift $ runAccountDB $ loadUser (newPasswordUser d)                       case muser of                         -- username is a hidden field so it should be correct.  No need to set a message and redirect.                         Nothing -> permissionDenied "Invalid username"@@ -655,9 +659,9 @@                               when (newPasswordKey d /= userResetPwdKey user) $ permissionDenied "Invalid key"                                hashed <- hashPassword (newPasswordPwd1 d)-                              runAccountDB $ setNewPassword user hashed-                              setMessageI Msg.PassUpdated-                              setCreds True $ Creds "account" (newPasswordUser d) []+                              lift $ runAccountDB $ setNewPassword user hashed+                              lift $ setMessageI Msg.PassUpdated+                              lift $ setCreds True $ Creds "account" (newPasswordUser d) []  --------------------------------------------------------------------------------------------------- @@ -689,11 +693,7 @@     userEmailVerifiedF  :: P.EntityField u Bool     userEmailVerifyKeyF :: P.EntityField u T.Text     userResetPwdKeyF    :: P.EntityField u T.Text-#if 1     uniqueUsername      :: T.Text -> P.Unique u-#else-    uniqueUsername      :: T.Text -> P.Unique u (P.PersistEntityBackend u)-#endif      -- | Creates a new user for use during 'addNewUser'.  The starting reset password     -- key should be the empty string.@@ -707,24 +707,21 @@ -- -- Persistent users can use 'AccountPersistDB' and don't need to create their own instance. -- If you are not using persistent or are using persistent but want to customize the database--- activity, you must manually create an instance.  The kind of @b@ is @* -> * -> *@.  The first--- type argument to @b@ is a subsite, and @b sub@ should be a monad which embeds--- @GHandler sub master a@.  It is unfortunate that the order of sub and master must be flipped,--- so you will need a newtype.  For example,+-- activity, you must manually make a monad an instance of this class.  You can use any monad+-- for which you can write 'runAccountDB', but typically the monad will be a newtype of HandlerT.+-- For example, ----- > newtype MyAccountDB sub a = MyAccountDB {runMyAccountDB :: GHandler sub MyApp a}--- >    deriving (Monad, MonadIO)--- > instance MonadLift (GHandler sub MyApp) (MyAccountDB sub) where--- >     lift = MyAccountDB+-- > newtype MyAccountDB a = MyAccountDB {runMyAccountDB :: HandlerT MyApp IO a}+-- >    deriving (Monad, MonadIO, MonadTrans, MonadHandler) -- > instance AccountDB MyAccountDB where -- >     .... ---class AccountDB b where+class AccountDB m where     -- | The data type which stores the user.  Must be an instance of 'UserCredentials'.-    type UserAccount b+    type UserAccount m      -- | Load a user by username-    loadUser :: Username -> b sub (Maybe (UserAccount b))+    loadUser :: Username -> m (Maybe (UserAccount m))      -- | Create new account.  The password reset key should be added as an empty string.     -- The creation can fail with an error message, in which case the error is set in a@@ -733,27 +730,27 @@                -> T.Text       -- ^ unverified email                -> T.Text       -- ^ the email verification key                -> B.ByteString -- ^ hashed and salted password-               -> b sub (Either T.Text (UserAccount b))+               -> m (Either T.Text (UserAccount m))      -- | Mark the account as successfully verified.  This should reset the email validation key     -- to the empty string.-    verifyAccount :: UserAccount b -> b sub ()+    verifyAccount :: UserAccount m -> m ()      -- | Change/set the users email verification key.-    setVerifyKey :: UserAccount b +    setVerifyKey :: UserAccount m                   -> T.Text -- ^ the verification key-                 -> b sub ()+                 -> m ()      -- | Change/set the users password reset key.-    setNewPasswordKey :: UserAccount b+    setNewPasswordKey :: UserAccount m                       -> T.Text -- ^ the key-                      -> b sub ()+                      -> m ()      -- | Set a new hashed password.  This should also set the password reset key to the empty     -- string.-    setNewPassword :: UserAccount b+    setNewPassword :: UserAccount m                    -> B.ByteString -- ^ hashed password-                   -> b sub ()+                   -> m ()  -- | A class to send email. --@@ -763,7 +760,7 @@     sendVerifyEmail :: Username                     -> T.Text -- ^ email address                     -> T.Text -- ^ verification URL-                    -> GHandler s master ()+                    -> HandlerT master IO ()     sendVerifyEmail uname email url =         $(logInfo) $ T.concat [ "Verification email for "                               , uname@@ -774,7 +771,7 @@     sendNewPasswordEmail :: Username                          -> T.Text -- ^ email address                          -> T.Text -- ^ new password URL-                         -> GHandler s master ()+                         -> HandlerT master IO ()     sendNewPasswordEmail uname email url =         $(logInfo) $ T.concat [ "Reset password email for "                               , uname@@ -807,7 +804,7 @@       ) => YesodAuthAccount db master | master -> db where      -- | Run a database action.  This is the only required method.-    runAccountDB :: db sub a -> GHandler sub master a+    runAccountDB :: db a -> HandlerT master IO a      -- | A form validator for valid usernames during new account creation.     --@@ -815,7 +812,8 @@     -- this validation and instead validate in 'addNewUser', but validating here     -- allows the validation to occur before database activity (checking existing     -- username) and before random salt creation (requires IO).-    checkValidUsername :: Username -> GHandler s master (Either T.Text Username)+    checkValidUsername :: (MonadHandler m, HandlerSite m ~ master) +                       => Username -> m (Either T.Text Username)     checkValidUsername u | T.all isAlphaNum u = return $ Right u     checkValidUsername _ = do         mr <- getMessageRender@@ -826,10 +824,10 @@     -- By default, this displays a message and contains 'resendVerifyEmailForm', allowing     -- the user to resend the verification email.  The handler is run inside the post     -- handler for login, so you can call 'setCreds' to preform a successful login.-    unregisteredLogin :: UserAccount db -> GHandler Auth master RepHtml+    unregisteredLogin :: UserAccount db -> HandlerT Auth (HandlerT master IO) RepHtml     unregisteredLogin u = do-        tm <- getRouteToMaster-        defaultLayout $ do+        tm <- getRouteToParent+        lift $ defaultLayout $ do             setTitleI MsgEmailUnverified             [whamlet| <p>_{MsgEmailUnverified}@@ -840,10 +838,10 @@     --     -- This is the page which is displayed on a GET to 'newAccountR', and defaults to     -- an embedding of 'newAccountWidget'.-    getNewAccountR :: GHandler Auth master RepHtml+    getNewAccountR :: HandlerT Auth (HandlerT master IO) RepHtml     getNewAccountR = do-        tm <- getRouteToMaster-        defaultLayout $ do+        tm <- getRouteToParent+        lift $ defaultLayout $ do             setTitleI Msg.RegisterLong             newAccountWidget tm @@ -852,11 +850,11 @@     -- By default, this processes 'newAccountForm', calls 'createNewAccount', sets a message     -- and redirects to LoginR.  If an error occurs, a message is set and the user is     -- redirected to 'newAccountR'.-    postNewAccountR :: GHandler Auth master RepHtml+    postNewAccountR :: HandlerT Auth (HandlerT master IO) RepHtml     postNewAccountR = do-        tm <- getRouteToMaster-        mr <- getMessageRender-        ((result, _), _) <- runFormPost $ renderDivs newAccountForm+        tm <- getRouteToParent+        mr <- lift getMessageRender+        ((result, _), _) <- lift $ runFormPost $ renderDivs newAccountForm         mdata <- case result of                     FormMissing -> invalidArgs ["Form is missing"]                     FormFailure msg -> return $ Left msg@@ -866,10 +864,10 @@         case mdata of             Left errs -> do                 setMessage $ toHtml $ T.concat errs-                redirect $ tm newAccountR+                redirect newAccountR -            Right d -> do void $ createNewAccount d tm-                          redirect $ tm LoginR+            Right d -> do void $ lift $ createNewAccount d tm+                          redirect LoginR      -- | Should the password reset inside this plugin be allowed?  Defaults to True     allowPasswordReset :: master -> Bool@@ -877,10 +875,10 @@      -- | The page which prompts for a username and sends an email allowing password reset.     --   By default, it embeds 'resetPasswordWidget'.-    getResetPasswordR :: GHandler Auth master RepHtml+    getResetPasswordR :: HandlerT Auth (HandlerT master IO) RepHtml     getResetPasswordR = do-        tm <- getRouteToMaster-        defaultLayout $ do+        tm <- getRouteToParent+        lift $ defaultLayout $ do             setTitleI MsgResetPwdTitle             resetPasswordWidget tm @@ -888,10 +886,10 @@     --     -- This is called only when the email key has been verified as correct. By default, it embeds     -- 'newPasswordWidget'.-    setPasswordHandler :: UserAccount db -> GHandler Auth master RepHtml+    setPasswordHandler :: UserAccount db -> HandlerT Auth (HandlerT master IO) RepHtml     setPasswordHandler u = do-        tm <- getRouteToMaster-        defaultLayout $ do+        tm <- getRouteToParent+        lift $ defaultLayout $ do             setTitleI Msg.SetPassTitle             newPasswordWidget u tm @@ -930,14 +928,14 @@     userResetPwdKey u = u ^. fieldLens userResetPwdKeyF  -- | Internal state for the AccountPersistDB monad.-data PersistFuncs master user sub = PersistFuncs {-      pGet :: T.Text -> GHandler sub master (Maybe (P.Entity user))-    , pInsert :: Username -> user -> GHandler sub master (Either T.Text (P.Entity user))-    , pUpdate :: P.Entity user -> [P.Update user] -> GHandler sub master ()+data PersistFuncs master user = PersistFuncs {+      pGet :: T.Text -> HandlerT master IO (Maybe (P.Entity user))+    , pInsert :: Username -> user -> HandlerT master IO (Either T.Text (P.Entity user))+    , pUpdate :: P.Entity user -> [P.Update user] -> HandlerT master IO () }  -- | A newtype which when using persistent is an instance of 'AccountDB'.-newtype AccountPersistDB master user sub a = AccountPersistDB (ReaderT (PersistFuncs master user sub) (GHandler sub master) a)+newtype AccountPersistDB master user a = AccountPersistDB (ReaderT (PersistFuncs master user) (HandlerT master IO) a)     deriving (Monad, MonadIO)  instance (Yesod master, PersistUserCredentials user) => AccountDB (AccountPersistDB master user) where@@ -975,18 +973,11 @@                        , P.PersistEntity user                        , PersistUserCredentials user                        , b ~ YesodPersistBackend master-#if 1-                       , P.PersistMonadBackend (b (GHandler sub master)) ~ P.PersistEntityBackend user-                       , P.PersistUnique (b (GHandler sub master))-                       , P.PersistQuery (b (GHandler sub master))-#else-                       , b ~ P.PersistEntityBackend user-                       , P.PersistUnique b (GHandler sub master)-                       , P.PersistQuery b (GHandler sub master)-#endif-    +                       , PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend user+                       , P.PersistUnique (b (HandlerT master IO))+                       , P.PersistQuery (b (HandlerT master IO))                        ) -                       => AccountPersistDB master user sub a -> GHandler sub master a+                       => AccountPersistDB master user a -> HandlerT master IO a runAccountPersistDB (AccountPersistDB m) = runReaderT m funcs     where funcs = PersistFuncs {                       pGet = runDB . P.getBy . uniqueUsername

@@ -46,7 +46,7 @@     renderMessage _ _ = defaultFormMessage  instance YesodPersist MyApp where-    type YesodPersistBackend MyApp = SqlPersist+    type YesodPersistBackend MyApp = SqlPersistT     runDB action = do         MyApp pool <- getYesod         runSqlPool action pool@@ -59,6 +59,7 @@     authPlugins _ = [accountPlugin]     authHttpManager _ = error "No manager needed"     onLogin = return ()+    maybeAuthId = lookupSession "_ID"  instance AccountSendEmail MyApp @@ -80,5 +81,5 @@ main :: IO () main = withSqlitePool "test.db3" 10 $ \pool -> do     runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool-    warpDebug 3000 $ MyApp pool+    warp 3000 $ MyApp pool 

@@ -2,80 +2,80 @@ module BasicTests (basicSpecs) where  import Yesod.Test-import Database.Persist.Sqlite+import Foundation -basicSpecs :: SpecsConn Connection+basicSpecs :: YesodSpec MyApp basicSpecs =-    describe "Basic tests" $ do-        it "checks the home page is not logged in" $ do-            get_ "/"+    ydescribe "Basic tests" $ do+        yit "checks the home page is not logged in" $ do+            get' "/"             statusIs 200             bodyContains "Please visit the <a href=\"/auth/login\">Login page" -        it "tests an invalid login" $ do-            get_ "/auth/login"+        yit "tests an invalid login" $ do+            get' "/auth/login"             statusIs 200 -            post "/auth/page/account/login" $ do+            post' "/auth/page/account/login" $ do                 byLabel "Username" "abc"                 byLabel "Password" "xxx"              statusIs 303-            get_ "/auth/login"+            get' "/auth/login"             statusIs 200             bodyContains "Invalid username or password" -        it "new account page looks ok" $ do-            get_ "/auth/page/account/newaccount"+        yit "new account page looks ok" $ do+            get' "/auth/page/account/newaccount"             statusIs 200             htmlAllContain "title" "Register a new account"             bodyContains "Register" -        it "reset password page looks ok" $ do-            get_ "/auth/page/account/resetpassword"+        yit "reset password page looks ok" $ do+            get' "/auth/page/account/resetpassword"             statusIs 200             bodyContains "Send email to reset password" -            post "/auth/page/account/resetpassword" $ do+            post' "/auth/page/account/resetpassword" $ do                 byLabel "Username" "abc"                 addNonce              statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "Invalid username" -        it "verify page returns an error" $ do-            get_ "/auth/page/account/verify/abc/xxxxxx"+        yit "verify page returns an error" $ do+            get' "/auth/page/account/verify/abc/xxxxxx"             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "invalid verification key" -        it "new password returns an error" $ do-            get_ "/auth/page/account/newpassword/abc/xxxxxx"+        yit "new password returns an error" $ do+            get' "/auth/page/account/newpassword/abc/xxxxxx"             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "invalid verification key" -        it "set password returns an error" $ do-            post "/auth/page/account/setpassword" $ do-                byName "f1" "xxx"-                byName "f2" "xxx"-                byName "f3" "xxx"-                byName "f4" "xxx"-                byName "f5" "xxx"+        yit "set password returns an error" $ do+            post' "/auth/page/account/setpassword" $ do+                addPostParam "f1" "xxx"+                addPostParam "f2" "xxx"+                addPostParam "f3" "xxx"+                addPostParam "f4" "xxx"+                addPostParam "f5" "xxx"              statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "As a protection against cross-site" -        it "resend verify email returns an error" $ do-            post "/auth/page/account/resendverifyemail" $ do-                byName "f1" "xxx"-                byName "f2" "xxx"+        yit "resend verify email returns an error" $ do+            post' "/auth/page/account/resendverifyemail" $ do+                addPostParam "f1" "xxx"+                addPostParam "f2" "xxx"              statusIs 400             bodyContains "As a protection against cross-site"

@@ -8,11 +8,11 @@ import Data.ByteString (ByteString) import Database.Persist.Sqlite import Data.IORef-import Control.Monad.Trans (MonadIO) import System.IO.Unsafe (unsafePerformIO) import Yesod import Yesod.Auth import Yesod.Auth.Account+import Yesod.Test  share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| User@@ -64,7 +64,7 @@     renderMessage _ _ = defaultFormMessage  instance YesodPersist MyApp where-    type YesodPersistBackend MyApp = SqlPersist+    type YesodPersistBackend MyApp = SqlPersistT     runDB action = do         MyApp pool <- getYesod         runSqlPool action pool@@ -77,6 +77,7 @@     authPlugins _ = [accountPlugin]     authHttpManager _ = error "No manager needed"     onLogin = return ()+    maybeAuthId = lookupSession "_ID"  instance AccountSendEmail MyApp where     sendVerifyEmail name email url =@@ -99,3 +100,13 @@ <p>You are logged in as #{u} <p><a href="@{AuthR LogoutR}">Logout</a> |]++-- Temporary helpers for testing+get' :: Yesod site => Text -> YesodExample site ()+get' url = Yesod.Test.get url++post' :: Yesod site => Text -> RequestBuilder site () -> YesodExample site ()+post' url builder = request $ do+    setUrl url+    setMethod "POST"+    builder

@@ -1,21 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module NewAccount (newAccountSpecs) where +import Yesod.Auth import Yesod.Test import Foundation-import Database.Persist.Sqlite import Text.XML.Cursor (attribute)-import qualified Data.Text.Encoding as T -newAccountSpecs :: SpecsConn Connection+newAccountSpecs :: YesodSpec MyApp newAccountSpecs =-    describe "New account tests" $ do-        it "new account with mismatched passwords" $ do-            get_ "/auth/page/account/newaccount"+    ydescribe "New account tests" $ do+        yit "new account with mismatched passwords" $ do+            get' "/auth/page/account/newaccount"             statusIs 200             bodyContains "Register" -            post "/auth/page/account/newaccount" $ do+            post'"/auth/page/account/newaccount" $ do                 addNonce                 byLabel "Username" "abc"                 byLabel "Email" "test@example.com"@@ -23,15 +22,15 @@                 byLabel "Confirm" "yyy"              statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "Passwords did not match" -        it "creates a new account" $ do-            get_ "/auth/page/account/newaccount"+        yit "creates a new account" $ do+            get' "/auth/page/account/newaccount"             statusIs 200 -            post "/auth/page/account/newaccount" $ do+            post'"/auth/page/account/newaccount" $ do                 addNonce                 byLabel "Username" "abc"                 byLabel "Email" "test@example.com"@@ -39,7 +38,7 @@                 byLabel "Confirm" "xxx"              statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "A confirmation e-mail has been sent to test@example.com" @@ -47,36 +46,36 @@             assertEqual "username" username "abc"             assertEqual "email" email "test@example.com" -            get_ "/auth/page/account/verify/abc/zzzzzz"+            get' "/auth/page/account/verify/abc/zzzzzz"             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "invalid verification key"              -- try login-            get_ "/auth/login"+            get' "/auth/login"             statusIs 200-            post "/auth/page/account/login" $ do+            post'"/auth/page/account/login" $ do                 byLabel "Username" "abc"                 byLabel "Password" "yyy"             statusIs 303-            get_ "/auth/login"+            get' "/auth/login"             statusIs 200             bodyContains "Invalid username or password"              -- valid login-            post "/auth/page/account/login" $ do+            post'"/auth/page/account/login" $ do                 byLabel "Username" "abc"                 byLabel "Password" "xxx"             statusIs 200             bodyContains "Your email has not yet been verified"              -- resend verify email-            post "/auth/page/account/resendverifyemail" $ do+            post'"/auth/page/account/resendverifyemail" $ do                 addNonce-                byName "f2" "abc" -- username is also a hidden field+                addPostParam "f2" "abc" -- username is also a hidden field             statusIs 303-            get_ "/"+            get' "/"             bodyContains "A confirmation e-mail has been sent to test@example.com"              (username', email', verify') <- lastVerifyEmail@@ -85,39 +84,39 @@             assertEqual "verify" True (verify /= verify')              -- verify email-            get_ $ T.encodeUtf8 verify'+            get' verify'             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "You are logged in as abc" -            post_ "/auth/logout"+            post $ AuthR LogoutR             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "Please visit the <a href=\"/auth/login\">Login page"              -- valid login-            get_ "/auth/login"-            post "/auth/page/account/login" $ do+            get' "/auth/login"+            post'"/auth/page/account/login" $ do                 byLabel "Username" "abc"                 byLabel "Password" "xxx"             statusIs 303-            get_ "/"+            get' "/"             bodyContains "You are logged in as abc"              -- logout-            post_ "/auth/logout"+            post $ AuthR LogoutR              -- reset password-            get_ "/auth/page/account/resetpassword"+            get' "/auth/page/account/resetpassword"             statusIs 200             bodyContains "Send email to reset password"-            post "/auth/page/account/resetpassword" $ do+            post'"/auth/page/account/resetpassword" $ do                 byLabel "Username" "abc"                 addNonce             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "A password reset email has been sent to your email address" @@ -126,44 +125,44 @@             assertEqual "Email" email'' "test@example.com"              -- bad key-            get_ $ T.encodeUtf8 newpwd+            get' newpwd             statusIs 200-            post "/auth/page/account/setpassword" $ do+            post'"/auth/page/account/setpassword" $ do                 addNonce                 byLabel "New password" "www"                 byLabel "Confirm" "www"-                byName "f2" "abc"-                byName "f3" "qqqqqqqqqqqqqq"+                addPostParam "f2" "abc"+                addPostParam "f3" "qqqqqqqqqqqqqq"             statusIs 403             bodyContains "Invalid key"              -- good key-            get_ $ T.encodeUtf8 newpwd+            get' newpwd             statusIs 200-            post "/auth/page/account/setpassword" $ do+            matches <- htmlQuery "input[name=f3][type=hidden][value]"+            post'"/auth/page/account/setpassword" $ do                 addNonce                 byLabel "New password" "www"                 byLabel "Confirm" "www"-                byName "f2" "abc"-                matches <- htmlQuery "input[name=f3][type=hidden][value]"+                addPostParam "f2" "abc"                 key <- case matches of                           [] -> error "Unable to find set password key"                           element:_ -> return $ head $ attribute "value" $ parseHTML element-                byName "f3" key+                addPostParam "f3" key             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "Password updated"             bodyContains "You are logged in as abc" -            post_ "/auth/logout"+            post $ AuthR LogoutR              -- check new password-            get_ "/auth/login"-            post "/auth/page/account/login" $ do+            get' "/auth/login"+            post'"/auth/page/account/login" $ do                 byLabel "Username" "abc"                 byLabel "Password" "www"             statusIs 303-            get_ "/"+            get' "/"             statusIs 200             bodyContains "You are logged in as abc"

@@ -4,6 +4,7 @@  import Yesod import Foundation+import Test.Hspec import Yesod.Test import Database.Persist.Sqlite import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)@@ -16,7 +17,6 @@ main = withSqlitePool "test.db3" 10 $ \pool -> do           runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool           runResourceT $ runNoLoggingT $ runSqlPool (deleteWhere ([] :: [Filter User])) pool-          let myapp = MyApp pool-          app <- toWaiAppPlain myapp-          runTests app pool basicSpecs-          runTests app pool newAccountSpecs+          hspec $ yesodSpec (MyApp pool) $ do+              basicSpecs+              newAccountSpecs

@@ -1,5 +1,5 @@ name:              yesod-auth-account-version:           1.1.0.1+version:           1.2.0 cabal-version:     >= 1.8 build-type:        Simple synopsis:          An account authentication plugin for Yesod@@ -37,13 +37,13 @@                  , blaze-html        >= 0.6                  , mtl               >= 2.1                  , text              >= 0.11-                 , persistent        >= 1.1.5.1    && < 1.2+                 , persistent        >= 1.2        && < 1.3                  , pwstore-fast      >= 2.0                  , random            >= 1.0-                 , yesod-auth        >= 1.1        && < 1.2-                 , yesod-core        >= 1.1        && < 1.2-                 , yesod-form        >= 1.2        && < 1.3-                 , yesod-persistent  >= 1.1+                 , yesod-auth        >= 1.2        && < 1.3+                 , yesod-core        >= 1.2        && < 1.3+                 , yesod-form        >= 1.3        && < 1.4+                 , yesod-persistent  >= 1.2  test-suite test     type:              exitcode-stdio-1.0@@ -53,6 +53,7 @@      build-depends: base                  , bytestring+                 , hspec                  , monad-logger >= 0.3                  , mtl                  , persistent-sqlite