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

It all compiles

Browse Source
This commit is contained in:
Michael Snoyman 2019-03-12 13:14:27 +02:00
parent cd76b34497
commit eccbe4acbe
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
10 changed files with 132 additions and 891 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
yesod-auth-oauth/Yesod/Auth/OAuth.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
@ -14,14 +15,8 @@ module Yesod.Auth.OAuth
, tumblrUrl
, module Web.Authenticate.OAuth
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import UnliftIO.Exception
import Control.Monad.IO.Class
import UnliftIO (MonadUnliftIO)
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text)
import RIO
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
@ -53,14 +48,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
oauthSessionName = "__oauth_token_secret"
dispatch
:: ( MonadHandler m
, master ~ HandlerSite m
, Auth ~ SubHandlerSite m
, MonadUnliftIO m
)
=> Text
:: Text
-> [Text]
-> m TypedContent
-> SubHandlerFor Auth master TypedContent
dispatch "GET" ["forward"] = do
render <- getUrlRender
tm <- getRouteToParent
@ -83,8 +73,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
]
else do
(verifier, oaTok) <-
runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
A.<*> ireq textField "oauth_token"
runInputGet $ (,) <$> ireq textField "oauth_verifier"
<*> ireq textField "oauth_token"
return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
, ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)

2
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -24,7 +24,7 @@ library
build-depends: authenticate-oauth >= 1.5 && < 1.7
, bytestring >= 0.9.1.4
, text >= 0.7
, unliftio
, rio
, yesod-auth >= 1.6 && < 1.7
, yesod-core >= 1.6 && < 1.7
, yesod-form >= 1.6 && < 1.7

178
yesod-auth/Yesod/Auth.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
@ -15,6 +16,7 @@ module Yesod.Auth
( -- * Subsite
Auth
, AuthRoute
, AuthHandler
, Route (..)
, AuthPlugin (..)
, getAuth
@ -38,9 +40,6 @@ module Yesod.Auth
, requireAuth
-- * Exception
, AuthException (..)
-- * Helper
, MonadAuthHandler
, AuthHandler
-- * Internal
, credsKey
, provideJsonMessage
@ -48,9 +47,8 @@ module Yesod.Auth
, asHtml
) where
import Control.Monad (when)
import RIO
import Control.Monad.Trans.Maybe
import UnliftIO (withRunInIO, MonadUnliftIO)
import Yesod.Auth.Routes
import Data.Aeson hiding (json)
@ -76,10 +74,9 @@ import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
type AuthRoute = Route Auth
type AuthHandler site = SubHandlerFor Auth site
type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
type AuthRoute = Route Auth
type Method = Text
type Piece = Text
@ -94,7 +91,7 @@ data AuthenticationResult master
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apDispatch :: Method -> [Piece] -> SubHandlerFor Auth master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
}
@ -112,7 +109,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
type AuthId master
-- | specify the layout. Uses defaultLayout by default
authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
authLayout :: (HasHandlerData env, HandlerSite env ~ master) => WidgetFor master () -> RIO env Html
authLayout = liftHandler . defaultLayout
-- | Default destination on successful login, if no other
@ -128,7 +125,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- Default implementation is in terms of @'getAuthId'@
--
-- @since: 1.4.4
authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
authenticate :: (HasHandlerData env, HandlerSite env ~ master) => Creds master -> RIO env (AuthenticationResult master)
authenticate creds = do
muid <- getAuthId creds
@ -138,7 +135,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- Default implementation is in terms of @'authenticate'@
--
getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
getAuthId :: (HasHandlerData env, HandlerSite env ~ master) => Creds master -> RIO env (Maybe (AuthId master))
getAuthId creds = do
auth <- authenticate creds
@ -168,7 +165,9 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- > lift $ redirect HomeR -- or any other Handler code you want
-- > defaultLoginHandler
--
loginHandler :: AuthHandler master Html
loginHandler
:: (HasHandlerData env, SubHandlerSite env ~ Auth, HandlerSite env ~ master)
=> RIO env Html
loginHandler = defaultLoginHandler
-- | Used for i18n of messages provided by this package.
@ -194,16 +193,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager\"@ here.
authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
authHttpManager :: (HasHandlerData env, HandlerSite env ~ master) => RIO env Manager
authHttpManager = liftIO getGlobalManager
-- | Called on a successful login. By default, calls
-- @addMessageI "success" NowLoggedIn@.
onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
onLogin :: (HasHandlerData env, master ~ HandlerSite env) => RIO env ()
onLogin = addMessageI "success" Msg.NowLoggedIn
-- | Called on logout. By default, does nothing
onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
onLogout :: (HasHandlerData env, master ~ HandlerSite env) => RIO env ()
onLogout = return ()
-- | Retrieves user credentials, if user is authenticated.
@ -215,16 +214,20 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- other than a browser.
--
-- @since 1.2.0
maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
maybeAuthId :: (HasHandlerData env, master ~ HandlerSite env) => RIO env (Maybe (AuthId master))
default maybeAuthId
:: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
=> m (Maybe (AuthId master))
:: (HasHandlerData env, master ~ HandlerSite env, YesodAuthPersist master, Typeable (AuthEntity master))
=> RIO env (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls
-- @addMessage@ with "error" as status and redirects to @dest@.
onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
onErrorHtml
:: (HasHandlerData env, HandlerSite env ~ master)
=> Route master
-> Text
-> RIO env Html
onErrorHtml dest msg = do
addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest
@ -235,10 +238,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
-- This is an experimental API that is not broadly used throughout the yesod-auth code base
runHttpRequest
:: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
:: (HasHandlerData env, HandlerSite env ~ master)
=> Request
-> (Response BodyReader -> m a)
-> m a
-> (Response BodyReader -> RIO env a)
-> RIO env a
runHttpRequest req inner = do
man <- authHttpManager
withRunInIO $ \run -> withResponse req man $ run . inner
@ -261,8 +264,8 @@ credsKey = "_ID"
--
-- @since 1.1.2
defaultMaybeAuthId
:: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
=> m (Maybe (AuthId master))
:: (HasHandlerData env, HandlerSite env ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
=> RIO env (Maybe (AuthId master))
defaultMaybeAuthId = runMaybeT $ do
s <- MaybeT $ lookupSession credsKey
aid <- MaybeT $ return $ fromPathPiece s
@ -270,13 +273,13 @@ defaultMaybeAuthId = runMaybeT $ do
return aid
cachedAuth
:: ( MonadHandler m
:: ( HasHandlerData env
, YesodAuthPersist master
, Typeable (AuthEntity master)
, HandlerSite m ~ master
, HandlerSite env ~ master
)
=> AuthId master
-> m (Maybe (AuthEntity master))
-> RIO env (Maybe (AuthEntity master))
cachedAuth
= fmap unCachedMaybeAuth
. cached
@ -290,7 +293,9 @@ cachedAuth
-- wraps the result in 'authLayout'. See 'loginHandler' for more details.
--
-- @since 1.4.9
defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler
:: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
=> RIO env Html
defaultLoginHandler = do
tp <- getRouteToParent
authLayout $ do
@ -298,21 +303,21 @@ defaultLoginHandler = do
master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master)
loginErrorMessageI
:: Route Auth
:: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
=> Route Auth
-> AuthMessage
-> AuthHandler master TypedContent
-> RIO env TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI
:: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
:: (HasHandlerData env, HandlerSite env ~ master, YesodAuth master)
=> Route master
-> AuthMessage
-> m TypedContent
-> RIO env TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
@ -320,28 +325,28 @@ loginErrorMessageMasterI dest msg = do
-- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status
loginErrorMessage
:: (MonadHandler m, YesodAuth (HandlerSite m))
=> Route (HandlerSite m)
:: (HasHandlerData env, YesodAuth (HandlerSite env))
=> Route (HandlerSite env)
-> Text
-> m TypedContent
-> RIO env TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401
:: MonadHandler m
:: HasHandlerData env
=> Text
-> m Html
-> m TypedContent
-> RIO env Html
-> RIO env TypedContent
messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
messageJson500 :: HasHandlerData env => Text -> RIO env Html -> RIO env TypedContent
messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus
:: MonadHandler m
:: HasHandlerData env
=> Status
-> Text
-> m Html
-> m TypedContent
-> RIO env Html
-> RIO env TypedContent
messageJsonStatus status msg html = selectRep $ do
provideRep html
provideRep $ do
@ -354,9 +359,9 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect
:: (MonadHandler m, YesodAuth (HandlerSite m))
=> Creds (HandlerSite m) -- ^ new credentials
-> m TypedContent
:: (HasHandlerData env, YesodAuth (HandlerSite env))
=> Creds (HandlerSite env) -- ^ new credentials
-> RIO env TypedContent
setCredsRedirect creds = do
y <- getYesod
auth <- authenticate creds
@ -379,7 +384,7 @@ setCredsRedirect creds = do
Just ar -> loginErrorMessageMasterI ar msg
ServerError msg -> do
$(logError) msg
logError $ display msg
case authRoute y of
Nothing -> do
@ -395,10 +400,10 @@ setCredsRedirect creds = do
return $ renderAuthMessage master langs msg
-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
setCreds :: (HasHandlerData env, YesodAuth (HandlerSite env))
=> Bool -- ^ if HTTP redirects should be done
-> Creds (HandlerSite m) -- ^ new credentials
-> m ()
-> Creds (HandlerSite env) -- ^ new credentials
-> RIO env ()
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
@ -409,10 +414,10 @@ setCreds doRedirects creds =
-- | same as defaultLayoutJson, but uses authLayout
authLayoutJson
:: (ToJSON j, MonadAuthHandler master m)
=> WidgetFor master () -- ^ HTML
-> m j -- ^ JSON
-> m TypedContent
:: (ToJSON j, HasHandlerData env, YesodAuth (HandlerSite env))
=> WidgetFor (HandlerSite env) () -- ^ HTML
-> RIO env j -- ^ JSON
-> RIO env TypedContent
authLayoutJson w json = selectRep $ do
provideRep $ authLayout w
provideRep $ fmap toJSON json
@ -420,9 +425,9 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session.
--
-- @since 1.1.7
clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
clearCreds :: (HasHandlerData env, YesodAuth (HandlerSite env))
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> m ()
-> RIO env ()
clearCreds doRedirects = do
y <- getYesod
onLogout
@ -430,7 +435,7 @@ clearCreds doRedirects = do
when doRedirects $ do
redirectUltDest $ logoutDest y
getCheckR :: AuthHandler master TypedContent
getCheckR :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env TypedContent
getCheckR = do
creds <- maybeAuthId
authLayoutJson (do
@ -451,23 +456,27 @@ $nothing
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
setUltDestReferer' :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env ()
setUltDestReferer' = do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master Html
getLoginR :: (HasHandlerData env, YesodAuth (HandlerSite env), SubHandlerSite env ~ Auth) => RIO env Html
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
getLogoutR :: (HasHandlerData env, YesodAuth (HandlerSite env), SubHandlerSite env ~ Auth) => RIO env ()
getLogoutR = do
tp <- getRouteToParent
setUltDestReferer' >> redirectToPost (tp LogoutR)
postLogoutR :: AuthHandler master ()
postLogoutR :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env ()
postLogoutR = clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR
:: YesodAuth site
=> Text
-> [Text]
-> SubHandlerFor Auth site TypedContent
handlePluginR plugin pieces = do
master <- getYesod
env <- waiRequest
@ -486,9 +495,9 @@ maybeAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
, MonadHandler m
, HandlerSite m ~ master
) => m (Maybe (Entity val))
, HasHandlerData env
, HandlerSite env ~ master
) => RIO env (Maybe (Entity val))
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
@ -498,10 +507,10 @@ maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
maybeAuthPair
:: ( YesodAuthPersist master
, Typeable (AuthEntity master)
, MonadHandler m
, HandlerSite m ~ master
, HasHandlerData env
, HandlerSite env ~ master
)
=> m (Maybe (AuthId master, AuthEntity master))
=> RIO env (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId
ae <- MaybeT $ cachedAuth aid
@ -532,18 +541,21 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
=> AuthId master -> m (Maybe (AuthEntity master))
getAuthEntity
:: (HasHandlerData env, HandlerSite env ~ master)
=> AuthId master
-> RIO env (Maybe (AuthEntity master))
default getAuthEntity
:: ( YesodPersistBackend master ~ backend
, PersistRecordBackend (AuthEntity master) backend
, Key (AuthEntity master) ~ AuthId master
, PersistStore backend
, MonadHandler m
, HandlerSite m ~ master
, HasHandlerData env
, HandlerSite env ~ master
)
=> AuthId master -> m (Maybe (AuthEntity master))
=> AuthId master
-> RIO env (Maybe (AuthEntity master))
getAuthEntity = liftHandler . runDB . get
@ -554,7 +566,7 @@ type instance KeyEntity (Key x) = x
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- @since 1.1.0
requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
requireAuthId :: (HasHandlerData env, YesodAuth (HandlerSite env)) => RIO env (AuthId (HandlerSite env))
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
@ -566,9 +578,9 @@ requireAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
, MonadHandler m
, HandlerSite m ~ master
) => m (Entity val)
, HasHandlerData env
, HandlerSite env ~ master
) => RIO env (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
@ -578,18 +590,18 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return
requireAuthPair
:: ( YesodAuthPersist master
, Typeable (AuthEntity master)
, MonadHandler m
, HandlerSite m ~ master
, HasHandlerData env
, HandlerSite env ~ master
)
=> m (AuthId master, AuthEntity master)
=> RIO env (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
handleAuthLack :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env a
handleAuthLack = do
aj <- acceptsJson
if aj then notAuthenticated else redirectLogin
redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin :: (YesodAuth (HandlerSite env), HasHandlerData env) => RIO env a
redirectLogin = do
y <- getYesod
when (redirectToCurrent y) setUltDestCurrent

170
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -1,170 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
-- module is no longer recommended for use.
module Yesod.Auth.BrowserId
{-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
( authBrowserId
, createOnClick, createOnClickOverride
, def
, BrowserIdSettings
, bisAudience
, bisLazyLoad
, forwardUrl
) where
import Yesod.Auth
import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Control.Monad (when, unless)
import Text.Julius (rawJS)
import Network.URI (uriPath, parseURI)
import Data.FileEmbed (embedFile)
import Data.ByteString (ByteString)
import Data.Default
pid :: Text
pid = "browserid"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid []
complete :: AuthRoute
complete = forwardUrl
-- | A settings type for various configuration options relevant to BrowserID.
--
-- See: <http://www.yesodweb.com/book/settings-types>
--
-- Since 1.2.0
data BrowserIdSettings = BrowserIdSettings
{ bisAudience :: Maybe Text
-- ^ BrowserID audience value. If @Nothing@, will be extracted based on the
-- approot.
--
-- Default: @Nothing@
--
-- Since 1.2.0
, bisLazyLoad :: Bool
-- ^ Use asynchronous Javascript loading for the BrowserID JS file.
--
-- Default: @True@.
--
-- Since 1.2.0
}
instance Default BrowserIdSettings where
def = BrowserIdSettings
{ bisAudience = Nothing
, bisLazyLoad = True
}
authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
{ apName = pid
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
audience <-
case bisAudience of
Just a -> return a
Nothing -> do
r <- getUrlRender
tm <- getRouteToParent
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
manager <- authHttpManager
memail <- checkAssertion audience assertion manager
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent
loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
}
("GET", ["static", "sign-in.png"]) -> sendResponse
( "image/png" :: ByteString
, toContent $(embedFile "persona_sign_in_blue.png")
)
(_, []) -> badMethod
_ -> notFound
, apLogin = \toMaster -> do
onclick <- createOnClick bis toMaster
autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
when autologin $ toWidget [julius|#{rawJS onclick}();|]
toWidget [hamlet|
$newline never
<p>
<a href="javascript:#{onclick}()">
<img src=@{toMaster loginIcon}>
|]
}
where
loginIcon = PluginR pid ["static", "sign-in.png"]
stripScheme t = fromMaybe t $ T.stripPrefix "//" $ snd $ T.breakOn "//" t
-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClickOverride :: BrowserIdSettings
-> (Route Auth -> Route master)
-> Maybe (Route master)
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
unless bisLazyLoad $ addScriptRemote browserIdJs
onclick <- newIdent
render <- getUrlRender
let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
loginRoute = maybe (toMaster LoginR) id mOnRegistration
toWidget [julius|
function #{rawJS onclick}() {
if (navigator.id) {
navigator.id.watch({
onlogin: function (assertion) {
if (assertion) {
document.location = "@{toMaster complete}/" + assertion;
}
},
onlogout: function () {}
});
navigator.id.request({
returnTo: #{login} + "?autologin=true"
});
}
else {
alert("Loading, please try again");
}
}
|]
when bisLazyLoad $ toWidget [julius|
(function(){
var bid = document.createElement("script");
bid.async = true;
bid.src = #{toJSON browserIdJs};
var s = document.getElementsByTagName('script')[0];
s.parentNode.insertBefore(bid, s);
})();
|]
autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
when autologin $ toWidget [julius|#{rawJS onclick}();|]
return onclick
where
getPath t = fromMaybe t $ do
uri <- parseURI $ T.unpack t
return $ T.pack $ uriPath uri
-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClick :: BrowserIdSettings
-> (Route Auth -> Route master)
-> WidgetFor master Text
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

20
yesod-auth/Yesod/Auth/Email.hs
View File

@ -327,7 +327,7 @@ class ( YesodAuth site
-- used.
--
-- @since 1.6.4
emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
emailPreviouslyRegisteredResponse :: Text -> Maybe (AuthHandler site TypedContent)
emailPreviouslyRegisteredResponse _ = Nothing
-- | Additional normalization of email addresses, besides standard canonicalization.
@ -376,8 +376,8 @@ class ( YesodAuth site
-- Default: 'defaultSetPasswordHandler'.
--
-- @since: 1.2.6
setPasswordHandler ::
Bool
setPasswordHandler
:: Bool
-- ^ Whether the old password is needed. If @True@, a
-- field for the old password should be presented.
-- Otherwise, just two fields for the new password are
@ -571,12 +571,12 @@ registerHelper allowUsername forgotPassword dest = do
return $ Just (lid, False, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just creds@(_, False, _, _) -> sendConfirmationEmail creds
Just creds@(_, True, _, _) -> do
if forgotPassword then sendConfirmationEmail creds
Just creds'@(_, False, _, _) -> sendConfirmationEmail creds'
Just creds'@(_, True, _, _) -> do
if forgotPassword then sendConfirmationEmail creds'
else case emailPreviouslyRegisteredResponse identifier of
Just response -> response
Nothing -> sendConfirmationEmail creds
Nothing -> sendConfirmationEmail creds'
where sendConfirmationEmail (lid, _, verKey, email) = do
render <- getUrlRender
tp <- getRouteToParent
@ -928,9 +928,9 @@ loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK"
--
-- @since 1.2.1
--setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()
setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))
=> AuthId (HandlerSite m)
-> m ()
setLoginLinkKey :: (HasHandlerData env, YesodAuthEmail (HandlerSite env))
=> AuthId (HandlerSite env)
-> RIO env ()
setLoginLinkKey aid = do
now <- liftIO getCurrentTime
setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)

598
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -1,598 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Use an email address as an identifier via Google's login system.
--
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
-- on Google's now deprecated OpenID system. For more information, see
-- <https://developers.google.com/+/api/auth-migration>.
--
-- By using this plugin, you are trusting Google to validate an email address,
-- and requiring users to have a Google account. On the plus side, you get to
-- use email addresses as the identifier, many users have existing Google
-- accounts, the login system has been long tested (as opposed to BrowserID),
-- and it requires no credential managing or setup (as opposed to Email).
--
-- In order to use this plugin:
--
-- * Create an application on the Google Developer Console <https://console.developers.google.com/>
--
-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)
--
-- * Enable the Google+ API.
--
-- @since 1.3.1
module Yesod.Auth.GoogleEmail2
{-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-}
( -- * Authentication handlers
authGoogleEmail
, authGoogleEmailSaveToken
, forwardUrl
-- * User authentication token
, Token(..)
, getUserAccessToken
-- * Person
, getPerson
, Person(..)
, Name(..)
, Gender(..)
, PersonImage(..)
, resizePersonImage
, RelationshipStatus(..)
, PersonURI(..)
, PersonURIType(..)
, Organization(..)
, OrganizationType(..)
, Place(..)
, Email(..)
, EmailType(..)
-- * Other functions
, pid
) where
import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth,
runHttpRequest, setCredsRedirect,
logoutDest, AuthHandler)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, MonadHandler,
TypedContent, getRouteToParent,
getUrlRender, invalidArgs,
liftIO, lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:),
addMessage, getYesod,
toHtml, liftSubHandler)
import Blaze.ByteString.Builder (fromByteString, toByteString)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO)
import qualified Crypto.Nonce as Nonce
import Data.Aeson ((.:?))
import qualified Data.Aeson as A
#if MIN_VERSION_aeson(1,0,0)
import qualified Data.Aeson.Text as A
#else
import qualified Data.Aeson.Encode as A
#endif
import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText)
import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
import Network.HTTP.Client (Manager, requestHeaders,
responseBody, urlEncodedBody)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Conduit (Request, bodyReaderSource)
import Network.HTTP.Conduit (http)
import Network.HTTP.Types (renderQueryText)
import System.IO.Unsafe (unsafePerformIO)
-- | Plugin identifier. This is used to identify the plugin used for
-- authentication. The 'credsPlugin' will contain this value when this
-- plugin is used for authentication.
-- @since 1.4.17
pid :: Text
pid = "googleemail2"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
csrfKey :: Text
csrfKey = "_GOOGLE_CSRF_TOKEN"
getCsrfToken :: MonadHandler m => m (Maybe Text)
getCsrfToken = lookupSession csrfKey
accessTokenKey :: Text
accessTokenKey = "_GOOGLE_ACCESS_TOKEN"
-- | Get user's access token from the session. Returns Nothing if it's not found
-- (probably because the user is not logged in via 'Yesod.Auth.GoogleEmail2'
-- or you are not using 'authGoogleEmailSaveToken')
getUserAccessToken :: MonadHandler m => m (Maybe Token)
getUserAccessToken = fmap (\t -> Token t "Bearer") <$> lookupSession accessTokenKey
getCreateCsrfToken :: MonadHandler m => m Text
getCreateCsrfToken = do
mtoken <- getCsrfToken
case mtoken of
Just token -> return token
Nothing -> do
token <- Nonce.nonce128urlT defaultNonceGen
setSession csrfKey token
return token
authGoogleEmail :: YesodAuth m
=> Text -- ^ client ID
-> Text -- ^ client secret
-> AuthPlugin m
authGoogleEmail = authPlugin False
-- | An alternative version which stores user access token in the session
-- variable. Use it if you want to request user's profile from your app.
--
-- @since 1.4.3
authGoogleEmailSaveToken :: YesodAuth m
=> Text -- ^ client ID
-> Text -- ^ client secret
-> AuthPlugin m
authGoogleEmailSaveToken = authPlugin True
authPlugin :: YesodAuth m
=> Bool -- ^ if the token should be stored
-> Text -- ^ client ID
-> Text -- ^ client secret
-> AuthPlugin m
authPlugin storeToken clientID clientSecret =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
getDest :: MonadHandler m
=> (Route Auth -> Route (HandlerSite m))
-> m Text
getDest tm = do
csrf <- getCreateCsrfToken
render <- getUrlRender
let qs = map (second Just)
[ ("scope", "email profile")
, ("state", csrf)
, ("redirect_uri", render $ tm complete)
, ("response_type", "code")
, ("client_id", clientID)
, ("access_type", "offline")
]
return $ decodeUtf8
$ toByteString
$ fromByteString "https://accounts.google.com/o/oauth2/auth"
`Data.Monoid.mappend` renderQueryText True qs
login tm = do
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch :: YesodAuth site
=> Text
-> [Text]
-> AuthHandler site TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
getDest tm >>= redirect
dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state"
case mstate of
Nothing -> invalidArgs ["CSRF state from Google is missing"]
Just state -> do
mtoken <- getCsrfToken
unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
mcode <- lookupGetParam "code"
code <-
case mcode of
Nothing -> do
merr <- lookupGetParam "error"
case merr of
Nothing -> invalidArgs ["Missing code paramter"]
Just err -> do
master <- getYesod
let msg =
case err of
"access_denied" -> "Access denied"
_ -> "Unknown error occurred: " `T.append` err
addMessage "error" $ toHtml msg
redirect $ logoutDest master
Just c -> return c
render <- getUrlRender
tm <- getRouteToParent
req' <- liftIO $
HTTP.parseUrlThrow
"https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req =
urlEncodedBody
[ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render $ tm complete)
, ("grant_type", "authorization_code")
]
req'
{ requestHeaders = []
}
value <- makeHttpRequest req
token@(Token accessToken' tokenType') <-
case parseEither parseJSON value of
Left e -> error e
Right t -> return t
unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
-- User's access token is saved for further access to API
when storeToken $ setSession accessTokenKey accessToken'
personValue <- makeHttpRequest =<< personValueRequest token
person <- case parseEither parseJSON personValue of
Left e -> error e
Right x -> return x
email <-
case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
[e] -> return e
[] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x
setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound
makeHttpRequest :: Request -> AuthHandler site A.Value
makeHttpRequest req =
liftSubHandler $ runHttpRequest req $ \res ->
runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'
-- | Allows to fetch information about a user from Google's API.
-- In case of parsing error returns 'Nothing'.
-- Will throw 'HttpException' in case of network problems or error response code.
--
-- @since 1.4.3
getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
req <- personValueRequest token
res <- http req manager
runConduit $ responseBody res .| sinkParser json'
)
personValueRequest :: MonadIO m => Token -> m Request
personValueRequest token = do
req2' <- liftIO
$ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
return req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
]
}
--------------------------------------------------------------------------------
-- | An authentication token which was acquired from OAuth callback.
-- The token gets saved into the session storage only if you use
-- 'authGoogleEmailSaveToken'.
-- You can acquire saved token with 'getUserAccessToken'.
--
-- @since 1.4.3
data Token = Token { accessToken :: Text
, tokenType :: Text
} deriving (Show, Eq)
instance FromJSON Token where
parseJSON = withObject "Tokens" $ \o -> Token
Control.Applicative.<$> o .: "access_token"
Control.Applicative.<*> o .: "token_type"
--------------------------------------------------------------------------------
-- | Gender of the person
--
-- @since 1.4.3
data Gender = Male | Female | OtherGender deriving (Show, Eq)
instance FromJSON Gender where
parseJSON = withText "Gender" $ \t -> return $ case t of
"male" -> Male
"female" -> Female
_ -> OtherGender
--------------------------------------------------------------------------------
-- | URIs specified in the person's profile
--
-- @since 1.4.3
data PersonURI =
PersonURI { uriLabel :: Maybe Text
, uriValue :: Maybe Text
, uriType :: Maybe PersonURIType
} deriving (Show, Eq)
instance FromJSON PersonURI where
parseJSON = withObject "PersonURI" $ \o -> PersonURI <$> o .:? "label"
<*> o .:? "value"
<*> o .:? "type"
--------------------------------------------------------------------------------
-- | The type of URI
--
-- @since 1.4.3
data PersonURIType = OtherProfile -- ^ URI for another profile
| Contributor -- ^ URI to a site for which this person is a contributor
| Website -- ^ URI for this Google+ Page's primary website
| OtherURI -- ^ Other URL
| PersonURIType Text -- ^ Something else
deriving (Show, Eq)
instance FromJSON PersonURIType where
parseJSON = withText "PersonURIType" $ \t -> return $ case t of
"otherProfile" -> OtherProfile
"contributor" -> Contributor
"website" -> Website
"other" -> OtherURI
_ -> PersonURIType t
--------------------------------------------------------------------------------
-- | Current or past organizations with which this person is associated
--
-- @since 1.4.3
data Organization =
Organization { orgName :: Maybe Text
-- ^ The person's job title or role within the organization
, orgTitle :: Maybe Text
, orgType :: Maybe OrganizationType
-- ^ The date that the person joined this organization.
, orgStartDate :: Maybe Text
-- ^ The date that the person left this organization.
, orgEndDate :: Maybe Text
-- ^ If @True@, indicates this organization is the person's
-- ^ primary one, which is typically interpreted as the current one.
, orgPrimary :: Maybe Bool
} deriving (Show, Eq)
instance FromJSON Organization where
parseJSON = withObject "Organization" $ \o ->
Organization <$> o .:? "name"
<*> o .:? "title"
<*> o .:? "type"
<*> o .:? "startDate"
<*> o .:? "endDate"
<*> o .:? "primary"
--------------------------------------------------------------------------------
-- | The type of an organization
--
-- @since 1.4.3
data OrganizationType = Work
| School
| OrganizationType Text -- ^ Something else
deriving (Show, Eq)
instance FromJSON OrganizationType where
parseJSON = withText "OrganizationType" $ \t -> return $ case t of
"work" -> Work
"school" -> School
_ -> OrganizationType t
--------------------------------------------------------------------------------
-- | A place where the person has lived or is living at the moment.
--
-- @since 1.4.3
data Place =
Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto".
placeValue :: Maybe Text
-- | If @True@, this place of residence is this person's primary residence.
, placePrimary :: Maybe Bool
} deriving (Show, Eq)
instance FromJSON Place where
parseJSON = withObject "Place" $ \o -> Place <$> (o .:? "value") <*> (o .:? "primary")
--------------------------------------------------------------------------------
-- | Individual components of a name
--
-- @since 1.4.3
data Name =
Name { -- | The full name of this person, including middle names, suffixes, etc
nameFormatted :: Maybe Text
-- | The family name (last name) of this person
, nameFamily :: Maybe Text
-- | The given name (first name) of this person
, nameGiven :: Maybe Text
-- | The middle name of this person.
, nameMiddle :: Maybe Text
-- | The honorific prefixes (such as "Dr." or "Mrs.") for this person
, nameHonorificPrefix :: Maybe Text
-- | The honorific suffixes (such as "Jr.") for this person
, nameHonorificSuffix :: Maybe Text
} deriving (Show, Eq)
instance FromJSON Name where
parseJSON = withObject "Name" $ \o -> Name <$> o .:? "formatted"
<*> o .:? "familyName"
<*> o .:? "givenName"
<*> o .:? "middleName"
<*> o .:? "honorificPrefix"
<*> o .:? "honorificSuffix"
--------------------------------------------------------------------------------
-- | The person's relationship status.
--
-- @since 1.4.3
data RelationshipStatus = Single -- ^ Person is single
| InRelationship -- ^ Person is in a relationship
| Engaged -- ^ Person is engaged
| Married -- ^ Person is married
| Complicated -- ^ The relationship is complicated
| OpenRelationship -- ^ Person is in an open relationship
| Widowed -- ^ Person is widowed
| DomesticPartnership -- ^ Person is in a domestic partnership
| CivilUnion -- ^ Person is in a civil union
| RelationshipStatus Text -- ^ Something else
deriving (Show, Eq)
instance FromJSON RelationshipStatus where
parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
"single" -> Single
"in_a_relationship" -> InRelationship
"engaged" -> Engaged
"married" -> Married
"its_complicated" -> Complicated
"open_relationship" -> OpenRelationship
"widowed" -> Widowed
"in_domestic_partnership" -> DomesticPartnership
"in_civil_union" -> CivilUnion
_ -> RelationshipStatus t
--------------------------------------------------------------------------------
-- | The URI of the person's profile photo.
--
-- @since 1.4.3
newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)
instance FromJSON PersonImage where
parseJSON = withObject "PersonImage" $ \o -> PersonImage <$> o .: "url"
-- | @resizePersonImage img 30@ would set query part to @?sz=30@ which would resize
-- the image under the URI. If for some reason you need to modify the query
-- part, you should do it after resizing.
--
-- @since 1.4.3
resizePersonImage :: PersonImage -> Int -> PersonImage
resizePersonImage (PersonImage uri) size =
PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)
--------------------------------------------------------------------------------
-- | Information about the user
-- Full description of the resource https://developers.google.com/+/api/latest/people
--
-- @since 1.4.3
data Person = Person
{ personId :: Text
-- | The name of this person, which is suitable for display
, personDisplayName :: Maybe Text
, personName :: Maybe Name
, personNickname :: Maybe Text
, personBirthday :: Maybe Text -- ^ Birthday formatted as YYYY-MM-DD
, personGender :: Maybe Gender
, personProfileUri :: Maybe Text -- ^ The URI of this person's profile
, personImage :: Maybe PersonImage
, personAboutMe :: Maybe Text -- ^ A short biography for this person
, personRelationshipStatus :: Maybe RelationshipStatus
, personUris :: [PersonURI]
, personOrganizations :: [Organization]
, personPlacesLived :: [Place]
-- | The brief description of this person
, personTagline :: Maybe Text
-- | Whether this user has signed up for Google+
, personIsPlusUser :: Maybe Bool
-- | The "bragging rights" line of this person
, personBraggingRights :: Maybe Text
-- | if a Google+ page, the number of people who have +1'd this page
, personPlusOneCount :: Maybe Int
-- | For followers who are visible, the number of people who have added
-- this person or page to a circle.
, personCircledByCount :: Maybe Int
-- | Whether the person or Google+ Page has been verified. This is used only
-- for pages with a higher risk of being impersonated or similar. This
-- flag will not be present on most profiles.
, personVerified :: Maybe Bool
-- | The user's preferred language for rendering.
, personLanguage :: Maybe Text
, personEmails :: [Email]
, personDomain :: Maybe Text
, personOccupation :: Maybe Text -- ^ The occupation of this person
, personSkills :: Maybe Text -- ^ The person's skills
} deriving (Show, Eq)
instance FromJSON Person where
parseJSON = withObject "Person" $ \o ->
Person <$> o .: "id"
<*> o .: "displayName"
<*> o .:? "name"
<*> o .:? "nickname"
<*> o .:? "birthday"
<*> o .:? "gender"
<*> (o .:? "url")
<*> o .:? "image"
<*> o .:? "aboutMe"
<*> o .:? "relationshipStatus"
<*> ((fromMaybe []) <$> (o .:? "urls"))
<*> ((fromMaybe []) <$> (o .:? "organizations"))
<*> ((fromMaybe []) <$> (o .:? "placesLived"))
<*> o .:? "tagline"
<*> o .:? "isPlusUser"
<*> o .:? "braggingRights"
<*> o .:? "plusOneCount"
<*> o .:? "circledByCount"
<*> o .:? "verified"
<*> o .:? "language"
<*> ((fromMaybe []) <$> (o .:? "emails"))
<*> o .:? "domain"
<*> o .:? "occupation"
<*> o .:? "skills"
--------------------------------------------------------------------------------
-- | Person's email
--
-- @since 1.4.3
data Email = Email
{ emailValue :: Text
, emailType :: EmailType
}
deriving (Show, Eq)
instance FromJSON Email where
parseJSON = withObject "Email" $ \o -> Email
<$> o .: "value"
<*> o .: "type"
--------------------------------------------------------------------------------
-- | Type of email
--
-- @since 1.4.3
data EmailType = EmailAccount -- ^ Google account email address
| EmailHome -- ^ Home email address
| EmailWork -- ^ Work email adress
| EmailOther -- ^ Other email address
| EmailType Text -- ^ Something else
deriving (Show, Eq)
instance FromJSON EmailType where
parseJSON = withText "EmailType" $ \t -> return $ case t of
"account" -> EmailAccount
"home" -> EmailHome
"work" -> EmailWork
"other" -> EmailOther
_ -> EmailType t
allPersonInfo :: A.Value -> [(Text, Text)]
allPersonInfo (A.Object o) = map enc $ M.toList o
where enc (key, A.String s) = (key, s)
enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
allPersonInfo _ = []
-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this
-- use of unsafePerformIO.
defaultNonceGen :: Nonce.Generator
defaultNonceGen = unsafePerformIO (Nonce.new)
{-# NOINLINE defaultNonceGen #-}

25
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Auth.OpenId
( authOpenId
, forwardUrl
@ -29,7 +30,7 @@ forwardUrl = PluginR "openid" ["forward"]
data IdentifierType = Claimed | OPLocal
authOpenId :: YesodAuth master
authOpenId :: forall master. YesodAuth master
=> IdentifierType
-> [(Text, Text)] -- ^ extension fields
-> AuthPlugin master
@ -41,16 +42,15 @@ authOpenId idType extensionFields =
name :: Text
name = "openid_identifier"
login
:: (AuthRoute -> Route master)
-> WidgetFor master ()
login tm = do
ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the
-- code, but it shouldn't be necessary
let y :: a -> [(Text, Text)] -> Text
y = undefined
toWidget (\x -> [cassius|##{ident}
toWidget [cassius|##{ident}
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
padding-left: 18px;
|] $ x `asTypeOf` y)
|]
[whamlet|
$newline never
<form method="get" action="@{tm forwardUrl}">
@ -62,7 +62,10 @@ $newline never
<input type="submit" value="_{Msg.LoginOpenID}">
|]
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
dispatch
:: Text
-> [Text]
-> SubHandlerFor Auth master TypedContent
dispatch "GET" ["forward"] = do
roid <- runInputGet $ iopt textField name
case roid of
@ -86,7 +89,11 @@ $newline never
completeHelper idType posts
dispatch _ _ = notFound
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper
:: (HasHandlerData env, SubHandlerSite env ~ Auth, YesodAuth (HandlerSite env))
=> IdentifierType
-> [(Text, Text)]
-> RIO env TypedContent
completeHelper idType gets' = do
manager <- authHttpManager
eres <- tryAny $ OpenId.authenticateClaimed gets' manager

3
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Auth.Rpxnow
( authRpxnow
) where
@ -18,7 +19,7 @@ import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery)
authRpxnow :: YesodAuth master
authRpxnow :: forall master. YesodAuth master
=> String -- ^ app name
-> String -- ^ key
-> AuthPlugin master

3
yesod-auth/yesod-auth.cabal
View File

@ -45,6 +45,7 @@ library
, nonce >= 1.0.2 && < 1.1
, persistent >= 2.8 && < 2.10
, random >= 1.0.0.2
, rio
, safe
, shakespeare
, template-haskell
@ -63,13 +64,11 @@ library
build-depends: network-uri >= 2.6
exposed-modules: Yesod.Auth
Yesod.Auth.BrowserId
Yesod.Auth.Dummy
Yesod.Auth.Email
Yesod.Auth.OpenId
Yesod.Auth.Rpxnow
Yesod.Auth.Message
Yesod.Auth.GoogleEmail2
Yesod.Auth.Hardcoded
Yesod.Auth.Util.PasswordStore
other-modules: Yesod.Auth.Routes

2
yesod-test/Yesod/Test.hs
View File

@ -1080,7 +1080,7 @@ setUrl url' = do
site <- fmap rbdSite getSIO
eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
mempty
site
(toTextUrl url')
url <- either (error . show) return eurl