module Yesod.Auth.HashDB
( HashDBUser(..)
, setPassword
, validateUser
, authHashDB
, getAuthIdHashDB
, User
, UserGeneric (..)
, UserId
, migrateUsers
) where
#include "qq.h"
import Yesod.Persist
import Yesod.Handler
import Yesod.Form
import Yesod.Auth
import Yesod.Widget (addHamlet)
import Text.Hamlet (hamlet, shamlet)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
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)
class HashDBUser user where
userPasswordHash :: user -> Maybe Text
userPasswordSalt :: user -> Maybe Text
setUserHashAndSalt :: Text
-> Text
-> user -> user
setUserHashAndSalt = setSaltAndPasswordHash
setSaltAndPasswordHash :: Text
-> Text
-> user -> user
setSaltAndPasswordHash = setUserHashAndSalt
randomSalt :: MonadIO m => m Text
randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
saltedHash :: Text
-> Text
-> Text
saltedHash salt =
pack . showDigest . sha1 . BS.pack . unpack . append salt
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
setPassword pwd u = do salt <- randomSalt
return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, PersistBackend b (GGHandler sub yesod IO)
, PersistEntity user
, HashDBUser user
) =>
Unique user b
-> Text
-> GHandler sub yesod Bool
validateUser userID passwd = do
let validate u = do hash <- userPasswordHash u
salt <- userPasswordSalt u
return $ hash == saltedHash salt passwd
user <- runDB $ getBy userID
return $ fromMaybe False $ validate . snd =<< user
login :: AuthRoute
login = PluginR "hashdb" ["login"]
postLoginR :: ( YesodAuth y, YesodPersist y
, b ~ YesodPersistBackend y
, HashDBUser user, PersistEntity user
, PersistBackend b (GGHandler Auth y IO))
=> (Text -> Maybe (Unique user b))
-> GHandler Auth y ()
postLoginR uniq = do
(mu,mp) <- runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage [QQ(shamlet)| Invalid username/password |]
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key b user ~ AuthId master
, b ~ YesodPersistBackend master
, PersistBackend b (GGHandler sub master IO))
=> (AuthRoute -> Route master)
-> (Text -> Maybe (Unique user b))
-> Creds master
-> GHandler sub master (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuth
case muid of
Just (uid, _) -> return $ Just uid
Nothing -> do
x <- case uniq (credsIdent creds) of
Nothing -> return Nothing
Just u -> runDB (getBy u)
case x of
Just (uid, _) -> return $ Just uid
Nothing -> do
setMessage [QQ(shamlet)| User not found |]
redirect RedirectTemporary $ authR LoginR
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
, b ~ YesodPersistBackend m
, PersistBackend b (GGHandler Auth m IO))
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
[QQ(hamlet)|
<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>
<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
share2 (mkPersist sqlSettings) (mkMigrate "migrateUsers")
[QQ(persist)|
User
username Text Eq
password Text
salt Text
UniqueUser username
|]
instance HashDBUser (UserGeneric backend) where
userPasswordHash = Just . userPassword
userPasswordSalt = Just . userSalt
setSaltAndPasswordHash s h u = u { userSalt = s
, userPassword = h
}