haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote branch 'patrick/master'

Browse Source 
Conflicts:
	Yesod/Helpers/Auth/HashDB.hs
	yesod-auth.cabal
This commit is contained in:
Michael Snoyman 2011-04-09 22:36:43 +03:00
commit eb94784201
1 changed files with 19 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Yesod/Helpers/Auth/HashDB.hs
View File

@ -75,6 +75,7 @@ import Data.ByteString.Lazy.Char8 (pack)
import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Digest.Pure.SHA (sha1, showDigest)
import Database.Persist.TH (share2, mkMigrate, persist, mkPersist) import Database.Persist.TH (share2, mkMigrate, persist, mkPersist)
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Maybe (fromMaybe)
-- | Computer the sha1 of a string and return it as a string -- | Computer the sha1 of a string and return it as a string
sha1String :: String -> String sha1String :: String -> String
@ -115,14 +116,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
@ -130,7 +134,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
@ -161,7 +165,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
@ -179,28 +183,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