Fix HashDB; hamlet6to7; GGHandler IO
This commit is contained in:
Michael Snoyman
parent
9671a86697
commit
66ee5f4c96
@ -166,7 +166,8 @@ setCreds doRedirects creds = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Invalid login|]
|
||||
<h1>Invalid login
|
||||
|]
|
||||
sendResponse rh
|
||||
Just ar -> do
|
||||
setMessage $ string "Invalid login"
|
||||
@ -193,11 +194,11 @@ getCheckR = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Authentication Status
|
||||
$maybe creds _
|
||||
%p Logged in.
|
||||
<h1>Authentication Status
|
||||
$maybe _ <- creds
|
||||
<p>Logged in.
|
||||
$nothing
|
||||
%p Not logged in.
|
||||
<p>Not logged in.
|
||||
|]
|
||||
json creds =
|
||||
ValueObject $ Map.fromList
|
||||
@ -237,7 +238,7 @@ maybeAuthId = do
|
||||
|
||||
maybeAuth :: ( YesodAuth m
|
||||
, Key val ~ AuthId m
|
||||
, PersistBackend (YesodDB m (GHandler s m))
|
||||
, PersistBackend (YesodDB m (GGHandler s m IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Maybe (Key val, val))
|
||||
@ -256,7 +257,7 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return
|
||||
|
||||
requireAuth :: ( YesodAuth m
|
||||
, Key val ~ AuthId m
|
||||
, PersistBackend (YesodDB m (GHandler s m))
|
||||
, PersistBackend (YesodDB m (GGHandler s m IO))
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Key val, val)
|
||||
|
||||
@ -27,8 +27,8 @@ authDummy =
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=post!action=@authToMaster.url@
|
||||
Your new identifier is: $
|
||||
%input!type=text!name=ident
|
||||
%input!type=submit!value="Dummy Login"
|
||||
<form method="post" action="@{authToMaster url}">
|
||||
\Your new identifier is:
|
||||
<input type="text" name="ident">
|
||||
<input type="submit" value="Dummy Login">
|
||||
|]
|
||||
|
||||
@ -77,20 +77,20 @@ authEmail =
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=post!action=@tm.login@
|
||||
%table
|
||||
%tr
|
||||
%th $messageEmail.y$
|
||||
%td
|
||||
%input!type=email!name=email
|
||||
%tr
|
||||
%th $messagePassword.y$
|
||||
%td
|
||||
%input!type=password!name=password
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit!value="Login via email"
|
||||
%a!href=@tm.register@ I don't have an account
|
||||
<form method="post" action="@{tm login}">
|
||||
<table>
|
||||
<tr>
|
||||
<th>#{messageEmail y}
|
||||
<td>
|
||||
<input type="email" name="email">
|
||||
<tr>
|
||||
<th>#{messagePassword y}
|
||||
<td>
|
||||
<input type="password" name="password">
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type="submit" value="Login via email">
|
||||
<a href="@{tm register}">I don't have an account
|
||||
|]
|
||||
where
|
||||
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
|
||||
@ -117,11 +117,11 @@ getRegisterR = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%p $messageEnterEmail.y$
|
||||
%form!method=post!action=@toMaster.register@
|
||||
%label!for=email $messageEmail y$
|
||||
%input!type=email!name=email!width=150
|
||||
%input!type=submit!value=$messageRegister y$
|
||||
<p>#{messageEnterEmail y}
|
||||
<form method="post" action="@{toMaster register}">
|
||||
<label for="email">#{messageEmail y}
|
||||
<input type="email" name="email" width="150">
|
||||
<input type="submit" value="#{messageRegister y}">
|
||||
|]
|
||||
|
||||
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
@ -152,7 +152,7 @@ postRegisterR = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%p $(messageConfirmationEmailSent y) email$
|
||||
<p>#{messageConfirmationEmailSent y email}
|
||||
|]
|
||||
|
||||
getVerifyR :: YesodAuthEmail m
|
||||
@ -180,7 +180,7 @@ getVerifyR lid key = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%p $messageInvalidKey y$
|
||||
<p>#{messageInvalidKey y}
|
||||
|]
|
||||
|
||||
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
@ -227,20 +227,20 @@ getPasswordR = do
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h3 $messageSetPass y$
|
||||
%form!method=post!action=@toMaster.setpass@
|
||||
%table
|
||||
%tr
|
||||
%th $messageNewPass y$
|
||||
%td
|
||||
%input!type=password!name=new
|
||||
%tr
|
||||
%th $messageConfirmPass y$
|
||||
%td
|
||||
%input!type=password!name=confirm
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit!value=$messageSetPassTitle y$
|
||||
<h3>#{messageSetPass y}
|
||||
<form method="post" action="@{toMaster setpass}">
|
||||
<table>
|
||||
<tr>
|
||||
<th>#{messageNewPass y}
|
||||
<td>
|
||||
<input type="password" name="new">
|
||||
<tr>
|
||||
<th>#{messageConfirmPass y}
|
||||
<td>
|
||||
<input type="password" name="confirm">
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type="submit" value="#{messageSetPassTitle y}">
|
||||
|]
|
||||
|
||||
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
|
||||
@ -66,6 +66,6 @@ authFacebook cid secret perms =
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%p
|
||||
%a!href=$furl$ $messageFacebook y$
|
||||
<p>
|
||||
<a href="#{furl}">#{messageFacebook y}
|
||||
|]
|
||||
|
||||
@ -54,15 +54,18 @@
|
||||
-- can be used to get the hash from the commandline.
|
||||
--
|
||||
-------------------------------------------------------------------------------
|
||||
module Helpers.Auth.HashDB
|
||||
module Yesod.Helpers.Auth.HashDB
|
||||
( authHashDB
|
||||
, getAuthIdHashDB
|
||||
, UserId
|
||||
, migrateUsers
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
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)
|
||||
@ -85,7 +88,7 @@ User
|
||||
-- | Given a (user,password) in plaintext, validate them against the
|
||||
-- database values
|
||||
validateUser :: (YesodPersist y,
|
||||
PersistBackend (YesodDB y (GHandler sub y)))
|
||||
PersistBackend (YesodDB y (GGHandler sub y IO)))
|
||||
=> (String, String)
|
||||
-> GHandler sub y Bool
|
||||
validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->
|
||||
@ -101,7 +104,7 @@ login = PluginR "hashdb" ["login"]
|
||||
-- | Handle the login form
|
||||
postLoginR :: (YesodAuth y,
|
||||
YesodPersist y,
|
||||
PersistBackend (YesodDB y (GHandler Auth y)))
|
||||
PersistBackend (YesodDB y (GGHandler Auth y IO)))
|
||||
=> GHandler Auth y ()
|
||||
postLoginR = do
|
||||
(user, password) <- runFormPost' $ (,)
|
||||
@ -113,14 +116,15 @@ postLoginR = do
|
||||
if isValid
|
||||
then setCreds True $ Creds "hashdb" user []
|
||||
else do
|
||||
setMessage $ [$hamlet| %em invalid username/password |]
|
||||
setMessage $ [$hamlet| <em>invalid username/password
|
||||
|]
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
-- | A drop in for the getAuthId method of your YesodAuth instance which
|
||||
-- can be used if authHashDB is the only plugin in use.
|
||||
getAuthIdHashDB :: (Key User ~ AuthId master,
|
||||
PersistBackend (YesodDB master (GHandler sub master)),
|
||||
PersistBackend (YesodDB master (GGHandler sub master IO)),
|
||||
YesodPersist master,
|
||||
YesodAuth master)
|
||||
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
|
||||
@ -137,41 +141,43 @@ getAuthIdHashDB authR creds = do
|
||||
-- user exists
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
setMessage $ [$hamlet| %em user not found |]
|
||||
setMessage $ [$hamlet| <em>user not found
|
||||
|]
|
||||
redirect RedirectTemporary $ authR LoginR
|
||||
|
||||
-- | Prompt for username and password, validate that against a database
|
||||
-- which holds the username and a hash of the password
|
||||
authHashDB :: (YesodAuth y,
|
||||
YesodPersist y,
|
||||
PersistBackend (YesodDB y (GHandler Auth y)))
|
||||
PersistBackend (YesodDB y (GGHandler Auth y IO)))
|
||||
=> AuthPlugin y
|
||||
authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
[$hamlet|
|
||||
#header
|
||||
%h1 Login
|
||||
|
||||
#login
|
||||
%form!method=post!action=@tm.login@
|
||||
%table
|
||||
%tr
|
||||
%th Username:
|
||||
%td
|
||||
%input#x!name=username!autofocus
|
||||
%tr
|
||||
%th Password:
|
||||
%td
|
||||
%input!type=password!name=password
|
||||
%tr
|
||||
%td
|
||||
%td
|
||||
%input!type=submit!value="Login"
|
||||
|
||||
%script
|
||||
if (!("autofocus" in document.createElement("input"))) {
|
||||
document.getElementById("x").focus();
|
||||
}
|
||||
|]
|
||||
[$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="">
|
||||
<tr>
|
||||
<th>Password:
|
||||
<td>
|
||||
<input type="password" name="password">
|
||||
<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
|
||||
|
||||
@ -32,11 +32,10 @@ authOpenId =
|
||||
y <- liftHandler getYesod
|
||||
addCassius
|
||||
#if GHC7
|
||||
[cassius|
|
||||
[cassius|##{ident}
|
||||
#else
|
||||
[$cassius|
|
||||
[$cassius|##{ident}
|
||||
#endif
|
||||
#$ident$
|
||||
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
|
||||
padding-left: 18px;
|
||||
|]
|
||||
@ -46,10 +45,10 @@ authOpenId =
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=get!action=@tm.forwardUrl@
|
||||
%label!for=$ident$ OpenID: $
|
||||
%input#$ident$!type=text!name=$name$!value="http://"
|
||||
%input!type=submit!value=$messageLoginOpenID.y$
|
||||
<form method="get" action="@{tm forwardUrl}">
|
||||
<label for="#{ident}">OpenID:
|
||||
<input id="#{ident}" type="text" name="#{name}" value="http://">
|
||||
<input type="submit" value="#{messageLoginOpenID y}">
|
||||
|]
|
||||
dispatch "GET" ["forward"] = do
|
||||
(roid, _, _) <- runFormGet $ stringInput name
|
||||
|
||||
@ -29,7 +29,7 @@ authRpxnow app apiKey =
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%iframe!src="http://$app$.rpxnow.com/openid/embed?token_url=@url@"!scrolling=no!frameBorder=no!allowtransparency=true!style="width:400px;height:240px"
|
||||
<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|
||||
|]
|
||||
dispatch _ [] = do
|
||||
token1 <- lookupGetParam "token"
|
||||
|
||||
@ -30,7 +30,7 @@ library
|
||||
, control-monad-attempt >= 0.3.0 && < 0.4
|
||||
, text >= 0.7 && < 0.12
|
||||
, mime-mail >= 0.1 && < 0.2
|
||||
, blaze-html >= 0.3.0.4 && < 0.4
|
||||
, blaze-html >= 0.4 && < 0.5
|
||||
, yesod-persistent >= 0.0 && < 0.1
|
||||
, hamlet >= 0.7 && < 0.8
|
||||
, yesod-json >= 0.0 && < 0.1
|
||||
@ -39,6 +39,8 @@ library
|
||||
, text >= 0.11 && < 0.12
|
||||
, yesod-form >= 0.0 && < 0.1
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, persistent >= 0.4 && < 0.5
|
||||
, SHA >= 1.4.1.3 && < 1.5
|
||||
exposed-modules: Yesod.Helpers.Auth
|
||||
Yesod.Helpers.Auth.Dummy
|
||||
Yesod.Helpers.Auth.Email
|
||||
|
||||
Loading…
Reference in New Issue
Block a user