From eccbe4acbee1972c8ee2e727ad34969c3789448e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 12 Mar 2019 13:14:27 +0200 Subject: [PATCH] It all compiles --- yesod-auth-oauth/Yesod/Auth/OAuth.hs | 22 +- yesod-auth-oauth/yesod-auth-oauth.cabal | 2 +- yesod-auth/Yesod/Auth.hs | 178 +++---- yesod-auth/Yesod/Auth/BrowserId.hs | 170 ------- yesod-auth/Yesod/Auth/Email.hs | 20 +- yesod-auth/Yesod/Auth/GoogleEmail2.hs | 598 ------------------------ yesod-auth/Yesod/Auth/OpenId.hs | 25 +- yesod-auth/Yesod/Auth/Rpxnow.hs | 3 +- yesod-auth/yesod-auth.cabal | 3 +- yesod-test/Yesod/Test.hs | 2 +- 10 files changed, 132 insertions(+), 891 deletions(-) delete mode 100644 yesod-auth/Yesod/Auth/BrowserId.hs delete mode 100644 yesod-auth/Yesod/Auth/GoogleEmail2.hs diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index a8d1d63a..8b0c6825 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -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) diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 713e43be..f2c60403 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -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 diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 60169f6e..7d86db9b 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -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 diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs deleted file mode 100644 index c7e08421..00000000 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ /dev/null @@ -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: --- --- 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 -

- - -|] - } - 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 diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 77a360fa..390538fd 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -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) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs deleted file mode 100644 index ce734a40..00000000 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ /dev/null @@ -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 --- . --- --- 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 --- --- * Create OAuth credentials. The redirect URI will be . (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|_{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 #-} diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index ceaa312c..f3970a9b 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -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

@@ -62,7 +62,10 @@ $newline never |] - 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 diff --git a/yesod-auth/Yesod/Auth/Rpxnow.hs b/yesod-auth/Yesod/Auth/Rpxnow.hs index b7a96a7c..e0ce6280 100644 --- a/yesod-auth/Yesod/Auth/Rpxnow.hs +++ b/yesod-auth/Yesod/Auth/Rpxnow.hs @@ -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 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 7af07c14..4173f759 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -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 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 91d88866..932b913d 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -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