Merge pull request #8 from Shimuuar/master
HashDB improvements and refactorings
This commit is contained in:
Michael Snoyman
commit
bbdca8cb5d
@ -22,19 +22,27 @@ module Yesod.Auth
|
||||
, requireAuth
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Language.Haskell.TH.Syntax hiding (lift)
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import Text.Hamlet (hamlet)
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.Persist
|
||||
import Yesod.Json
|
||||
import Language.Haskell.TH.Syntax hiding (lift)
|
||||
import qualified Network.Wai as W
|
||||
import Text.Hamlet (hamlet)
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Yesod.Auth.Message (AuthMessage, defaultMessage)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
import Yesod.Form (FormMessage)
|
||||
@ -91,11 +99,7 @@ mkYesodSub "Auth"
|
||||
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
||||
]
|
||||
#define STRINGS *Texts
|
||||
#if GHC7
|
||||
[parseRoutes|
|
||||
#else
|
||||
[$parseRoutes|
|
||||
#endif
|
||||
[QQ(parseRoutes)|
|
||||
/check CheckR GET
|
||||
/login LoginR GET
|
||||
/logout LogoutR GET POST
|
||||
@ -108,34 +112,21 @@ credsKey = "_ID"
|
||||
-- | FIXME: won't show up till redirect
|
||||
setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
|
||||
setCreds doRedirects creds = do
|
||||
y <- getYesod
|
||||
y <- getYesod
|
||||
maid <- getAuthId creds
|
||||
case maid of
|
||||
Nothing ->
|
||||
if doRedirects
|
||||
then do
|
||||
case authRoute y of
|
||||
Nothing -> do
|
||||
rh <- defaultLayout
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Invalid login
|
||||
|]
|
||||
when doRedirects $ do
|
||||
case authRoute y of
|
||||
Nothing -> do rh <- defaultLayout [QQ(hamlet)| <h1>Invalid login |]
|
||||
sendResponse rh
|
||||
Just ar -> do
|
||||
setMessageI Msg.InvalidLogin
|
||||
Just ar -> do setMessageI Msg.InvalidLogin
|
||||
redirect RedirectTemporary ar
|
||||
else return ()
|
||||
Just aid -> do
|
||||
setSession credsKey $ toSinglePiece aid
|
||||
if doRedirects
|
||||
then do
|
||||
setMessageI Msg.NowLoggedIn
|
||||
redirectUltDest RedirectTemporary $ loginDest y
|
||||
else return ()
|
||||
when doRedirects $ do
|
||||
setMessageI Msg.NowLoggedIn
|
||||
redirectUltDest RedirectTemporary $ loginDest y
|
||||
|
||||
getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
|
||||
getCheckR = do
|
||||
@ -145,11 +136,7 @@ getCheckR = do
|
||||
addHtml $ html creds) (json' creds)
|
||||
where
|
||||
html creds =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
[QQ(hamlet)|
|
||||
<h1>Authentication Status
|
||||
$maybe _ <- creds
|
||||
<p>Logged in.
|
||||
@ -195,15 +182,10 @@ maybeAuth :: ( YesodAuth m
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Maybe (Key val, val))
|
||||
maybeAuth = do
|
||||
maid <- maybeAuthId
|
||||
case maid of
|
||||
Nothing -> return Nothing
|
||||
Just aid -> do
|
||||
ma <- runDB $ get aid
|
||||
case ma of
|
||||
Nothing -> return Nothing
|
||||
Just a -> return $ Just (aid, a)
|
||||
maybeAuth = runMaybeT $ do
|
||||
aid <- MaybeT $ maybeAuthId
|
||||
a <- MaybeT $ runDB $ get aid
|
||||
return (aid, a)
|
||||
|
||||
requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
|
||||
requireAuthId = maybeAuthId >>= maybe redirectLogin return
|
||||
|
||||
@ -8,6 +8,8 @@ module Yesod.Auth.Dummy
|
||||
( authDummy
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Auth
|
||||
import Yesod.Form (runInputPost, textField, ireq)
|
||||
import Yesod.Handler (notFound)
|
||||
@ -23,11 +25,7 @@ authDummy =
|
||||
dispatch _ _ = notFound
|
||||
url = PluginR "dummy" []
|
||||
login authToMaster =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
[QQ(hamlet)|
|
||||
<form method="post" action="@{authToMaster url}">
|
||||
\Your new identifier is:
|
||||
<input type="text" name="ident">
|
||||
|
||||
@ -14,6 +14,8 @@ module Yesod.Auth.Email
|
||||
, setpassR
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Network.Mail.Mime (randomString)
|
||||
import Yesod.Auth
|
||||
import System.Random
|
||||
@ -81,11 +83,7 @@ authEmail =
|
||||
AuthPlugin "email" dispatch $ \tm -> do
|
||||
y <- lift getYesod
|
||||
l <- lift languages
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
[QQ(whamlet)|
|
||||
<form method="post" action="@{tm loginR}">
|
||||
<table>
|
||||
<tr>
|
||||
@ -119,11 +117,7 @@ getRegisterR = do
|
||||
defaultLayout $ do
|
||||
setTitleI Msg.RegisterLong
|
||||
addWidget
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
[QQ(whamlet)|
|
||||
<p>_{Msg.EnterEmail}
|
||||
<form method="post" action="@{toMaster registerR}">
|
||||
<label for="email">_{Msg.Email}
|
||||
@ -154,13 +148,7 @@ postRegisterR = do
|
||||
defaultLayout $ do
|
||||
setTitleI Msg.ConfirmationEmailSentTitle
|
||||
addWidget
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
<p>_{Msg.ConfirmationEmailSent email}
|
||||
|]
|
||||
[QQ(whamlet)| <p>_{Msg.ConfirmationEmailSent email} |]
|
||||
|
||||
getVerifyR :: YesodAuthEmail m
|
||||
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
|
||||
@ -181,13 +169,7 @@ getVerifyR lid key = do
|
||||
defaultLayout $ do
|
||||
setTitleI Msg.InvalidKey
|
||||
addWidget
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
<p>_{Msg.InvalidKey}
|
||||
|]
|
||||
[QQ(whamlet)| <p>_{Msg.InvalidKey} |]
|
||||
|
||||
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
postLoginR = do
|
||||
@ -226,11 +208,7 @@ getPasswordR = do
|
||||
defaultLayout $ do
|
||||
setTitleI Msg.SetPassTitle
|
||||
addWidget
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
[QQ(whamlet)|
|
||||
<h3>_{Msg.SetPass}
|
||||
<form method="post" action="@{toMaster setpassR}">
|
||||
<table>
|
||||
|
||||
@ -6,6 +6,8 @@ module Yesod.Auth.Facebook
|
||||
, facebookUrl
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Auth
|
||||
import qualified Web.Authenticate.Facebook as Facebook
|
||||
import Data.Aeson
|
||||
@ -56,11 +58,7 @@ authFacebook cid secret perms =
|
||||
render <- lift getUrlRender
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm url
|
||||
let furl = Facebook.getForwardUrl fb $ perms
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
[QQ(whamlet)|
|
||||
<p>
|
||||
<a href="#{furl}">_{Msg.Facebook}
|
||||
|]
|
||||
|
||||
@ -16,8 +16,7 @@
|
||||
-- Portability : Portable
|
||||
--
|
||||
-- A yesod-auth AuthPlugin designed to look users up in Persist where
|
||||
-- their user id's and a sha1 hash of their password will already be
|
||||
-- stored.
|
||||
-- their user id's and a salted SHA1 hash of their password is stored.
|
||||
--
|
||||
-- Example usage:
|
||||
--
|
||||
@ -37,10 +36,8 @@
|
||||
-- >
|
||||
-- > loginDest _ = RootR
|
||||
-- > logoutDest _ = RootR
|
||||
-- > getAuthId = getAuthIdHashDB AuthR
|
||||
-- > showAuthId _ = showIntegral
|
||||
-- > readAuthId _ = readIntegral
|
||||
-- > authPlugins = [authHashDB]
|
||||
-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)
|
||||
-- > authPlugins = [authHashDB (Just . UniqueUser)]
|
||||
-- >
|
||||
-- >
|
||||
-- > -- include the migration function in site startup
|
||||
@ -49,21 +46,31 @@
|
||||
-- > runSqlPool (runMigration migrateUsers) p
|
||||
-- > let h = DevSite p
|
||||
--
|
||||
-- Your app must be an instance of YesodPersist and the username and
|
||||
-- hashed-passwords must be added manually to the database.
|
||||
-- Note that function which converts username to unique identifier must be same.
|
||||
--
|
||||
-- > echo -n 'MyPassword' | sha1sum
|
||||
-- Your app must be an instance of YesodPersist. and the username,
|
||||
-- salt and hashed-passwords should be added to the database.
|
||||
--
|
||||
-- > echo -n 'MySaltMyPassword' | sha1sum
|
||||
--
|
||||
-- can be used to get the hash from the commandline.
|
||||
--
|
||||
-------------------------------------------------------------------------------
|
||||
module Yesod.Auth.HashDB
|
||||
( authHashDB
|
||||
( HashDBUser(..)
|
||||
, setPassword
|
||||
-- * Authentification
|
||||
, validateUser
|
||||
, authHashDB
|
||||
, getAuthIdHashDB
|
||||
-- * Predefined data type
|
||||
, User(..)
|
||||
, UserId
|
||||
, migrateUsers
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Persist
|
||||
import Yesod.Handler
|
||||
import Yesod.Form
|
||||
@ -71,115 +78,130 @@ import Yesod.Auth
|
||||
import Text.Hamlet (hamlet)
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Data.ByteString.Lazy.Char8 (pack)
|
||||
import Control.Monad (replicateM,liftM)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
|
||||
import Data.Digest.Pure.SHA (sha1, showDigest)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text (Text, pack, unpack, append)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import System.Random (randomRIO)
|
||||
|
||||
-- | Computer the sha1 of a string and return it as a string
|
||||
sha1String :: String -> String
|
||||
sha1String = showDigest . sha1 . pack
|
||||
|
||||
-- | Generate data base instances for a valid user
|
||||
share2 mkPersist (mkMigrate "migrateUsers")
|
||||
#if GHC7
|
||||
[persist|
|
||||
#else
|
||||
[$persist|
|
||||
#endif
|
||||
User
|
||||
username Text Eq
|
||||
password Text
|
||||
UniqueUser username
|
||||
|]
|
||||
-- | Interface for data type which holds user info. It's just a
|
||||
-- collection of getters and setters
|
||||
class HashDBUser user where
|
||||
-- | Retrieve password hash from user data
|
||||
userPasswordHash :: user -> Maybe Text
|
||||
-- | Retrieve salt for password
|
||||
userPasswordSalt :: user -> Maybe Text
|
||||
-- | Set hash and password
|
||||
setUserHashAndSalt :: Text -- ^ Salt
|
||||
-> Text -- ^ Password hash
|
||||
-> user -> user
|
||||
|
||||
-- | Generate random salt. Length of 8 is chosen arbitrarily
|
||||
randomSalt :: MonadIO m => m Text
|
||||
randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
|
||||
|
||||
-- | Calculate salted hash using SHA1.
|
||||
saltedHash :: Text -- ^ Salt
|
||||
-> Text -- ^ Password
|
||||
-> Text
|
||||
saltedHash salt =
|
||||
pack . showDigest . sha1 . BS.pack . unpack . append salt
|
||||
|
||||
-- | Set password for user. This function should be used for setting
|
||||
-- passwords. It generates random salt and calculates proper hashes.
|
||||
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
|
||||
setPassword pwd u = do salt <- randomSalt
|
||||
return $ setUserHashAndSalt salt (saltedHash salt pwd) u
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- Authentification
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Given a user ID and password in plaintext, validate them against
|
||||
-- the database values.
|
||||
validateUser :: ( YesodPersist yesod
|
||||
, PersistBackend (YesodDB yesod (GGHandler sub yesod IO))
|
||||
, PersistEntity user
|
||||
, HashDBUser user
|
||||
) =>
|
||||
Unique user -- ^ User unique identifier
|
||||
-> Text -- ^ Password in plaint-text
|
||||
-> GHandler sub yesod Bool
|
||||
validateUser userID passwd = do
|
||||
-- Checks that hash and password match
|
||||
let validate u = do hash <- userPasswordHash u
|
||||
salt <- userPasswordSalt u
|
||||
return $ hash == saltedHash salt passwd
|
||||
-- Get user data
|
||||
user <- runDB $ getBy userID
|
||||
return $ fromMaybe False $ validate . snd =<< user
|
||||
|
||||
-- | Given a (user,password) in plaintext, validate them against the
|
||||
-- database values
|
||||
validateUser :: (YesodPersist y,
|
||||
PersistBackend (YesodDB y (GGHandler sub y IO)))
|
||||
=> (Text, Text)
|
||||
-> GHandler sub y Bool
|
||||
validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->
|
||||
case dbUser of
|
||||
-- user not found
|
||||
Nothing -> return False
|
||||
-- validate password
|
||||
Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)
|
||||
|
||||
login :: AuthRoute
|
||||
login = PluginR "hashdb" ["login"]
|
||||
|
||||
-- | Handle the login form
|
||||
postLoginR :: (YesodAuth y,
|
||||
YesodPersist y,
|
||||
PersistBackend (YesodDB y (GGHandler Auth y IO)))
|
||||
=> GHandler Auth y ()
|
||||
postLoginR = do
|
||||
|
||||
-- | Handle the login form. First parameter is function which maps
|
||||
-- username (whatever it might be) to unique user ID.
|
||||
postLoginR :: ( YesodAuth y, YesodPersist y
|
||||
, HashDBUser user, PersistEntity user
|
||||
, PersistBackend (YesodDB y (GGHandler Auth y IO)))
|
||||
=> (Text -> Maybe (Unique user))
|
||||
-> GHandler Auth y ()
|
||||
postLoginR uniq = do
|
||||
(mu,mp) <- runInputPost $ (,)
|
||||
<$> iopt textField "username"
|
||||
<*> iopt textField "password"
|
||||
|
||||
isValid <- case (mu,mp) of
|
||||
(Nothing, _ ) -> return False
|
||||
(_ , Nothing) -> return False
|
||||
(Just u , Just p ) -> validateUser (u,p)
|
||||
isValid <- fromMaybe (return False)
|
||||
(validateUser <$> (uniq =<< mu) <*> mp)
|
||||
if isValid
|
||||
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
||||
else do setMessage [QQ(hamlet)| Invalid username/password |]
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
if isValid
|
||||
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
||||
else do
|
||||
setMessage
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
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 (GGHandler sub master IO)),
|
||||
YesodPersist master,
|
||||
YesodAuth master)
|
||||
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
|
||||
-> Creds m -- ^ the creds argument
|
||||
-> GHandler sub master (Maybe UserId)
|
||||
getAuthIdHashDB authR creds = do
|
||||
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
|
||||
, HashDBUser user, PersistEntity user
|
||||
, Key user ~ AuthId master
|
||||
, PersistBackend (YesodDB master (GGHandler sub master IO)))
|
||||
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
|
||||
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
|
||||
-> Creds master -- ^ the creds argument
|
||||
-> GHandler sub master (Maybe (AuthId master))
|
||||
getAuthIdHashDB authR uniq creds = do
|
||||
muid <- maybeAuth
|
||||
case muid of
|
||||
-- user already authenticated
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
x <- runDB $ getBy $ UniqueUser (credsIdent creds)
|
||||
x <- case uniq (credsIdent creds) of
|
||||
Nothing -> return Nothing
|
||||
Just u -> runDB (getBy u)
|
||||
case x of
|
||||
-- user exists
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
setMessage
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
User not found
|
||||
|]
|
||||
setMessage [QQ(hamlet)| 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 (GGHandler Auth y IO)))
|
||||
=> AuthPlugin y
|
||||
authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
authHashDB :: ( YesodAuth m, YesodPersist m
|
||||
, HashDBUser user
|
||||
, PersistEntity user
|
||||
, PersistBackend (YesodDB m (GGHandler Auth m IO)))
|
||||
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
|
||||
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
[QQ(hamlet)|
|
||||
<div id="header">
|
||||
<h1>Login
|
||||
|
||||
@ -206,5 +228,27 @@ authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
|
||||
|
||||
|]
|
||||
where
|
||||
dispatch "POST" ["login"] = postLoginR >>= sendResponse
|
||||
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
|
||||
dispatch _ _ = notFound
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- Predefined datatype
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Generate data base instances for a valid user
|
||||
share2 mkPersist (mkMigrate "migrateUsers")
|
||||
[QQ(persist)|
|
||||
User
|
||||
username Text Eq
|
||||
password Text
|
||||
salt Text
|
||||
UniqueUser username
|
||||
|]
|
||||
|
||||
instance HashDBUser User where
|
||||
userPasswordHash = Just . userPassword
|
||||
userPasswordSalt = Just . userSalt
|
||||
setUserHashAndSalt s h u = u { userSalt = s
|
||||
, userPassword = h
|
||||
}
|
||||
|
||||
@ -6,6 +6,9 @@ module Yesod.Auth.OAuth
|
||||
, authTwitter
|
||||
, twitterUrl
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Auth
|
||||
import Yesod.Form
|
||||
import Yesod.Handler
|
||||
@ -66,13 +69,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
|
||||
render <- lift getUrlRender
|
||||
let oaUrl = render $ tm $ oauthUrl name
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<a href=#{oaUrl}>Login with #{name}
|
||||
|]
|
||||
[QQ(hamlet)| <a href=#{oaUrl}>Login with #{name} |]
|
||||
|
||||
authTwitter :: YesodAuth m =>
|
||||
String -- ^ Consumer Key
|
||||
|
||||
@ -6,6 +6,8 @@ module Yesod.Auth.OpenId
|
||||
, forwardUrl
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Auth
|
||||
import qualified Web.Authenticate.OpenId as OpenId
|
||||
import Control.Monad.Attempt
|
||||
@ -34,20 +36,12 @@ authOpenId =
|
||||
ident <- lift newIdent
|
||||
y <- lift getYesod
|
||||
addCassius
|
||||
#if GHC7
|
||||
[cassius|##{ident}
|
||||
#else
|
||||
[$cassius|##{ident}
|
||||
#endif
|
||||
[QQ(cassius)|##{ident}
|
||||
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
|
||||
padding-left: 18px;
|
||||
|]
|
||||
l <- lift languages
|
||||
#if GHC7
|
||||
[whamlet|
|
||||
#else
|
||||
[$whamlet|
|
||||
#endif
|
||||
[QQ(whamlet)|
|
||||
<form method="get" action="@{tm forwardUrl}">
|
||||
<label for="#{ident}">OpenID: #
|
||||
<input id="#{ident}" type="text" name="#{name}" value="http://">
|
||||
|
||||
@ -5,6 +5,8 @@ module Yesod.Auth.Rpxnow
|
||||
( authRpxnow
|
||||
) where
|
||||
|
||||
#include "qq.h"
|
||||
|
||||
import Yesod.Auth
|
||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
import Control.Monad (mplus)
|
||||
@ -27,11 +29,7 @@ authRpxnow app apiKey =
|
||||
login tm = do
|
||||
let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
|
||||
addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
[QQ(hamlet)|
|
||||
<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|
||||
|]
|
||||
dispatch _ [] = do
|
||||
|
||||
10
include/qq.h
Normal file
10
include/qq.h
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
-- CPP macro which choses which quasyquotes syntax to use depending
|
||||
-- on GHC version.
|
||||
--
|
||||
-- QQ stands for quasyquote.
|
||||
#if GHC7
|
||||
# define QQ(x) x
|
||||
#else
|
||||
# define QQ(x) $x
|
||||
#endif
|
||||
@ -53,6 +53,8 @@ library
|
||||
Yesod.Auth.HashDB
|
||||
Yesod.Auth.Message
|
||||
ghc-options: -Wall
|
||||
include-dirs:
|
||||
include
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
Loading…
Reference in New Issue
Block a user