* Parametrize all functions by user data type. So it's possible to
use custom data type for users. (So it's possible to store additional data). * Add type class for custom user data type * Export User data type there is no point in hiding it. It becomes possible to manipulate user database from withint yesod application
This commit is contained in:
Alexey Khudyakov
parent
7cd2f9f6c4
commit
9c5f049114
@ -58,8 +58,12 @@
|
||||
--
|
||||
-------------------------------------------------------------------------------
|
||||
module Yesod.Auth.HashDB
|
||||
( authHashDB
|
||||
( HashDBUser(..)
|
||||
, authHashDB
|
||||
, validateUser
|
||||
, getAuthIdHashDB
|
||||
-- * Predefined data type
|
||||
, User(..)
|
||||
, UserId
|
||||
, migrateUsers
|
||||
) where
|
||||
@ -73,79 +77,100 @@ import Yesod.Auth
|
||||
import Text.Hamlet (hamlet)
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Data.ByteString.Lazy.Char8 (pack)
|
||||
import Control.Monad (replicateM)
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
|
||||
import Data.Digest.Pure.SHA (sha1, showDigest)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text (Text, pack, unpack, append)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import System.Random (randomRIO)
|
||||
|
||||
-- | Computer the sha1 of a string and return it as a string
|
||||
sha1String :: String -> String
|
||||
sha1String = showDigest . sha1 . pack
|
||||
class HashDBUser user where
|
||||
-- | Retrieve password hash from user data
|
||||
userPasswordHash :: user -> Maybe Text
|
||||
-- | Retrieve salt for password
|
||||
userPasswordSalt :: user -> Maybe Text
|
||||
-- | Set hash and password
|
||||
setUserHashAndSalt :: Text -- ^ Salt
|
||||
-> Text -- ^ Password hash
|
||||
-> user -> user
|
||||
|
||||
-- | Generate data base instances for a valid user
|
||||
share2 mkPersist (mkMigrate "migrateUsers")
|
||||
[QQ(persist)|
|
||||
User
|
||||
username Text Eq
|
||||
password Text
|
||||
UniqueUser username
|
||||
|]
|
||||
-- | Generate random salt. Length of 8 is chosen arbitrarily
|
||||
randomSalt :: IO Text
|
||||
randomSalt = pack <$> 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
|
||||
|
||||
|
||||
-- | Given a user ID and password in plaintext, validate them against
|
||||
-- the database values.
|
||||
validateUser :: ( YesodPersist yesod
|
||||
, PersistBackend (YesodDB yesod (GGHandler sub yesod IO))
|
||||
, PersistEntity user
|
||||
, HashDBUser user
|
||||
) =>
|
||||
Unique user -- ^ User unique identifier
|
||||
-> Text -- ^ Password in plaint-text
|
||||
-> GHandler sub yesod Bool
|
||||
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 . snd =<< user
|
||||
|
||||
-- | Given a (user,password) in plaintext, validate them against the
|
||||
-- database values
|
||||
validateUser :: (YesodPersist y,
|
||||
PersistBackend (YesodDB y (GGHandler sub y IO)))
|
||||
=> (Text, Text)
|
||||
-> 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 (unpack password) == unpack (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
|
||||
|
||||
-- | Handle the login form. First parameter is function which username
|
||||
-- (whatever it might be) to unique user ID.
|
||||
postLoginR :: ( YesodAuth y, YesodPersist y
|
||||
, HashDBUser user, PersistEntity user
|
||||
, PersistBackend (YesodDB y (GGHandler Auth y IO)))
|
||||
=> (Text -> Maybe (Unique user))
|
||||
-> GHandler Auth y ()
|
||||
postLoginR uniq = do
|
||||
(mu,mp) <- runInputPost $ (,)
|
||||
<$> iopt textField "username"
|
||||
<*> iopt textField "password"
|
||||
|
||||
isValid <- case (mu,mp) of
|
||||
(Nothing, _ ) -> return False
|
||||
(_ , Nothing) -> return False
|
||||
(Just u , Just p ) -> validateUser (u,p)
|
||||
isValid <- fromMaybe (return False)
|
||||
(validateUser <$> (uniq =<< mu) <*> mp)
|
||||
if isValid
|
||||
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
||||
else do setMessage [QQ(hamlet)| Invalid username/password |]
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
if isValid
|
||||
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
||||
else do
|
||||
setMessage
|
||||
[QQ(hamlet)| 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
|
||||
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
|
||||
, HashDBUser user, PersistEntity user
|
||||
, Key user ~ AuthId master
|
||||
, PersistBackend (YesodDB master (GGHandler sub master IO)))
|
||||
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
|
||||
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
|
||||
-> Creds m -- ^ the creds argument
|
||||
-> GHandler sub master (Maybe (AuthId master))
|
||||
getAuthIdHashDB authR uniq creds = do
|
||||
muid <- maybeAuth
|
||||
case muid of
|
||||
-- user already authenticated
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
x <- runDB $ getBy $ UniqueUser (credsIdent creds)
|
||||
x <- case uniq (credsIdent creds) of
|
||||
Nothing -> return Nothing
|
||||
Just u -> runDB (getBy u)
|
||||
case x of
|
||||
-- user exists
|
||||
Just (uid, _) -> return $ Just uid
|
||||
@ -155,11 +180,12 @@ getAuthIdHashDB authR creds = do
|
||||
|
||||
-- | 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 ->
|
||||
authHashDB :: ( YesodAuth m, YesodPersist m
|
||||
, HashDBUser user
|
||||
, PersistEntity user
|
||||
, PersistBackend (YesodDB m (GGHandler Auth m IO)))
|
||||
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
|
||||
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
[QQ(hamlet)|
|
||||
<div id="header">
|
||||
<h1>Login
|
||||
@ -187,5 +213,27 @@ authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
|
||||
|]
|
||||
where
|
||||
dispatch "POST" ["login"] = postLoginR >>= sendResponse
|
||||
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
|
||||
dispatch _ _ = notFound
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- Predefined datatype
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Generate data base instances for a valid user
|
||||
share2 mkPersist (mkMigrate "migrateUsers")
|
||||
[QQ(persist)|
|
||||
User
|
||||
username Text Eq
|
||||
password Text
|
||||
salt Text
|
||||
UniqueUser username
|
||||
|]
|
||||
|
||||
instance HashDBUser User where
|
||||
userPasswordHash = Just . userPassword
|
||||
userPasswordSalt = Just . userSalt
|
||||
setUserHashAndSalt s h u = u { userSalt = s
|
||||
, userPassword = h
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user