WIP

yesod-auth/Yesod/Auth.hs

@@ -47,9 +47,10 @@ module Yesod.Auth
     , asHtml
     ) where
 
-import           Control.Applicative ((<$>))
 import Control.Monad                 (when)
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader    (ReaderT)
+import Control.Monad.IO.Unlift       (withRunInIO)
 
 import Yesod.Auth.Routes
 import Data.Aeson hiding (json)
@@ -60,11 +61,11 @@ import qualified Data.Text as T
 import qualified Data.HashMap.Lazy as Map
 import Data.Monoid (Endo)
 import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
+import Network.HTTP.Client.TLS (getGlobalManager)
 
 import qualified Network.Wai as W
 
 import Yesod.Core
-import Yesod.Core.Types (HandlerFor(..))
 import Yesod.Persist
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 import qualified Yesod.Auth.Message as Msg
@@ -110,8 +111,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     type AuthId master
 
     -- | specify the layout. Uses defaultLayout by default
-    authLayout :: WidgetFor master () -> HandlerFor master Html
-    authLayout = defaultLayout
+    authLayout :: WidgetFor master () -> AuthHandler master Html
+    authLayout = liftHandler . defaultLayout
 
     -- | Default destination on successful login, if no other
     -- destination exists.
@@ -126,7 +127,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- Default implementation is in terms of @'getAuthId'@
     --
     -- Since: 1.4.4
-    authenticate :: Creds master -> HandlerFor master (AuthenticationResult master)
+    authenticate :: Creds master -> AuthHandler master (AuthenticationResult master)
     authenticate creds = do
         muid <- getAuthId creds
 
@@ -136,7 +137,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     --
     -- Default implementation is in terms of @'authenticate'@
     --
-    getAuthId :: Creds master -> HandlerFor master (Maybe (AuthId master))
+    getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master))
     getAuthId creds = do
         auth <- authenticate creds
 
@@ -191,15 +192,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 :: master -> Manager
+    authHttpManager :: master -> IO Manager
+    authHttpManager _ = getGlobalManager
 
     -- | Called on a successful login. By default, calls
     -- @addMessageI "success" NowLoggedIn@.
-    onLogin :: HandlerFor master ()
+    onLogin :: AuthHandler master ()
     onLogin = addMessageI "success" Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
-    onLogout :: HandlerFor master ()
+    onLogout :: AuthHandler master ()
     onLogout = return ()
 
     -- | Retrieves user credentials, if user is authenticated.
@@ -211,16 +213,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- other than a browser.
     --
     -- Since 1.2.0
-    maybeAuthId :: HandlerFor master (Maybe (AuthId master))
+    maybeAuthId :: AuthHandler master (Maybe (AuthId master))
 
     default maybeAuthId
         :: (YesodAuthPersist master, Typeable (AuthEntity master))
-        => HandlerFor master (Maybe (AuthId master))
+        => AuthHandler master (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 :: Route master -> Text -> HandlerFor master Html
+    onErrorHtml :: Route master -> Text -> AuthHandler master Html
     onErrorHtml dest msg = do
         addMessage "error" $ toHtml msg
         fmap asHtml $ redirect dest
@@ -230,10 +232,13 @@ 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 :: Request -> (Response BodyReader -> HandlerFor master a) -> HandlerFor master a
+    runHttpRequest :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth)
+                   => Request
+                   -> (Response BodyReader -> ReaderT (SubsiteData Auth master) (HandlerFor master) a)
+                   -> m a
     runHttpRequest req inner = do
-      man <- authHttpManager Control.Applicative.<$> getYesod
-      HandlerFor $ \t -> withResponse req man $ \res -> unHandlerFor (inner res) t
+      man <- getYesod >>= liftIO . authHttpManager
+      lift $ withRunInIO $ \run -> withResponse req man $ run . inner
 
     {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
 
@@ -254,7 +259,7 @@ credsKey = "_ID"
 -- Since 1.1.2
 defaultMaybeAuthId
     :: (YesodAuthPersist master, Typeable (AuthEntity master))
-    => HandlerFor master (Maybe (AuthId master))
+    => AuthHandler master (Maybe (AuthId master))
 defaultMaybeAuthId = runMaybeT $ do
     s   <- MaybeT $ lookupSession credsKey
     aid <- MaybeT $ return $ fromPathPiece s
@@ -263,7 +268,7 @@ defaultMaybeAuthId = runMaybeT $ do
 
 cachedAuth
     :: (YesodAuthPersist master, Typeable (AuthEntity master))
-    => AuthId master -> HandlerFor master (Maybe (AuthEntity master))
+    => AuthId master -> AuthHandler master (Maybe (AuthEntity master))
 cachedAuth
     = fmap unCachedMaybeAuth
     . cached
@@ -298,7 +303,7 @@ loginErrorMessageI dest msg = do
 loginErrorMessageMasterI :: (YesodAuth master, RenderMessage master AuthMessage)
          => Route master
          -> AuthMessage
-         -> HandlerFor master TypedContent
+         -> AuthHandler master TypedContent
 loginErrorMessageMasterI dest msg = do
   mr <- getMessageRender
   loginErrorMessage dest (mr msg)
@@ -308,10 +313,13 @@ loginErrorMessageMasterI dest msg = do
 loginErrorMessage :: YesodAuth master
          => Route master
          -> Text
-         -> HandlerFor master TypedContent
+         -> AuthHandler master TypedContent
 loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
 
-messageJson401 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent
+messageJson401 :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth)
+               => Text
+               -> m Html
+               -> m TypedContent
 messageJson401 = messageJsonStatus unauthorized401
 
 messageJson500 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent
@@ -577,8 +585,8 @@ data AuthException = InvalidFacebookResponse
     deriving (Show, Typeable)
 instance Exception AuthException
 
--- FIXME this is ugly, and I probably want to ditch the MonadSubHandler typeclass anyway
-instance (YesodAuth (HandlerSite m), MonadSubHandler m) => YesodSubDispatch Auth m where
+-- FIXME HandlerSite m ~ SubHandlerSite m should be unnecessary
+instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m) => YesodSubDispatch Auth m where
     yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
 
 asHtml :: Html -> Html

yesod-auth/Yesod/Auth/Dummy.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 -- | Provides a dummy authentication module that simply lets a user specify
 -- his/her identifier. This is not intended for real world use, just for
 -- testing.
@@ -15,9 +16,9 @@ authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
-    dispatch "POST" [] = do
-        ident <- lift $ runInputPost $ ireq textField "ident"
-        lift $ setCredsRedirect $ Creds "dummy" ident []
+    dispatch "POST" [] = liftHandler $ do
+        ident <- runInputPost $ ireq textField "ident"
+        setCredsRedirect $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster = do

yesod-auth/Yesod/Auth/Email.hs

@@ -325,7 +325,7 @@ class ( YesodAuth site
     -- Default: 'defaultRegisterHandler'.
     --
     -- @since: 1.2.6
-    registerHandler :: HandlerT Auth (HandlerT site IO) Html
+    registerHandler :: AuthHandler site Html
     registerHandler = defaultRegisterHandler
 
     -- | Handler called to render the \"forgot password\" page.
@@ -335,7 +335,7 @@ class ( YesodAuth site
     -- Default: 'defaultForgotPasswordHandler'.
     --
     -- @since: 1.2.6
-    forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html
+    forgotPasswordHandler :: AuthHandler site Html
     forgotPasswordHandler = defaultForgotPasswordHandler
 
     -- | Handler called to render the \"set password\" page.  The
@@ -351,7 +351,7 @@ class ( YesodAuth site
          -- field for the old password should be presented.
          -- Otherwise, just two fields for the new password are
          -- needed.
-      -> HandlerT Auth (HandlerT site IO) TypedContent
+      -> AuthHandler site TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
 authEmail :: (YesodAuthEmail m) => AuthPlugin m
@@ -371,7 +371,7 @@ authEmail =
     dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
     dispatch _ _ = notFound
 
-getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getRegisterR :: YesodAuthEmail master => AuthHandler master Html
 getRegisterR = registerHandler
 
 -- | Default implementation of 'emailLoginHandler'.
@@ -437,7 +437,7 @@ defaultEmailLoginHandler toParent = do
 -- | Default implementation of 'registerHandler'.
 --
 -- @since 1.2.6
-defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
 defaultRegisterHandler = do
     (widget, enctype) <- lift $ generateFormPost registrationForm
     toParentRoute <- getRouteToParent
@@ -480,7 +480,7 @@ parseEmail = withObject "email" (\obj -> do
 registerHelper :: YesodAuthEmail master
                => Bool -- ^ allow usernames?
                -> Route Auth
-               -> HandlerT Auth (HandlerT master IO) TypedContent
+               -> AuthHandler master TypedContent
 registerHelper allowUsername dest = do
     y <- lift getYesod
     checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
@@ -525,16 +525,16 @@ registerHelper allowUsername dest = do
                     lift $ sendVerifyEmail email verKey verUrl
                     lift $ confirmationEmailSentResponse identifier
 
-postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
 postRegisterR = registerHelper False registerR
 
-getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
 getForgotPasswordR = forgotPasswordHandler
 
 -- | Default implementation of 'forgotPasswordHandler'.
 --
 -- @since 1.2.6
-defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
 defaultForgotPasswordHandler = do
     (widget, enctype) <- lift $ generateFormPost forgotPasswordForm
     toParent <- getRouteToParent
@@ -569,13 +569,13 @@ defaultForgotPasswordHandler = do
             fsAttrs = [("autofocus", "")]
         }
 
-postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
 postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
            -> Text
-           -> HandlerT Auth (HandlerT site IO) TypedContent
+           -> AuthHandler site TypedContent
 getVerifyR lid key = do
     realKey <- lift $ getVerifyKey lid
     memail <- lift $ getEmail lid
@@ -612,7 +612,7 @@ parseCreds = withObject "creds" (\obj -> do
                                    return (email', pass))
 
 
-postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
 postLoginR = do
     result <- lift $ runInputPostResult $ (,)
         <$> ireq textField "email"
@@ -658,7 +658,7 @@ postLoginR = do
                                    then Msg.InvalidEmailPass
                                    else Msg.InvalidUsernamePass
 
-getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
 getPasswordR = do
     maid <- lift maybeAuthId
     case maid of
@@ -670,7 +670,7 @@ getPasswordR = do
 -- | Default implementation of 'setPasswordHandler'.
 --
 -- @since 1.2.6
-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
 defaultSetPasswordHandler needOld = do
     messageRender <- lift getMessageRender
     toParent <- getRouteToParent
@@ -749,7 +749,7 @@ parsePassword = withObject "password" (\obj -> do
                                          curr <- obj .:? "current"
                                          return (email', pass, curr))
 
-postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
+postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
 postPasswordR = do
     maid <- lift maybeAuthId
     (creds :: Result Value) <- lift parseCheckJsonBody
@@ -773,14 +773,14 @@ postPasswordR = do
                 mrealpass <- lift $ getPassword aid
                 case (mrealpass, current) of
                     (Nothing, _) ->
-                        lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
+                        liftHandler $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
                     (_, Nothing) ->
                         loginErrorMessageI LoginR Msg.BadSetPass
                     (Just realpass, Just current') -> do
-                        passValid <- lift $ verifyPassword current' realpass
+                        passValid <- liftHandler $ verifyPassword current' realpass
                         if passValid
                           then confirmPassword aid tm jcreds
-                          else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+                          else liftHandler $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
   where
     msgOk = Msg.PassUpdated

yesod-auth/yesod-auth.cabal

@@ -41,6 +41,7 @@ library
                    , persistent              >= 2.1       && < 2.8
                    , persistent-template     >= 2.1       && < 2.8
                    , http-client
+                   , http-client-tls
                    , http-conduit            >= 2.1
                    , aeson                   >= 0.7
                    , lifted-base             >= 0.1
@@ -61,6 +62,7 @@ library
                    , conduit
                    , conduit-extra
                    , nonce                   >= 1.0.2     && < 1.1
+                   , unliftio-core
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6

yesod-core/Yesod/Core.hs

@@ -76,6 +76,7 @@ module Yesod.Core
     , getApprootText
       -- * Subsites
     , MonadSubHandler (..)
+    , SubsiteData
       -- * Misc
     , yesodVersion
     , yesodRender