It all compiles

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           RIO
-import           Control.Monad.IO.Class
-import           UnliftIO                 (MonadUnliftIO)
-import           Data.ByteString          (ByteString)
-import           Data.Maybe
-import           Data.Text                (Text)
 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
+      :: Text
-         , master ~ HandlerSite m
-         , Auth ~ SubHandlerSite m
-         , MonadUnliftIO m
-         )
-      => 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"
+                runInputGet $ (,) <$> ireq textField "oauth_verifier"
-                                  A.<*> ireq textField "oauth_token"
+                                  <*> ireq textField "oauth_token"
             return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
                                 , ("oauth_token", encodeUtf8 oaTok)
                                 , ("oauth_token_secret", encodeUtf8 tokSec)

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

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 AuthRoute = Route Auth
-type AuthHandler master a = forall m. MonadAuthHandler master m => m a
 
 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))
+        :: (HasHandlerData env, master ~ HandlerSite env, YesodAuthPersist master, Typeable (AuthEntity master))
-        => m (Maybe (AuthId 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)
+      -> (Response BodyReader -> RIO env a)
-      -> m 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))
+    :: (HasHandlerData env, HandlerSite env ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
-    => m (Maybe (AuthId 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))
+         :: (HasHandlerData env, YesodAuth (HandlerSite env))
-         => Route (HandlerSite m)
+         => 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
+  -> RIO env Html
-  -> m TypedContent
+  -> 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
+  -> RIO env Html
-  -> m TypedContent
+  -> 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))
+  :: (HasHandlerData env, YesodAuth (HandlerSite env))
-  => Creds (HandlerSite m) -- ^ new credentials
+  => Creds (HandlerSite env) -- ^ new credentials
-  -> m TypedContent
+  -> 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
+         -> Creds (HandlerSite env) -- ^ new credentials
-         -> m ()
+         -> 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)
+  :: (ToJSON j, HasHandlerData env, YesodAuth (HandlerSite env))
-  => WidgetFor master ()  -- ^ HTML
+  => WidgetFor (HandlerSite env) ()  -- ^ HTML
-  -> m j  -- ^ JSON
+  -> RIO env j  -- ^ JSON
-  -> m TypedContent
+  -> 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
+             , HasHandlerData env
-             , HandlerSite m ~ master
+             , HandlerSite env ~ master
-             ) => m (Maybe (Entity val))
+             ) => 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
+     , HasHandlerData env
-     , HandlerSite m ~ master
+     , 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)
+    getAuthEntity
-                  => AuthId master -> m (Maybe (AuthEntity master))
+      :: (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
+           , HasHandlerData env
-           , HandlerSite m ~ master
+           , 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
+               , HasHandlerData env
-               , HandlerSite m ~ master
+               , HandlerSite env ~ master
-               ) => m (Entity val)
+               ) => 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
+     , HasHandlerData env
-     , HandlerSite m ~ master
+     , 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

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -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

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 ::
+    setPasswordHandler
-         Bool
+      :: 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'@(_, False, _, _) -> sendConfirmationEmail creds'
-                Just creds@(_, True, _, _) -> do
+                Just creds'@(_, True, _, _) -> do
-                  if forgotPassword then sendConfirmationEmail creds
+                  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))
+setLoginLinkKey :: (HasHandlerData env, YesodAuthEmail (HandlerSite env))
-                => AuthId (HandlerSite m)
+                => AuthId (HandlerSite env)
-                -> m ()
+                -> RIO env ()
 setLoginLinkKey aid = do
     now <- liftIO getCurrentTime
     setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -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 #-}

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
+        toWidget [cassius|##{ident}
-        -- code, but it shouldn't be necessary
-        let y :: a -> [(Text, Text)] -> Text
-            y = undefined
-        toWidget (\x -> [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

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

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

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