some HashDB cleanups

* inputs are now flagged as required
* handle empty input more elegantly
* don't preformat the setMessage contents
* cleanup some hamlet
This commit is contained in:
patrick brisbin 2011-04-07 16:23:07 -04:00
parent ef635dc07d
commit d6ecbf5d0a

View File

@ -72,6 +72,7 @@ import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.ByteString.Lazy.Char8 (pack) import Data.ByteString.Lazy.Char8 (pack)
import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Maybe (fromMaybe)
import Database.Persist.TH (share2) import Database.Persist.TH (share2)
import Database.Persist.GenericSql (mkMigrate) import Database.Persist.GenericSql (mkMigrate)
@ -114,14 +115,17 @@ postLoginR :: (YesodAuth y,
PersistBackend (YesodDB y (GGHandler Auth y IO))) PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> GHandler Auth y () => GHandler Auth y ()
postLoginR = do postLoginR = do
(user, password) <- runFormPost' $ (,) (mu,mp) <- runFormPost' $ (,)
<$> stringInput "username" <$> maybeStringInput "username"
<*> stringInput "password" <*> maybeStringInput "password"
isValid <- validateUser (user,password) isValid <- case (mu,mp) of
(Nothing, _ ) -> return False
(_ , Nothing) -> return False
(Just u , Just p ) -> validateUser (u,p)
if isValid if isValid
then setCreds True $ Creds "hashdb" user [] then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do else do
setMessage setMessage
#if GHC7 #if GHC7
@ -129,7 +133,7 @@ postLoginR = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
<em>invalid username/password Invalid username/password
|] |]
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR redirect RedirectTemporary $ toMaster LoginR
@ -160,7 +164,7 @@ getAuthIdHashDB authR creds = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
<em>user not found User not found
|] |]
redirect RedirectTemporary $ authR LoginR redirect RedirectTemporary $ authR LoginR
@ -178,28 +182,28 @@ authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
#endif #endif
<div id="header"> <div id="header">
<h1>Login <h1>Login
\
<div id="login"> <div id="login">
<form method="post" action="@{tm login}"> <form method="post" action="@{tm login}">
<table> <table>
<tr> <tr>
<th>Username: <th>Username:
<td> <td>
<input id="x" name="username" autofocus=""> <input id="x" name="username" autofocus="" required>
<tr> <tr>
<th>Password: <th>Password:
<td> <td>
<input type="password" name="password"> <input type="password" name="password" required>
<tr> <tr>
<td>&nbsp; <td>&nbsp;
<td> <td>
<input type="submit" value="Login"> <input type="submit" value="Login">
\
<script> <script>
\if (!("autofocus" in document.createElement("input"))) { if (!("autofocus" in document.createElement("input"))) {
\document.getElementById("x").focus(); document.getElementById("x").focus();
\} }
\
|] |]
where where
dispatch "POST" ["login"] = postLoginR >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse