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

Fix HashDB; hamlet6to7; GGHandler IO

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-20 00:01:43 +02:00
parent 9671a86697
commit 66ee5f4c96
8 changed files with 98 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
Yesod/Helpers/Auth.hs
View File

@ -166,7 +166,8 @@ setCreds doRedirects creds = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%h1 Invalid login|] <h1>Invalid login
|]
sendResponse rh sendResponse rh
Just ar -> do Just ar -> do
setMessage $ string "Invalid login" setMessage $ string "Invalid login"
@ -193,11 +194,11 @@ getCheckR = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%h1 Authentication Status <h1>Authentication Status
$maybe creds _ $maybe _ <- creds
%p Logged in. <p>Logged in.
$nothing $nothing
%p Not logged in. <p>Not logged in.
|] |]
json creds = json creds =
ValueObject $ Map.fromList ValueObject $ Map.fromList
@ -237,7 +238,7 @@ maybeAuthId = do
maybeAuth :: ( YesodAuth m maybeAuth :: ( YesodAuth m
, Key val ~ AuthId m , Key val ~ AuthId m
, PersistBackend (YesodDB m (GHandler s m)) , PersistBackend (YesodDB m (GGHandler s m IO))
, PersistEntity val , PersistEntity val
, YesodPersist m , YesodPersist m
) => GHandler s m (Maybe (Key val, val)) ) => GHandler s m (Maybe (Key val, val))
@ -256,7 +257,7 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return
requireAuth :: ( YesodAuth m requireAuth :: ( YesodAuth m
, Key val ~ AuthId m , Key val ~ AuthId m
, PersistBackend (YesodDB m (GHandler s m)) , PersistBackend (YesodDB m (GGHandler s m IO))
, PersistEntity val , PersistEntity val
, YesodPersist m , YesodPersist m
) => GHandler s m (Key val, val) ) => GHandler s m (Key val, val)

8
Yesod/Helpers/Auth/Dummy.hs
View File

@ -27,8 +27,8 @@ authDummy =
#else #else
[$hamlet| [$hamlet|
#endif #endif
%form!method=post!action=@authToMaster.url@ <form method="post" action="@{authToMaster url}">
Your new identifier is: $ \Your new identifier is:
%input!type=text!name=ident <input type="text" name="ident">
%input!type=submit!value="Dummy Login" <input type="submit" value="Dummy Login">
|] |]

70
Yesod/Helpers/Auth/Email.hs
View File

@ -77,20 +77,20 @@ authEmail =
#else #else
[$hamlet| [$hamlet|
#endif #endif
%form!method=post!action=@tm.login@ <form method="post" action="@{tm login}">
%table <table>
%tr <tr>
%th $messageEmail.y$ <th>#{messageEmail y}
%td <td>
%input!type=email!name=email <input type="email" name="email">
%tr <tr>
%th $messagePassword.y$ <th>#{messagePassword y}
%td <td>
%input!type=password!name=password <input type="password" name="password">
%tr <tr>
%td!colspan=2 <td colspan="2">
%input!type=submit!value="Login via email" <input type="submit" value="Login via email">
%a!href=@tm.register@ I don't have an account <a href="@{tm register}">I don't have an account
|] |]
where where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "GET" ["register"] = getRegisterR >>= sendResponse
@ -117,11 +117,11 @@ getRegisterR = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%p $messageEnterEmail.y$ <p>#{messageEnterEmail y}
%form!method=post!action=@toMaster.register@ <form method="post" action="@{toMaster register}">
%label!for=email $messageEmail y$ <label for="email">#{messageEmail y}
%input!type=email!name=email!width=150 <input type="email" name="email" width="150">
%input!type=submit!value=$messageRegister y$ <input type="submit" value="#{messageRegister y}">
|] |]
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
@ -152,7 +152,7 @@ postRegisterR = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%p $(messageConfirmationEmailSent y) email$ <p>#{messageConfirmationEmailSent y email}
|] |]
getVerifyR :: YesodAuthEmail m getVerifyR :: YesodAuthEmail m
@ -180,7 +180,7 @@ getVerifyR lid key = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%p $messageInvalidKey y$ <p>#{messageInvalidKey y}
|] |]
postLoginR :: YesodAuthEmail master => GHandler Auth master () postLoginR :: YesodAuthEmail master => GHandler Auth master ()
@ -227,20 +227,20 @@ getPasswordR = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
%h3 $messageSetPass y$ <h3>#{messageSetPass y}
%form!method=post!action=@toMaster.setpass@ <form method="post" action="@{toMaster setpass}">
%table <table>
%tr <tr>
%th $messageNewPass y$ <th>#{messageNewPass y}
%td <td>
%input!type=password!name=new <input type="password" name="new">
%tr <tr>
%th $messageConfirmPass y$ <th>#{messageConfirmPass y}
%td <td>
%input!type=password!name=confirm <input type="password" name="confirm">
%tr <tr>
%td!colspan=2 <td colspan="2">
%input!type=submit!value=$messageSetPassTitle y$ <input type="submit" value="#{messageSetPassTitle y}">
|] |]
postPasswordR :: YesodAuthEmail master => GHandler Auth master () postPasswordR :: YesodAuthEmail master => GHandler Auth master ()

4
Yesod/Helpers/Auth/Facebook.hs
View File

@ -66,6 +66,6 @@ authFacebook cid secret perms =
#else #else
[$hamlet| [$hamlet|
#endif #endif
%p <p>
%a!href=$furl$ $messageFacebook y$ <a href="#{furl}">#{messageFacebook y}
|] |]

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

@ -54,15 +54,18 @@
-- can be used to get the hash from the commandline. -- can be used to get the hash from the commandline.
-- --
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
module Helpers.Auth.HashDB module Yesod.Helpers.Auth.HashDB
( authHashDB ( authHashDB
, getAuthIdHashDB , getAuthIdHashDB
, UserId , UserId
, migrateUsers , migrateUsers
) where ) where
import Yesod import Yesod.Persist
import Yesod.Handler
import Yesod.Form
import Yesod.Helpers.Auth import Yesod.Helpers.Auth
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.ByteString.Lazy.Char8 (pack) import Data.ByteString.Lazy.Char8 (pack)
@ -85,7 +88,7 @@ User
-- | Given a (user,password) in plaintext, validate them against the -- | Given a (user,password) in plaintext, validate them against the
-- database values -- database values
validateUser :: (YesodPersist y, validateUser :: (YesodPersist y,
PersistBackend (YesodDB y (GHandler sub y))) PersistBackend (YesodDB y (GGHandler sub y IO)))
=> (String, String) => (String, String)
-> GHandler sub y Bool -> GHandler sub y Bool
validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->
@ -101,7 +104,7 @@ login = PluginR "hashdb" ["login"]
-- | Handle the login form -- | Handle the login form
postLoginR :: (YesodAuth y, postLoginR :: (YesodAuth y,
YesodPersist y, YesodPersist y,
PersistBackend (YesodDB y (GHandler Auth y))) PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> GHandler Auth y () => GHandler Auth y ()
postLoginR = do postLoginR = do
(user, password) <- runFormPost' $ (,) (user, password) <- runFormPost' $ (,)
@ -113,14 +116,15 @@ postLoginR = do
if isValid if isValid
then setCreds True $ Creds "hashdb" user [] then setCreds True $ Creds "hashdb" user []
else do else do
setMessage $ [$hamlet| %em invalid username/password |] setMessage $ [$hamlet| <em>invalid username/password
|]
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR redirect RedirectTemporary $ toMaster LoginR
-- | A drop in for the getAuthId method of your YesodAuth instance which -- | A drop in for the getAuthId method of your YesodAuth instance which
-- can be used if authHashDB is the only plugin in use. -- can be used if authHashDB is the only plugin in use.
getAuthIdHashDB :: (Key User ~ AuthId master, getAuthIdHashDB :: (Key User ~ AuthId master,
PersistBackend (YesodDB master (GHandler sub master)), PersistBackend (YesodDB master (GGHandler sub master IO)),
YesodPersist master, YesodPersist master,
YesodAuth master) YesodAuth master)
=> (AuthRoute -> Route master) -- ^ your site's Auth Route => (AuthRoute -> Route master) -- ^ your site's Auth Route
@ -137,41 +141,43 @@ getAuthIdHashDB authR creds = do
-- user exists -- user exists
Just (uid, _) -> return $ Just uid Just (uid, _) -> return $ Just uid
Nothing -> do Nothing -> do
setMessage $ [$hamlet| %em user not found |] setMessage $ [$hamlet| <em>user not found
|]
redirect RedirectTemporary $ authR LoginR redirect RedirectTemporary $ authR LoginR
-- | Prompt for username and password, validate that against a database -- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password -- which holds the username and a hash of the password
authHashDB :: (YesodAuth y, authHashDB :: (YesodAuth y,
YesodPersist y, YesodPersist y,
PersistBackend (YesodDB y (GHandler Auth y))) PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> AuthPlugin y => AuthPlugin y
authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
[$hamlet| [$hamlet|\
#header <div id="header">
%h1 Login <h1>Login
\
#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#x!name=username!autofocus <input id="x" name="username" autofocus="">
%tr <tr>
%th Password: <th>Password:
%td <td>
%input!type=password!name=password <input type="password" name="password">
%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
dispatch _ _ = notFound dispatch _ _ = notFound

13
Yesod/Helpers/Auth/OpenId.hs
View File

@ -32,11 +32,10 @@ authOpenId =
y <- liftHandler getYesod y <- liftHandler getYesod
addCassius addCassius
#if GHC7 #if GHC7
[cassius| [cassius|##{ident}
#else #else
[$cassius| [$cassius|##{ident}
#endif #endif
#$ident$
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
padding-left: 18px; padding-left: 18px;
|] |]
@ -46,10 +45,10 @@ authOpenId =
#else #else
[$hamlet| [$hamlet|
#endif #endif
%form!method=get!action=@tm.forwardUrl@ <form method="get" action="@{tm forwardUrl}">
%label!for=$ident$ OpenID: $ <label for="#{ident}">OpenID:
%input#$ident$!type=text!name=$name$!value="http://" <input id="#{ident}" type="text" name="#{name}" value="http://">
%input!type=submit!value=$messageLoginOpenID.y$ <input type="submit" value="#{messageLoginOpenID y}">
|] |]
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
(roid, _, _) <- runFormGet $ stringInput name (roid, _, _) <- runFormGet $ stringInput name

2
Yesod/Helpers/Auth/Rpxnow.hs
View File

@ -29,7 +29,7 @@ authRpxnow app apiKey =
#else #else
[$hamlet| [$hamlet|
#endif #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 dispatch _ [] = do
token1 <- lookupGetParam "token" token1 <- lookupGetParam "token"

4
yesod-auth.cabal
View File

@ -30,7 +30,7 @@ library
, control-monad-attempt >= 0.3.0 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4
, text >= 0.7 && < 0.12 , text >= 0.7 && < 0.12
, mime-mail >= 0.1 && < 0.2 , 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 , yesod-persistent >= 0.0 && < 0.1
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.7 && < 0.8
, yesod-json >= 0.0 && < 0.1 , yesod-json >= 0.0 && < 0.1
@ -39,6 +39,8 @@ library
, text >= 0.11 && < 0.12 , text >= 0.11 && < 0.12
, yesod-form >= 0.0 && < 0.1 , yesod-form >= 0.0 && < 0.1
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, persistent >= 0.4 && < 0.5
, SHA >= 1.4.1.3 && < 1.5
exposed-modules: Yesod.Helpers.Auth exposed-modules: Yesod.Helpers.Auth
Yesod.Helpers.Auth.Dummy Yesod.Helpers.Auth.Dummy
Yesod.Helpers.Auth.Email Yesod.Helpers.Auth.Email