removed QQ hacks from yesod-auth
This commit is contained in:
parent
ba1e083edc
commit
f4e743e50d
@ -1,9 +1,9 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -27,8 +27,6 @@ module Yesod.Auth
|
|||||||
, AuthException (..)
|
, AuthException (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
|
|
||||||
@ -132,7 +130,7 @@ mkYesodSub "Auth"
|
|||||||
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
||||||
]
|
]
|
||||||
#define STRINGS *Texts
|
#define STRINGS *Texts
|
||||||
[QQ(parseRoutes)|
|
[parseRoutes|
|
||||||
/check CheckR GET
|
/check CheckR GET
|
||||||
/login LoginR GET
|
/login LoginR GET
|
||||||
/logout LogoutR GET POST
|
/logout LogoutR GET POST
|
||||||
@ -151,7 +149,7 @@ setCreds doRedirects creds = do
|
|||||||
Nothing ->
|
Nothing ->
|
||||||
when doRedirects $ do
|
when doRedirects $ do
|
||||||
case authRoute y of
|
case authRoute y of
|
||||||
Nothing -> do rh <- defaultLayout $ addHtml [QQ(shamlet)| <h1>Invalid login |]
|
Nothing -> do rh <- defaultLayout $ addHtml [shamlet| <h1>Invalid login |]
|
||||||
sendResponse rh
|
sendResponse rh
|
||||||
Just ar -> do setMessageI Msg.InvalidLogin
|
Just ar -> do setMessageI Msg.InvalidLogin
|
||||||
redirect ar
|
redirect ar
|
||||||
@ -169,7 +167,7 @@ getCheckR = do
|
|||||||
addHtml $ html' creds) (jsonCreds creds)
|
addHtml $ html' creds) (jsonCreds creds)
|
||||||
where
|
where
|
||||||
html' creds =
|
html' creds =
|
||||||
[QQ(shamlet)|
|
[shamlet|
|
||||||
<h1>Authentication Status
|
<h1>Authentication Status
|
||||||
$maybe _ <- creds
|
$maybe _ <- creds
|
||||||
<p>Logged in.
|
<p>Logged in.
|
||||||
|
|||||||
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Yesod.Auth.BrowserId
|
module Yesod.Auth.BrowserId
|
||||||
( authBrowserId
|
( authBrowserId
|
||||||
@ -16,8 +15,6 @@ import Data.Maybe (fromMaybe)
|
|||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Exception (throwIO)
|
import Control.Exception (throwIO)
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
pid :: Text
|
pid :: Text
|
||||||
pid = "browserid"
|
pid = "browserid"
|
||||||
|
|
||||||
@ -64,7 +61,7 @@ helper maudience = AuthPlugin
|
|||||||
_ -> notFound
|
_ -> notFound
|
||||||
, apLogin = \toMaster -> do
|
, apLogin = \toMaster -> do
|
||||||
addScriptRemote browserIdJs
|
addScriptRemote browserIdJs
|
||||||
addHamlet [QQ(hamlet)|
|
addHamlet [hamlet|
|
||||||
<p>
|
<p>
|
||||||
<a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
|
<a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
|
||||||
<img src="https://browserid.org/i/sign_in_green.png">
|
<img src="https://browserid.org/i/sign_in_green.png">
|
||||||
|
|||||||
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
-- | Provides a dummy authentication module that simply lets a user specify
|
-- | Provides a dummy authentication module that simply lets a user specify
|
||||||
-- his/her identifier. This is not intended for real world use, just for
|
-- his/her identifier. This is not intended for real world use, just for
|
||||||
@ -8,8 +7,6 @@ module Yesod.Auth.Dummy
|
|||||||
( authDummy
|
( authDummy
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import Yesod.Form (runInputPost, textField, ireq)
|
import Yesod.Form (runInputPost, textField, ireq)
|
||||||
import Yesod.Handler (notFound)
|
import Yesod.Handler (notFound)
|
||||||
@ -26,7 +23,7 @@ authDummy =
|
|||||||
dispatch _ _ = notFound
|
dispatch _ _ = notFound
|
||||||
url = PluginR "dummy" []
|
url = PluginR "dummy" []
|
||||||
login authToMaster =
|
login authToMaster =
|
||||||
addHamlet [QQ(hamlet)|
|
addHamlet [hamlet|
|
||||||
<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">
|
||||||
|
|||||||
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
module Yesod.Auth.Email
|
module Yesod.Auth.Email
|
||||||
@ -15,8 +14,6 @@ module Yesod.Auth.Email
|
|||||||
, isValidPass
|
, isValidPass
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Network.Mail.Mime (randomString)
|
import Network.Mail.Mime (randomString)
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import System.Random
|
import System.Random
|
||||||
@ -82,7 +79,7 @@ class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where
|
|||||||
authEmail :: YesodAuthEmail m => AuthPlugin m
|
authEmail :: YesodAuthEmail m => AuthPlugin m
|
||||||
authEmail =
|
authEmail =
|
||||||
AuthPlugin "email" dispatch $ \tm ->
|
AuthPlugin "email" dispatch $ \tm ->
|
||||||
[QQ(whamlet)|
|
[whamlet|
|
||||||
<form method="post" action="@{tm loginR}">
|
<form method="post" action="@{tm loginR}">
|
||||||
<table>
|
<table>
|
||||||
<tr>
|
<tr>
|
||||||
@ -116,7 +113,7 @@ getRegisterR = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI Msg.RegisterLong
|
setTitleI Msg.RegisterLong
|
||||||
addWidget
|
addWidget
|
||||||
[QQ(whamlet)|
|
[whamlet|
|
||||||
<p>_{Msg.EnterEmail}
|
<p>_{Msg.EnterEmail}
|
||||||
<form method="post" action="@{toMaster registerR}">
|
<form method="post" action="@{toMaster registerR}">
|
||||||
<label for="email">_{Msg.Email}
|
<label for="email">_{Msg.Email}
|
||||||
@ -147,7 +144,7 @@ postRegisterR = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI Msg.ConfirmationEmailSentTitle
|
setTitleI Msg.ConfirmationEmailSentTitle
|
||||||
addWidget
|
addWidget
|
||||||
[QQ(whamlet)| <p>_{Msg.ConfirmationEmailSent email} |]
|
[whamlet| <p>_{Msg.ConfirmationEmailSent email} |]
|
||||||
|
|
||||||
getVerifyR :: YesodAuthEmail m
|
getVerifyR :: YesodAuthEmail m
|
||||||
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
|
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
|
||||||
@ -168,7 +165,7 @@ getVerifyR lid key = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI Msg.InvalidKey
|
setTitleI Msg.InvalidKey
|
||||||
addWidget
|
addWidget
|
||||||
[QQ(whamlet)| <p>_{Msg.InvalidKey} |]
|
[whamlet| <p>_{Msg.InvalidKey} |]
|
||||||
|
|
||||||
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
||||||
postLoginR = do
|
postLoginR = do
|
||||||
@ -207,7 +204,7 @@ getPasswordR = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI Msg.SetPassTitle
|
setTitleI Msg.SetPassTitle
|
||||||
addWidget
|
addWidget
|
||||||
[QQ(whamlet)|
|
[whamlet|
|
||||||
<h3>_{Msg.SetPass}
|
<h3>_{Msg.SetPass}
|
||||||
<form method="post" action="@{toMaster setpassR}">
|
<form method="post" action="@{toMaster setpassR}">
|
||||||
<table>
|
<table>
|
||||||
|
|||||||
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
-- | Use an email address as an identifier via Google's OpenID login system.
|
-- | Use an email address as an identifier via Google's OpenID login system.
|
||||||
--
|
--
|
||||||
|
|||||||
@ -2,7 +2,6 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
@ -72,8 +71,6 @@ module Yesod.Auth.HashDB
|
|||||||
, migrateUsers
|
, migrateUsers
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Yesod.Persist
|
import Yesod.Persist
|
||||||
import Yesod.Handler
|
import Yesod.Handler
|
||||||
import Yesod.Form
|
import Yesod.Form
|
||||||
@ -179,7 +176,7 @@ postLoginR uniq = do
|
|||||||
(validateUser <$> (uniq =<< mu) <*> mp)
|
(validateUser <$> (uniq =<< mu) <*> mp)
|
||||||
if isValid
|
if isValid
|
||||||
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
|
||||||
else do setMessage [QQ(shamlet)| Invalid username/password |]
|
else do setMessage [shamlet| Invalid username/password |]
|
||||||
toMaster <- getRouteToMaster
|
toMaster <- getRouteToMaster
|
||||||
redirect $ toMaster LoginR
|
redirect $ toMaster LoginR
|
||||||
|
|
||||||
@ -210,7 +207,7 @@ getAuthIdHashDB authR uniq creds = do
|
|||||||
-- user exists
|
-- user exists
|
||||||
Just (Entity uid _) -> return $ Just uid
|
Just (Entity uid _) -> return $ Just uid
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
setMessage [QQ(shamlet)| User not found |]
|
setMessage [shamlet| User not found |]
|
||||||
redirect $ authR LoginR
|
redirect $ authR LoginR
|
||||||
|
|
||||||
-- | Prompt for username and password, validate that against a database
|
-- | Prompt for username and password, validate that against a database
|
||||||
@ -224,7 +221,7 @@ authHashDB :: ( YesodAuth m, YesodPersist m
|
|||||||
, PersistUnique b (GHandler Auth m))
|
, PersistUnique b (GHandler Auth m))
|
||||||
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m
|
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m
|
||||||
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
|
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
|
||||||
[QQ(hamlet)|
|
[hamlet|
|
||||||
<div id="header">
|
<div id="header">
|
||||||
<h1>Login
|
<h1>Login
|
||||||
|
|
||||||
@ -261,7 +258,7 @@ authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
|
|||||||
|
|
||||||
-- | Generate data base instances for a valid user
|
-- | Generate data base instances for a valid user
|
||||||
share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
|
share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
|
||||||
[QQ(persistUpperCase)|
|
[persistUpperCase|
|
||||||
User
|
User
|
||||||
username Text Eq
|
username Text Eq
|
||||||
password Text
|
password Text
|
||||||
|
|||||||
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Yesod.Auth.OpenId
|
module Yesod.Auth.OpenId
|
||||||
( authOpenId
|
( authOpenId
|
||||||
@ -7,8 +6,6 @@ module Yesod.Auth.OpenId
|
|||||||
, forwardUrl
|
, forwardUrl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import qualified Web.Authenticate.OpenId as OpenId
|
import qualified Web.Authenticate.OpenId as OpenId
|
||||||
|
|
||||||
@ -37,11 +34,11 @@ authOpenIdExtended extensionFields =
|
|||||||
login tm = do
|
login tm = do
|
||||||
ident <- lift newIdent
|
ident <- lift newIdent
|
||||||
addCassius
|
addCassius
|
||||||
[QQ(cassius)|##{ident}
|
[cassius|##{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;
|
||||||
|]
|
|]
|
||||||
[QQ(whamlet)|
|
[whamlet|
|
||||||
<form method="get" action="@{tm forwardUrl}">
|
<form method="get" action="@{tm forwardUrl}">
|
||||||
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
|
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
|
||||||
<button .openid-google>_{Msg.LoginGoogle}
|
<button .openid-google>_{Msg.LoginGoogle}
|
||||||
|
|||||||
@ -1,12 +1,9 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Yesod.Auth.Rpxnow
|
module Yesod.Auth.Rpxnow
|
||||||
( authRpxnow
|
( authRpxnow
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#include "qq.h"
|
|
||||||
|
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||||
import Control.Monad (mplus)
|
import Control.Monad (mplus)
|
||||||
@ -28,7 +25,7 @@ authRpxnow app apiKey =
|
|||||||
login tm = do
|
login tm = do
|
||||||
let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
|
let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
|
||||||
addHamlet
|
addHamlet
|
||||||
[QQ(hamlet)|
|
[hamlet|
|
||||||
<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
|
||||||
|
|||||||
@ -1,10 +0,0 @@
|
|||||||
|
|
||||||
-- 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
|
|
||||||
Loading…
Reference in New Issue
Block a user