Merge remote-tracking branch 'origin/master' into persistent2-simpler-dispatch

Conflicts:
	yesod-auth/Yesod/Auth/HashDB.hs

yesod-auth/Yesod/Auth.hs

@@ -23,6 +23,7 @@ module Yesod.Auth
       -- * Plugin interface
     , Creds (..)
     , setCreds
+    , setCredsRedirect
     , clearCreds
     , loginErrorMessage
     , loginErrorMessageI
@@ -37,6 +38,9 @@ module Yesod.Auth
     , AuthHandler
       -- * Internal
     , credsKey
+    , provideJsonMessage
+    , messageJson401
+    , asHtml
     ) where
 
 import Control.Monad                 (when)
@@ -65,6 +69,7 @@ import Control.Exception (Exception)
 import Network.HTTP.Types          (unauthorized401)
 import Control.Monad.Trans.Resource (MonadResourceBase)
 import qualified Control.Monad.Trans.Writer    as Writer
+import Control.Monad (void)
 
 type AuthRoute = Route Auth
 
@@ -75,7 +80,7 @@ type Piece = Text
 
 data AuthPlugin master = AuthPlugin
     { apName :: Text
-    , apDispatch :: Method -> [Piece] -> AuthHandler master ()
+    , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
     , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
     }
 
@@ -189,9 +194,6 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     onErrorHtml dest msg = do
         setMessage $ toHtml msg
         fmap asHtml $ redirect dest
-        where
-          asHtml :: Html -> Html
-          asHtml = id
 
 -- | Internal session key used to hold the authentication information.
 --
@@ -270,7 +272,7 @@ cachedAuth aid = runMaybeT $ do
 loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
                    => Route child
                    -> AuthMessage
-                   -> HandlerT child (HandlerT master m) a
+                   -> HandlerT child (HandlerT master m) TypedContent
 loginErrorMessageI dest msg = do
   toParent <- getRouteToParent
   lift $ loginErrorMessageMasterI (toParent dest) msg
@@ -279,7 +281,7 @@ loginErrorMessageI dest msg = do
 loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
          => Route master
          -> AuthMessage
-         -> HandlerT master m a
+         -> HandlerT master m TypedContent
 loginErrorMessageMasterI dest msg = do
   mr <- getMessageRender
   loginErrorMessage dest (mr msg)
@@ -289,47 +291,55 @@ loginErrorMessageMasterI dest msg = do
 loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
          => Route master
          -> Text
-         -> HandlerT master m a
-loginErrorMessage dest msg =
-  sendResponseStatus unauthorized401 =<< (
-    selectRep $ do
-      provideRep $ do
-          onErrorHtml dest msg
-      provideJsonMessage msg
-  )
+         -> HandlerT master m TypedContent
+loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
+
+messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
+messageJson401 msg html = selectRep $ do
+    provideRep html
+    provideRep $ do
+        let obj = object ["message" .= msg]
+        void $ sendResponseStatus unauthorized401 obj
+        return obj
 
 provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
 provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
 
 
+setCredsRedirect :: YesodAuth master
+         => Creds master -- ^ new credentials
+         -> HandlerT master IO TypedContent
+setCredsRedirect creds = do
+    y    <- getYesod
+    maid <- getAuthId creds
+    case maid of
+        Nothing ->
+            case authRoute y of
+                Nothing -> do
+                    messageJson401 "Invalid Login" $ authLayout $
+                        toWidget [shamlet|<h1>Invalid login|]
+                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
+        Just aid -> do
+            setSession credsKey $ toPathPiece aid
+            onLogin
+            res <- selectRep $ do
+                provideRepType typeHtml $
+                    fmap asHtml $ redirectUltDest $ loginDest y
+                provideJsonMessage "Login Successful"
+            sendResponse res
+
 -- | Sets user credentials for the session after checking them with authentication backends.
 setCreds :: YesodAuth master
          => Bool         -- ^ if HTTP redirects should be done
          -> Creds master -- ^ new credentials
          -> HandlerT master IO ()
-setCreds doRedirects creds = do
-    y    <- getYesod
-    maid <- getAuthId creds
-    case maid of
-        Nothing -> when doRedirects $ do
-            case authRoute y of
-                Nothing -> do
-                    sendResponseStatus unauthorized401 =<< (
-                      selectRep $ do
-                        provideRep $ authLayout $ toWidget [shamlet|<h1>Invalid login|]
-                        provideJsonMessage "Invalid Login"
-                      )
-                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
-        Just aid -> do
-            setSession credsKey $ toPathPiece aid
-            when doRedirects $ do
-              onLogin
-              res <- selectRep $ do
-                  provideRepType typeHtml $ do
-                      _ <- redirectUltDest $ loginDest y
-                      return ()
-                  provideJsonMessage "Login Successful"
-              sendResponse res
+setCreds doRedirects creds =
+    if doRedirects
+      then void $ setCredsRedirect creds
+      else do maid <- getAuthId creds
+              case maid of
+                  Nothing -> return ()
+                  Just aid -> setSession credsKey $ toPathPiece aid
 
 -- | same as defaultLayoutJson, but uses authLayout
 authLayoutJson :: (YesodAuth site, ToJSON j)
@@ -388,7 +398,7 @@ getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
 postLogoutR :: AuthHandler master ()
 postLogoutR = lift $ clearCreds True
 
-handlePluginR :: Text -> [Text] -> AuthHandler master ()
+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
 handlePluginR plugin pieces = do
     master <- lift getYesod
     env <- waiRequest
@@ -500,3 +510,6 @@ instance Exception AuthException
 
 instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
     yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
+
+asHtml :: Html -> Html
+asHtml = id

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -77,7 +77,7 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
                       $logErrorS "yesod-auth" "BrowserID assertion failure"
                       tm <- getRouteToParent
                       lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
-                    Just email -> lift $ setCreds True Creds
+                    Just email -> lift $ setCredsRedirect Creds
                         { credsPlugin = pid
                         , credsIdent = email
                         , credsExtra = []

yesod-auth/Yesod/Auth/Dummy.hs

@@ -18,7 +18,7 @@ authDummy =
   where
     dispatch "POST" [] = do
         ident <- lift $ runInputPost $ ireq textField "ident"
-        lift $ setCreds True $ Creds "dummy" ident []
+        lift $ setCredsRedirect $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster =

yesod-auth/Yesod/Auth/Email.hs

@@ -46,8 +46,8 @@ import qualified Crypto.PasswordStore as PS
 import qualified Text.Email.Validate
 import qualified Yesod.Auth.Message as Msg
 import Control.Applicative ((<$>), (<*>))
+import Control.Monad (void)
 import Yesod.Form
-import Control.Monad (when)
 import Data.Time (getCurrentTime, addUTCTime)
 import Safe (readMay)
 
@@ -83,7 +83,11 @@ data EmailCreds site = EmailCreds
     , emailCredsEmail :: Email
     }
 
-class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
+class ( YesodAuth site
+      , PathPiece (AuthEmailId site)
+      , (RenderMessage site Msg.AuthMessage)
+      )
+  => YesodAuthEmail site where
     type AuthEmailId site
 
     -- | Add a new email address to the database, but indicate that the address
@@ -172,10 +176,14 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
     -- | Response after sending a confirmation email.
     --
     -- Since 1.2.2
-    confirmationEmailSentResponse :: Text -> HandlerT site IO Html
-    confirmationEmailSentResponse identifier = authLayout $ do
-        setTitleI Msg.ConfirmationEmailSentTitle
-        [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
+    confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
+    confirmationEmailSentResponse identifier = do
+        mr <- getMessageRender
+        messageJson401 (mr msg) $ authLayout $ do
+              setTitleI Msg.ConfirmationEmailSentTitle
+              [whamlet|<p>_{msg}|]
+      where
+        msg = Msg.ConfirmationEmailSent identifier
 
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
@@ -218,7 +226,7 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
          -- field for the old password should be presented.
          -- Otherwise, just two fields for the new password are
          -- needed.
-      -> AuthHandler site Html
+      -> AuthHandler site TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
 
@@ -280,40 +288,46 @@ defaultRegisterHandler = do
 registerHelper :: YesodAuthEmail master
                => Bool -- ^ allow usernames?
                -> Route Auth
-               -> HandlerT Auth (HandlerT master IO) Html
+               -> HandlerT Auth (HandlerT master IO) TypedContent
 registerHelper allowUsername dest = do
     y <- lift getYesod
     midentifier <- lookupPostParam "email"
-    identifier <-
-        case midentifier of
-            Nothing -> loginErrorMessageI dest Msg.NoIdentifierProvided
+    let eidentifier = case midentifier of
+            Nothing -> Left Msg.NoIdentifierProvided
             Just x
                 | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
-                    return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
-                | allowUsername -> return $ TS.strip x
-                | otherwise -> loginErrorMessageI dest Msg.InvalidEmailAddress
+                    Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
+                | allowUsername -> Right $ TS.strip x
+                | otherwise -> Left Msg.InvalidEmailAddress
 
-    mecreds <- lift $ getEmailCreds identifier
-    (lid, verKey, email) <-
-        case mecreds of
-            Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
-            Just (EmailCreds lid _ _ Nothing email) -> do
-                key <- liftIO $ randomKey y
-                lift $ setVerifyKey lid key
-                return (lid, key, email)
-            Nothing
-                | allowUsername ->
-                    loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
-                | otherwise -> do
-                    key <- liftIO $ randomKey y
-                    lid <- lift $ addUnverified identifier key
-                    return (lid, key, identifier)
-    render <- getUrlRender
-    let verUrl = render $ verify (toPathPiece lid) verKey
-    lift $ sendVerifyEmail email verKey verUrl
-    lift $ confirmationEmailSentResponse identifier
+    case eidentifier of
+        Left route -> loginErrorMessageI dest route
+        Right identifier -> do
 
-postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+            mecreds <- lift $ getEmailCreds identifier
+            registerCreds <-
+                case mecreds of
+                    Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
+                    Just (EmailCreds lid _ _ Nothing email) -> do
+                        key <- liftIO $ randomKey y
+                        lift $ setVerifyKey lid key
+                        return $ Just (lid, key, email)
+                    Nothing
+                        | allowUsername -> return Nothing
+                        | otherwise -> do
+                            key <- liftIO $ randomKey y
+                            lid <- lift $ addUnverified identifier key
+                            return $ Just (lid, key, identifier)
+
+            case registerCreds of
+                Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
+                Just (lid, verKey, email) -> do
+                    render <- getUrlRender
+                    let verUrl = render $ verify (toPathPiece lid) verKey
+                    lift $ sendVerifyEmail email verKey verUrl
+                    lift $ confirmationEmailSentResponse identifier
+
+postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postRegisterR = registerHelper False registerR
 
 getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
@@ -337,35 +351,43 @@ defaultForgotPasswordHandler = do
                 <button .btn>_{Msg.SendPasswordResetEmail}
         |]
 
-postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
            -> Text
-           -> HandlerT Auth (HandlerT site IO) Html
+           -> HandlerT Auth (HandlerT site IO) TypedContent
 getVerifyR lid key = do
     realKey <- lift $ getVerifyKey lid
     memail <- lift $ getEmail lid
+    mr <- lift getMessageRender
     case (realKey == Just key, memail) of
         (True, Just email) -> do
             muid <- lift $ verifyAccount lid
             case muid of
-                Nothing -> return ()
+                Nothing -> invalidKey mr
                 Just uid -> do
                     lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
-                    lift $ setMessageI Msg.AddressVerified
                     lift $ setLoginLinkKey uid
-                    redirect setpassR
-        _ -> return ()
-    lift $ authLayout $ do
-        setTitleI Msg.InvalidKey
+                    let msgAv = Msg.AddressVerified
+                    selectRep $ do
+                      provideRep $ do
+                        lift $ setMessageI msgAv
+                        fmap asHtml $ redirect setpassR
+                      provideJsonMessage $ mr msgAv
+        _ -> invalidKey mr
+  where
+    msgIk = Msg.InvalidKey
+    invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
+        setTitleI msgIk
         [whamlet|
 $newline never
-<p>_{Msg.InvalidKey}
+<p>_{msgIk}
 |]
 
-postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
+
+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postLoginR = do
     (identifier, pass) <- lift $ runInputPost $ (,)
         <$> ireq textField "email"
@@ -388,37 +410,40 @@ postLoginR = do
     let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
     case maid of
         Just email ->
-            lift $ setCreds True $ Creds
+            lift $ setCredsRedirect $ Creds
                 (if isEmail then "email" else "username")
                 email
                 [("verifiedEmail", email)]
-        Nothing -> do
+        Nothing ->
             loginErrorMessageI LoginR $
                 if isEmail
                     then Msg.InvalidEmailPass
                     else Msg.InvalidUsernamePass
 
-getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 getPasswordR = do
     maid <- lift maybeAuthId
     case maid of
-        Just _ -> return ()
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-    needOld <- maybe (return True) (lift . needOldPassword) maid
-    setPasswordHandler needOld
+        Just _ -> do
+            needOld <- maybe (return True) (lift . needOldPassword) maid
+            setPasswordHandler needOld
 
 -- | Default implementation of 'setPasswordHandler'.
 --
 -- Since: 1.2.6
-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master Html
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
 defaultSetPasswordHandler needOld = do
     tp <- getRouteToParent
     pass0 <- newIdent
     pass1 <- newIdent
     pass2 <- newIdent
-    lift $ authLayout $ do
-        setTitleI Msg.SetPassTitle
-        [whamlet|
+    mr <- lift getMessageRender
+    selectRep $ do
+      provideJsonMessage $ mr Msg.SetPass
+      provideRep $ lift $ authLayout $ do
+          setTitleI Msg.SetPassTitle
+          [whamlet|
 $newline never
 <h3>_{Msg.SetPass}
 <form method="post" action="@{tp setpassR}">
@@ -444,45 +469,52 @@ $newline never
                 <input type="submit" value=_{Msg.SetPassTitle}>
 |]
 
-postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postPasswordR = do
     maid <- lift maybeAuthId
-    aid <- case maid of
-            Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-            Just aid -> return aid
+    case maid of
+        Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
+        Just aid -> do
+            tm <- getRouteToParent
 
-    tm <- getRouteToParent
+            needOld <- lift $ needOldPassword aid
+            if not needOld then confirmPassword aid tm else do
+                current <- lift $ runInputPost $ ireq textField "current"
+                mrealpass <- lift $ getPassword aid
+                case mrealpass of
+                    Nothing ->
+                        lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
+                    Just realpass
+                        | isValidPass current realpass -> confirmPassword aid tm
+                        | otherwise ->
+                            lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
-    needOld <- lift $ needOldPassword aid
-    when needOld $ do
-        current <- lift $ runInputPost $ ireq textField "current"
-        mrealpass <- lift $ getPassword aid
-        case mrealpass of
-            Nothing ->
-                lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
-            Just realpass
-                | isValidPass current realpass -> return ()
-                | otherwise ->
-                    lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+  where
+    msgOk = Msg.PassUpdated
+    confirmPassword aid tm = do
+        (new, confirm) <- lift $ runInputPost $ (,)
+            <$> ireq textField "new"
+            <*> ireq textField "confirm"
 
-    (new, confirm) <- lift $ runInputPost $ (,)
-        <$> ireq textField "new"
-        <*> ireq textField "confirm"
-    when (new /= confirm) $
-        loginErrorMessageI setpassR Msg.PassMismatch
+        if new /= confirm
+          then loginErrorMessageI setpassR Msg.PassMismatch
+          else do
+              isSecure <- lift $ checkPasswordSecurity aid new
+              case isSecure of
+                  Left e -> lift $ loginErrorMessage (tm setpassR) e
+                  Right () -> do
+                      salted <- liftIO $ saltPass new
+                      y <- lift $ do
+                          setPassword aid salted
+                          deleteSession loginLinkKey
+                          setMessageI msgOk
+                          getYesod
 
-    isSecure <- lift $ checkPasswordSecurity aid new
-    case isSecure of
-        Left e -> lift $ loginErrorMessage (tm setpassR) e
-        Right () -> return ()
-
-    salted <- liftIO $ saltPass new
-    lift $ do
-        y <- getYesod
-        setPassword aid salted
-        setMessageI Msg.PassUpdated
-        deleteSession loginLinkKey
-        redirect $ afterPasswordRoute y
+                      mr <- lift getMessageRender
+                      selectRep $ do
+                        provideRep $
+                          fmap asHtml $ lift $ redirect $ afterPasswordRoute y
+                        provideJsonMessage (mr msgOk)
 
 saltLength :: Int
 saltLength = 5

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -69,19 +69,19 @@ authGoogleEmail =
         completeHelper posts
     dispatch _ _ = notFound
 
-completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
+completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper gets' = do
       master <- lift getYesod
       eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
       tm <- getRouteToParent
       either (onFailure tm) (onSuccess tm) eres
     where
-      onFailure tm err = do
+      onFailure tm err =
         lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
       onSuccess tm oir = do
               let OpenId.Identifier ident = OpenId.oirOpLocal oir
               memail <- lookupGetParam "openid.ext1.value.email"
               case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
-                  (Just email, True) -> lift $ setCreds True $ Creds pid email []
+                  (Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
                   (_, False)   -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
                   (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

yesod-auth/Yesod/Auth/HashDB.hs

@@ -1,327 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE ConstraintKinds            #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE CPP                        #-}
--------------------------------------------------------------------------------
--- |
--- Module      :  Yesod.Auth.HashDB
--- Copyright   :  (c) Patrick Brisbin 2010 
--- License     :  as-is
---
--- Maintainer  :  pbrisbin@gmail.com
--- Stability   :  Stable
--- Portability :  Portable
---
--- /WARNING/: This module was /not/ designed with security in mind, and is not
--- suitable for production sites. In the near future, it will likely be either
--- deprecated or rewritten to have a more secure implementation. For more
--- information, see: <https://github.com/yesodweb/yesod/issues/668>.
---
--- A yesod-auth AuthPlugin designed to look users up in Persist where
--- their user id's and a salted SHA1 hash of their password is stored.
---
--- Example usage:
---
--- > -- import the function
--- > import Auth.HashDB
--- >
--- > -- make sure you have an auth route
--- > mkYesodData "MyApp" [$parseRoutes|
--- > / RootR GET
--- > /auth AuthR Auth getAuth
--- > |]
--- >
--- >
--- > -- make your app an instance of YesodAuth using this plugin
--- > instance YesodAuth MyApp where
--- >    type AuthId MyApp = UserId
--- >
--- >    loginDest _  = RootR
--- >    logoutDest _ = RootR
--- >    getAuthId    = getAuthIdHashDB AuthR (Just . UniqueUser)
--- >    authPlugins  = [authHashDB (Just . UniqueUser)]
--- >
--- >
--- > -- include the migration function in site startup
--- > withServer :: (Application -> IO a) -> IO a
--- > withServer f = withConnectionPool $ \p -> do
--- >     runSqlPool (runMigration migrateUsers) p
--- >     let h = DevSite p
---
--- Note that function which converts username to unique identifier must be same.
---
--- Your app must be an instance of YesodPersist. and the username,
--- salt and hashed-passwords should be added to the database.
---
--- > echo -n 'MySaltMyPassword' | sha1sum
---
--- can be used to get the hash from the commandline.
---
--------------------------------------------------------------------------------
-module Yesod.Auth.HashDB
-    ( HashDBUser(..)
-    , Unique (..)
-    , setPassword
-      -- * Authentification
-    , validateUser
-    , authHashDB
-    , getAuthIdHashDB
-      -- * Predefined data type
-    , User
-    , UserGeneric (..)
-    , UserId
-    , EntityField (..)
-    , migrateUsers
-    ) where
-
-import Yesod.Persist
-import Yesod.Form
-import Yesod.Auth
-import Yesod.Core
-import Text.Hamlet (hamlet)
-
-import Control.Applicative         ((<$>), (<*>))
-import Control.Monad               (replicateM,liftM)
-import Data.Typeable
-
-import qualified Data.ByteString.Lazy.Char8 as BS (pack)
-import Data.Digest.Pure.SHA        (sha1, showDigest)
-import Data.Text                   (Text, pack, unpack, append)
-import Data.Maybe                  (fromMaybe)
-import System.Random               (randomRIO)
--- | Interface for data type which holds user info. It's just a
---   collection of getters and setters
-class HashDBUser user where
-  -- | Retrieve password hash from user data
-  userPasswordHash :: user -> Maybe Text
-  -- | Retrieve salt for password
-  userPasswordSalt :: user -> Maybe Text
-
-  -- | Deprecated for the better named setSaltAndPasswordHash 
-  setUserHashAndSalt :: Text    -- ^ Salt
-                     -> Text    -- ^ Password hash
-                     -> user -> user
-  setUserHashAndSalt = setSaltAndPasswordHash
-
-  -- | a callback for setPassword
-  setSaltAndPasswordHash :: Text    -- ^ Salt
-                     -> Text    -- ^ Password hash
-                     -> user -> user
-  setSaltAndPasswordHash = setUserHashAndSalt
-
--- | Generate random salt. Length of 8 is chosen arbitrarily
-randomSalt :: MonadIO m => m Text
-randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
-
--- | Calculate salted hash using SHA1.
-saltedHash :: Text              -- ^ Salt
-           -> Text              -- ^ Password
-           -> Text
-saltedHash salt = 
-  pack . showDigest . sha1 . BS.pack . unpack . append salt
-
--- | Set password for user. This function should be used for setting
---   passwords. It generates random salt and calculates proper hashes.
-setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
-setPassword pwd u = do salt <- randomSalt
-                       return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
-
-
-----------------------------------------------------------------
--- Authentification
-----------------------------------------------------------------
-
--- | Given a user ID and password in plaintext, validate them against
---   the database values.
-#if MIN_VERSION_persistent(2, 0, 0)
-validateUser :: ( YesodPersist yesod
-                , b ~ YesodPersistBackend yesod
-                , b ~ PersistEntityBackend user
-                , PersistUnique b
-                , PersistEntity user
-                , HashDBUser    user
-                ) => 
-                Unique user     -- ^ User unique identifier
-             -> Text            -- ^ Password in plaint-text
-             -> HandlerT yesod IO Bool
-#else
-validateUser :: ( YesodPersist yesod
-                , b ~ YesodPersistBackend yesod
-                , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
-                , PersistUnique (b (HandlerT yesod IO))
-                , PersistEntity user
-                , HashDBUser    user
-                ) => 
-                Unique user     -- ^ User unique identifier
-             -> Text            -- ^ Password in plaint-text
-             -> HandlerT yesod IO Bool
-#endif
-validateUser userID passwd = do
-  -- Checks that hash and password match
-  let validate u = do hash <- userPasswordHash u
-                      salt <- userPasswordSalt u
-                      return $ hash == saltedHash salt passwd
-  -- Get user data
-  user <- runDB $ getBy userID
-  return $ fromMaybe False $ validate . entityVal =<< user
-
-
-login :: AuthRoute
-login = PluginR "hashdb" ["login"]
-
-
--- | Handle the login form. First parameter is function which maps
---   username (whatever it might be) to unique user ID.
-#if MIN_VERSION_persistent(2, 0, 0)
-postLoginR :: ( YesodAuth y, YesodPersist y
-              , HashDBUser user, PersistEntity user
-              , b ~ YesodPersistBackend y
-              , b ~ PersistEntityBackend user
-              , PersistUnique b
-              )
-           => (Text -> Maybe (Unique user))
-           -> HandlerT Auth (HandlerT y IO) ()
-#else
-postLoginR :: ( YesodAuth y, YesodPersist y
-              , HashDBUser user, PersistEntity user
-              , b ~ YesodPersistBackend y
-              , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (HandlerT y IO))
-              )
-           => (Text -> Maybe (Unique user))
-           -> HandlerT Auth (HandlerT y IO) ()
-#endif
-postLoginR uniq = do
-    (mu,mp) <- lift $ runInputPost $ (,)
-        <$> iopt textField "username"
-        <*> iopt textField "password"
-
-    isValid <- lift $ fromMaybe (return False) 
-                 (validateUser <$> (uniq =<< mu) <*> mp)
-    if isValid 
-       then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
-       else do
-           tm <- getRouteToParent
-           lift $ loginErrorMessage (tm LoginR) "Invalid username/password"
-
-
--- | A drop in for the getAuthId method of your YesodAuth instance which
---   can be used if authHashDB is the only plugin in use.
-#if MIN_VERSION_persistent(2, 0, 0)
-getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-                   , HashDBUser user, PersistEntity user
-                   , Key user ~ AuthId master
-                   , b ~ YesodPersistBackend master
-                   , b ~ PersistEntityBackend user
-                   , PersistUnique b
-                   )
-                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-                -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-                -> Creds master                  -- ^ the creds argument
-                -> HandlerT master IO (Maybe (AuthId master))
-#else
-getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-                   , HashDBUser user, PersistEntity user
-                   , Key user ~ AuthId master
-                   , b ~ YesodPersistBackend master
-                   , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
-                   , PersistUnique (b (HandlerT master IO))
-                   )
-                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-                -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-                -> Creds master                  -- ^ the creds argument
-                -> HandlerT master IO (Maybe (AuthId master))
-#endif
-getAuthIdHashDB authR uniq creds = do
-    muid <- maybeAuthId
-    case muid of
-        -- user already authenticated
-        Just uid -> return $ Just uid
-        Nothing       -> do
-            x <- case uniq (credsIdent creds) of
-                   Nothing -> return Nothing
-                   Just u  -> runDB (getBy u)
-            case x of
-                -- user exists
-                Just (Entity uid _) -> return $ Just uid
-                Nothing       -> loginErrorMessage (authR LoginR) "User not found"
-
--- | Prompt for username and password, validate that against a database
---   which holds the username and a hash of the password
-#if MIN_VERSION_persistent(2, 0, 0)
-authHashDB :: ( YesodAuth m, YesodPersist m
-              , HashDBUser user
-              , PersistEntity user
-              , b ~ YesodPersistBackend m
-              , b ~ PersistEntityBackend user
-              , PersistUnique b
-              )
-           => (Text -> Maybe (Unique user)) -> AuthPlugin m
-#else
-authHashDB :: ( YesodAuth m, YesodPersist m
-              , HashDBUser user
-              , PersistEntity user
-              , b ~ YesodPersistBackend m
-              , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (HandlerT m IO)))
-           => (Text -> Maybe (Unique user)) -> AuthPlugin m
-#endif
-authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
-$newline never
-    <div id="header">
-        <h1>Login
-
-    <div id="login">
-        <form method="post" action="@{tm login}">
-            <table>
-                <tr>
-                    <th>Username:
-                    <td>
-                        <input id="x" name="username" autofocus="" required>
-                <tr>
-                    <th>Password:
-                    <td>
-                        <input type="password" name="password" required>
-                <tr>
-                    <td>&nbsp;
-                    <td>
-                        <input type="submit" value="Login">
-
-            <script>
-                if (!("autofocus" in document.createElement("input"))) {
-                    document.getElementById("x").focus();
-                }
-
-|]
-    where
-        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
-        dispatch _ _              = notFound
-
-
-----------------------------------------------------------------
--- Predefined datatype
-----------------------------------------------------------------
-
--- | Generate data base instances for a valid user
-share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
-         [persistUpperCase|
-User
-    username Text Eq
-    password Text
-    salt     Text
-    UniqueUser username
-    deriving Typeable
-|]
-
-instance HashDBUser (UserGeneric backend) where
-  userPasswordHash = Just . userPassword
-  userPasswordSalt = Just . userSalt
-  setSaltAndPasswordHash s h u = u { userSalt     = s
-                               , userPassword = h
-                               }

yesod-auth/Yesod/Auth/OpenId.hs

@@ -85,7 +85,7 @@ $newline never
         completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper idType gets' = do
     master <- lift getYesod
     eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
@@ -108,7 +108,7 @@ completeHelper idType gets' = do
                         case idType of
                             OPLocal -> OpenId.oirOpLocal oir
                             Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-            lift $ setCreds True $ Creds "openid" i gets''
+            lift $ setCredsRedirect $ Creds "openid" i gets''
 
 -- | The main identifier provided by the OpenID authentication plugin is the
 -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -48,7 +48,7 @@ $newline never
                 $ maybe id (\x -> (:) ("displayName", x))
                     (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
                   []
-        lift $ setCreds True creds
+        lift $ setCredsRedirect creds
     dispatch _ _ = notFound
 
 -- | Get some form of a display name.

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.2.7
+version:         1.3.0.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -10,9 +10,12 @@ stability:       Stable
 cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
-                 .
-                 * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
+description:
+    This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
+   .
+   * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
+   .
+   * <https://github.com/ollieh/yesod-auth-bcrypt/>: A replacement for the previously provided HashDB module, which has been removed.
 extra-source-files: persona_sign_in_blue.png
 
 library
@@ -58,7 +61,6 @@ library
                      Yesod.Auth.Email
                      Yesod.Auth.OpenId
                      Yesod.Auth.Rpxnow
-                     Yesod.Auth.HashDB
                      Yesod.Auth.Message
                      Yesod.Auth.GoogleEmail
     other-modules:   Yesod.Auth.Routes

yesod-platform/yesod-platform.cabal

@@ -1,5 +1,5 @@
 name:            yesod-platform
-version:         1.2.8
+version:         1.2.8.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -70,7 +70,7 @@ library
                  , filesystem-conduit == 1.0.0.1
                  , hamlet == 1.1.9.2
                  , hjsmin == 0.1.4.5
-                 , hspec == 1.8.3
+                 , hspec == 1.9.0
                  , hspec-expectations == 0.5.0.1
                  , html-conduit == 1.1.0.1
                  , http-client == 0.2.2.2