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:
parent
ef635dc07d
commit
d6ecbf5d0a
@ -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>
|
<td>
|
||||||
<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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user