+ |
+
|]
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
@@ -237,19 +250,19 @@
<$> stringInput "new"
<*> stringInput "confirm"
toMaster <- getRouteToMaster
+ y <- getYesod
when (new /= confirm) $ do
- setMessage $ string "Passwords did not match, please try again"
+ setMessage $ messagePassMismatch y
redirect RedirectTemporary $ toMaster setpass
maid <- maybeAuthId
aid <- case maid of
Nothing -> do
- setMessage $ string "You must be logged in to set a password"
+ setMessage $ messageBadSetPass y
redirect RedirectTemporary $ toMaster login
Just aid -> return aid
salted <- liftIO $ saltPass new
setPassword aid salted
- setMessage $ string "Password updated"
- y <- getYesod
+ setMessage $ messagePassUpdated y
redirect RedirectTemporary $ loginDest y
saltLength :: Int
diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs
--- a/Yesod/Helpers/Auth/Facebook.hs
+++ b/Yesod/Helpers/Auth/Facebook.hs
@@ -5,12 +5,19 @@
, facebookUrl
) where
-import Yesod
import Yesod.Helpers.Auth
import qualified Web.Authenticate.Facebook as Facebook
import Data.Object (fromMapping, lookupScalar)
import Data.Maybe (fromMaybe)
+import Yesod.Form
+import Yesod.Handler
+import Yesod.Widget
+import Text.Hamlet (hamlet)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString.Char8 as S8
+import Control.Monad.Trans.Class (lift)
+
facebookUrl :: AuthRoute
facebookUrl = PluginR "facebook" ["forward"]
@@ -27,7 +34,7 @@
tm <- getRouteToMaster
render <- getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
- redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms
+ redirectString RedirectTemporary $ S8.pack $ Facebook.getForwardUrl fb perms
dispatch "GET" [] = do
render <- getUrlRender
tm <- getRouteToMaster
@@ -51,15 +58,16 @@
setCreds True c
dispatch _ _ = notFound
login tm = do
- render <- liftHandler getUrlRender
+ render <- lift getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
let furl = Facebook.getForwardUrl fb $ perms
+ y <- lift getYesod
addHtml
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
-%p
- %a!href=$furl$ Login with Facebook
+
+ #{messageFacebook y}
|]
diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Helpers/Auth/HashDB.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+-------------------------------------------------------------------------------
+-- |
+-- Module : Yesod.Helpers.Auth.HashDB
+-- Copyright : (c) Patrick Brisbin 2010
+-- License : as-is
+--
+-- Maintainer : pbrisbin@gmail.com
+-- Stability : Stable
+-- Portability : Portable
+--
+-- A yesod-auth AuthPlugin designed to look users up in Persist where
+-- their user id's and a sha1 hash of their password will already be
+-- stored.
+--
+-- Example usage:
+--
+-- > -- import the function
+-- > import Helpers.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
+-- > showAuthId _ = showIntegral
+-- > readAuthId _ = readIntegral
+-- > authPlugins = [authHashDB]
+-- >
+-- >
+-- > -- 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
+--
+-- Your app must be an instance of YesodPersist and the username and
+-- hashed-passwords must be added manually to the database.
+--
+-- > echo -n 'MyPassword' | sha1sum
+--
+-- can be used to get the hash from the commandline.
+--
+-------------------------------------------------------------------------------
+module Yesod.Helpers.Auth.HashDB
+ ( authHashDB
+ , getAuthIdHashDB
+ , UserId
+ , migrateUsers
+ ) where
+
+import Yesod.Persist
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Helpers.Auth
+import Text.Hamlet (hamlet)
+
+import Control.Applicative ((<$>), (<*>))
+import Data.ByteString.Lazy.Char8 (pack)
+import Data.Digest.Pure.SHA (sha1, showDigest)
+import Database.Persist.TH (share2)
+import Database.Persist.GenericSql (mkMigrate)
+
+-- | Computer the sha1 of a string and return it as a string
+sha1String :: String -> String
+sha1String = showDigest . sha1 . pack
+
+-- | Generate data base instances for a valid user
+share2 mkPersist (mkMigrate "migrateUsers")
+#if GHC7
+ [persist|
+#else
+ [$persist|
+#endif
+User
+ username String Eq
+ password String
+ UniqueUser username
+|]
+
+-- | Given a (user,password) in plaintext, validate them against the
+-- database values
+validateUser :: (YesodPersist y,
+ PersistBackend (YesodDB y (GGHandler sub y IO)))
+ => (String, String)
+ -> GHandler sub y Bool
+validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->
+ case dbUser of
+ -- user not found
+ Nothing -> return False
+ -- validate password
+ Just (_, sqlUser) -> return $ sha1String password == userPassword sqlUser
+
+login :: AuthRoute
+login = PluginR "hashdb" ["login"]
+
+-- | Handle the login form
+postLoginR :: (YesodAuth y,
+ YesodPersist y,
+ PersistBackend (YesodDB y (GGHandler Auth y IO)))
+ => GHandler Auth y ()
+postLoginR = do
+ (user, password) <- runFormPost' $ (,)
+ <$> stringInput "username"
+ <*> stringInput "password"
+
+ isValid <- validateUser (user,password)
+
+ if isValid
+ then setCreds True $ Creds "hashdb" user []
+ else do
+ setMessage
+#if GHC7
+ [hamlet|
+#else
+ [$hamlet|
+#endif
+ invalid username/password
+|]
+ toMaster <- getRouteToMaster
+ redirect RedirectTemporary $ toMaster LoginR
+
+-- | A drop in for the getAuthId method of your YesodAuth instance which
+-- can be used if authHashDB is the only plugin in use.
+getAuthIdHashDB :: (Key User ~ AuthId master,
+ PersistBackend (YesodDB master (GGHandler sub master IO)),
+ YesodPersist master,
+ YesodAuth master)
+ => (AuthRoute -> Route master) -- ^ your site's Auth Route
+ -> Creds m -- ^ the creds argument
+ -> GHandler sub master (Maybe UserId)
+getAuthIdHashDB authR creds = do
+ muid <- maybeAuth
+ case muid of
+ -- user already authenticated
+ Just (uid, _) -> return $ Just uid
+ Nothing -> do
+ x <- runDB $ getBy $ UniqueUser (credsIdent creds)
+ case x of
+ -- user exists
+ Just (uid, _) -> return $ Just uid
+ Nothing -> do
+ setMessage
+#if GHC7
+ [hamlet|
+#else
+ [$hamlet|
+#endif
+ user not found
+|]
+ redirect RedirectTemporary $ authR LoginR
+
+-- | Prompt for username and password, validate that against a database
+-- which holds the username and a hash of the password
+authHashDB :: (YesodAuth y,
+ YesodPersist y,
+ PersistBackend (YesodDB y (GGHandler Auth y IO)))
+ => AuthPlugin y
+authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
+#if GHC7
+ [hamlet|
+#else
+ [$hamlet|
+#endif
+ |