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 Data.Text (Text, unpack)
import Data.Maybe (fromMaybe)
sha1String :: String -> String
sha1String = showDigest . sha1 . pack
share2 mkPersist (mkMigrate "migrateUsers")
#if GHC7
[persist|
#else
[$persist|
#endif
User
username Text Eq
password Text
UniqueUser username
|]
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
Nothing -> return False
Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)
login :: AuthRoute
login = PluginR "hashdb" ["login"]
postLoginR :: (YesodAuth y,
YesodPersist y,
PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> GHandler Auth y ()
postLoginR = do
(mu,mp) <- runFormPost' $ (,)
<$> maybeStringInput "username"
<*> maybeStringInput "password"
isValid <- case (mu,mp) of
(Nothing, _ ) -> return False
(_ , Nothing) -> return False
(Just u , Just p ) -> validateUser (u,p)
if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do
setMessage
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
Invalid username/password
|]
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR
getAuthIdHashDB :: (Key User ~ AuthId master,
PersistBackend (YesodDB master (GGHandler sub master IO)),
YesodPersist master,
YesodAuth master)
=> (AuthRoute -> Route master)
-> Creds m
-> GHandler sub master (Maybe UserId)
getAuthIdHashDB authR creds = do
muid <- maybeAuth
case muid of
Just (uid, _) -> return $ Just uid
Nothing -> do
x <- runDB $ getBy $ UniqueUser (credsIdent creds)
case x of
Just (uid, _) -> return $ Just uid
Nothing -> do
setMessage
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
User not found
|]
redirect RedirectTemporary $ authR LoginR
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
<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 >>= sendResponse
dispatch _ _ = notFound