Merge remote-tracking branch 'origin/master' into rio

.travis.yml

@@ -35,12 +35,6 @@ matrix:
   include:
   # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
   # https://github.com/hvr/multi-ghc-travis
-  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.0.2"
-    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
-  - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 8.2.2"
-    addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
   - env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7
     compiler: ": #GHC 8.4.4"
     addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
@@ -60,14 +54,6 @@ matrix:
     compiler: ": #stack default"
     addons: {apt: {packages: [libgmp-dev]}}
 
-  - env: BUILD=stack ARGS="--stack-yaml stack-lts-9.yaml --resolver lts-9"
-    compiler: ": #stack 8.0.2"
-    addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: BUILD=stack ARGS="--resolver lts-11"
-    compiler: ": #stack 8.2.2"
-    addons: {apt: {packages: [libgmp-dev]}}
-
   - env: BUILD=stack ARGS="--resolver lts-12"
     compiler: ": #stack 8.4.4"
     addons: {apt: {packages: [libgmp-dev]}}
@@ -76,10 +62,6 @@ matrix:
     compiler: ": #stack 8.6.3"
     addons: {apt: {packages: [libgmp-dev]}}
 
-  - env: BUILD=stack ARGS="--stack-yaml stack-persistent-2-9.yaml"
-    compiler: ": #stack/persistent 2.9"
-    addons: {apt: {packages: [libgmp-dev]}}
-
   # Nightly builds are allowed to fail
   - env: BUILD=stack ARGS="--resolver nightly"
     compiler: ": #stack nightly"
@@ -90,14 +72,6 @@ matrix:
     compiler: ": #stack default osx"
     os: osx
 
-  - env: BUILD=stack ARGS="--stack-yaml stack-lts-9.yaml --resolver lts-9"
-    compiler: ": #stack 8.0.2 osx"
-    os: osx
-
-  - env: BUILD=stack ARGS="--resolver lts-11"
-    compiler: ": #stack 8.2.2 osx"
-    os: osx
-
   - env: BUILD=stack ARGS="--resolver lts-12"
     compiler: ": #stack 8.4.4 osx"
     os: osx
@@ -106,10 +80,6 @@ matrix:
     compiler: ": #stack 8.6.3 osx"
     os: osx
 
-  - env: BUILD=stack ARGS="--stack-yaml stack-persistent-2-9.yaml"
-    compiler: ": #stack/persistent 2.9"
-    os: osx
-
   - env: BUILD=stack ARGS="--resolver nightly"
     compiler: ": #stack nightly osx"
     os: osx

appveyor.yml

@@ -9,7 +9,7 @@ install:
 build: off
 
 build_script:
-  - stack --no-terminal test --no-run-tests --resolver lts-11
+  - stack --no-terminal test --no-run-tests
 
 test_script:
-  - stack --jobs 1 --no-terminal test --resolver lts-11
+  - stack --jobs 1 --no-terminal test

sources.txt

@@ -1,13 +0,0 @@
-./yesod-core
-./yesod-static
-./yesod-persistent
-./yesod-newsfeed
-./yesod-form
-./yesod-auth
-./yesod-auth-oauth
-./yesod-sitemap
-./yesod-test
-./yesod-bin
-./yesod
-./yesod-eventsource
-./yesod-websockets

stack-lts-9.yaml

@@ -1,37 +0,0 @@
-resolver: lts-9.21
-packages:
-- ./yesod-core
-- ./yesod-static
-- ./yesod-persistent
-- ./yesod-newsfeed
-- ./yesod-form
-- ./yesod-auth
-- ./yesod-auth-oauth
-- ./yesod-sitemap
-- ./yesod-test
-- ./yesod-bin
-- ./yesod
-- ./yesod-eventsource
-- ./yesod-websockets
-extra-deps:
-- bsb-http-chunked-0.0.0.2@rev:0
-- conduit-1.3.0.2@rev:0
-- conduit-extra-1.3.0@rev:0
-- html-conduit-1.3.0@rev:0
-- http-client-0.5.12.1@rev:0
-- http-conduit-2.3.1@rev:0
-- monad-logger-0.3.28.5@rev:0
-- mono-traversable-1.0.8.1@rev:0
-- persistent-2.8.2@rev:0
-- persistent-sqlite-2.8.1.2@rev:0
-- project-template-0.2.0.1@rev:0
-- resourcet-1.2.1@rev:0
-- streaming-commons-0.2.0.0@rev:0
-- typed-process-0.2.2.0@rev:0
-- unliftio-0.2.7.0@rev:0
-- unliftio-core-0.1.1.0@rev:0
-- wai-extra-3.0.22.1@rev:0
-- wai-logger-2.3.2@rev:0
-- warp-3.2.22@rev:0
-- xml-conduit-1.8.0@rev:0
-- yaml-0.8.30@rev:0

stack-persistent-2-9.yaml

@@ -1,18 +0,0 @@
-resolver: lts-11.10
-packages:
-- ./yesod-core
-- ./yesod-static
-- ./yesod-persistent
-- ./yesod-newsfeed
-- ./yesod-form
-- ./yesod-auth
-- ./yesod-auth-oauth
-- ./yesod-sitemap
-- ./yesod-test
-- ./yesod-bin
-- ./yesod
-- ./yesod-eventsource
-- ./yesod-websockets
-extra-deps:
-- persistent-2.9.0@rev:0
-- persistent-sqlite-2.9.0@rev:0

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-core/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 2.0.0.0
+
+* Switch over to using `rio`
+
 ## 1.6.13
 
 * Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)

yesod-core/src/Yesod/Core.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
@@ -29,10 +30,6 @@ module Yesod.Core
     , AuthResult (..)
     , unauthorizedI
       -- * Logging
-    , defaultMakeLogger
-    , defaultMessageLoggerSource
-    , defaultShouldLogIO
-    , formatLogMessage
     , LogLevel (..)
     , logDebug
     , logInfo
@@ -67,8 +64,10 @@ module Yesod.Core
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
     -- * Generalizing type classes
-    , MonadHandler (..)
+    , HasHandlerData (..)
-    , MonadWidget (..)
+    , HasWidgetData (..)
+    , liftHandler
+    , liftWidget
       -- * Approot
     , guessApproot
     , guessApprootOr
@@ -76,7 +75,6 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
-    , Yesod.Core.runFakeHandler
       -- * LiteApp
     , module Yesod.Core.Internal.LiteApp
       -- * Low-level
@@ -94,12 +92,9 @@ module Yesod.Core
     , MonadIO (..)
     , MonadUnliftIO (..)
     , MonadResource (..)
-    , MonadLogger
+    , RIO
       -- * Commonly referenced functions/datatypes
     , Application
-      -- * Utilities
-    , showIntegral
-    , readIntegral
       -- * Shakespeare
       -- ** Hamlet
     , hamlet
@@ -120,7 +115,6 @@ module Yesod.Core
 import Yesod.Core.Content
 import Yesod.Core.Dispatch
 import Yesod.Core.Handler
-import Yesod.Core.Class.Handler
 import Yesod.Core.Widget
 import Yesod.Core.Json
 import Yesod.Core.Types
@@ -128,18 +122,16 @@ import Text.Shakespeare.I18N
 import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
 import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
 
-import Control.Monad.Logger
 import Control.Monad.Trans.Class (MonadTrans (..))
 import Yesod.Core.Internal.Session
 import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Class.Breadcrumbs
-import qualified Yesod.Core.Internal.Run
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 import Yesod.Routes.Class
-import UnliftIO (MonadIO (..), MonadUnliftIO (..))
+import RIO
 
 import Control.Monad.Trans.Resource (MonadResource (..))
 import Yesod.Core.Internal.LiteApp
@@ -149,17 +141,11 @@ import Text.Lucius
 import Text.Julius
 import Network.Wai (Application)
 
-runFakeHandler :: (Yesod site, MonadIO m) =>
-                  SessionMap
-               -> (site -> Logger)
-               -> site
-               -> HandlerT site IO a
-               -> m (Either ErrorResponse a)
-runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler
-{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}
-
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
+unauthorizedI
+  :: (HasHandlerData env, RenderMessage (HandlerSite env) msg)
+  => msg
+  -> RIO env AuthResult
 unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg
@@ -178,12 +164,3 @@ maybeAuthorized :: Yesod site
 maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
-
-showIntegral :: Integral a => a -> String
-showIntegral x = show (fromIntegral x :: Integer)
-
-readIntegral :: Num a => String -> Maybe a
-readIntegral s =
-    case reads s of
-        (i, _):_ -> Just $ fromInteger i
-        [] -> Nothing

yesod-core/src/Yesod/Core/Class/Dispatch.hs

@@ -4,8 +4,10 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Core.Class.Dispatch where
 
+import RIO
 import qualified Network.Wai as W
 import Yesod.Core.Types
 import Yesod.Core.Content (ToTypedContent (..))
@@ -30,8 +32,8 @@ instance YesodSubDispatch WaiSubsiteWithAuth master where
       ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
     where
       route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
-      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
+      WaiSubsiteWithAuth set' = ysreGetSub $ yreSite $ ysreParentEnv
-      handlert = sendWaiApplication set
+      handlert = sendWaiApplication set'
 
 subHelper
   :: ToTypedContent content
@@ -39,14 +41,15 @@ subHelper
   -> YesodSubRunnerEnv child master
   -> Maybe (Route child)
   -> W.Application
-subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
+subHelper subHandler YesodSubRunnerEnv {..} mroute =
     ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
   where
-    handler = fmap toTypedContent $ HandlerFor $ \hd ->
+    handler = fmap toTypedContent $ do
+      hd <- view subHandlerDataL
       let rhe = handlerEnv hd
           rhe' = rhe
             { rheRoute = mroute
             , rheChild = ysreGetSub $ yreSite ysreParentEnv
             , rheRouteToMaster = ysreToParentRoute
             }
-       in f hd { handlerEnv = rhe' }
+      runRIO hd { handlerEnv = rhe' } subHandler

yesod-core/src/Yesod/Core/Class/Handler.hs

@@ -1,120 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Yesod.Core.Class.Handler
-    ( MonadHandler (..)
-    , MonadWidget (..)
-    , liftHandlerT
-    , liftWidgetT
-    ) where
-
-import Yesod.Core.Types
-import Control.Monad.Logger (MonadLogger)
-import Control.Monad.Trans.Resource (MonadResource)
-import Control.Monad.Trans.Class (lift)
-import Data.Conduit.Internal (Pipe, ConduitM)
-
-import Control.Monad.Trans.Identity ( IdentityT)
-import Control.Monad.Trans.List     ( ListT    )
-import Control.Monad.Trans.Maybe    ( MaybeT   )
-import Control.Monad.Trans.Except   ( ExceptT  )
-import Control.Monad.Trans.Reader   ( ReaderT  )
-import Control.Monad.Trans.State    ( StateT   )
-import Control.Monad.Trans.Writer   ( WriterT  )
-import Control.Monad.Trans.RWS      ( RWST     )
-import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
-import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
-
--- FIXME should we just use MonadReader instances instead?
-class (MonadResource m, MonadLogger m) => MonadHandler m where
-    type HandlerSite m
-    type SubHandlerSite m
-    liftHandler :: HandlerFor (HandlerSite m) a -> m a
-    liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
-
-liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
-liftHandlerT = liftHandler
-{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
-
-instance MonadHandler (HandlerFor site) where
-    type HandlerSite (HandlerFor site) = site
-    type SubHandlerSite (HandlerFor site) = site
-    liftHandler = id
-    {-# INLINE liftHandler #-}
-    liftSubHandler (SubHandlerFor f) = HandlerFor f
-    {-# INLINE liftSubHandler #-}
-
-instance MonadHandler (SubHandlerFor sub master) where
-    type HandlerSite (SubHandlerFor sub master) = master
-    type SubHandlerSite (SubHandlerFor sub master) = sub
-    liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd
-      { handlerEnv =
-          let rhe = handlerEnv hd
-           in rhe
-                { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)
-                , rheRouteToMaster = id
-                , rheChild = rheSite rhe
-                }
-      }
-    {-# INLINE liftHandler #-}
-    liftSubHandler = id
-    {-# INLINE liftSubHandler #-}
-
-instance MonadHandler (WidgetFor site) where
-    type HandlerSite (WidgetFor site) = site
-    type SubHandlerSite (WidgetFor site) = site
-    liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
-    {-# INLINE liftHandler #-}
-    liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler
-    {-# INLINE liftSubHandler #-}
-
-#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
-#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
-GO(IdentityT)
-GO(ListT)
-GO(MaybeT)
-GO(ExceptT e)
-GO(ReaderT r)
-GO(StateT s)
-GOX(Monoid w, WriterT w)
-GOX(Monoid w, RWST r w s)
-GOX(Monoid w, Strict.RWST r w s)
-GO(Strict.StateT s)
-GOX(Monoid w, Strict.WriterT w)
-GO(Pipe l i o u)
-GO(ConduitM i o)
-#undef GO
-#undef GOX
-
-class MonadHandler m => MonadWidget m where
-    liftWidget :: WidgetFor (HandlerSite m) a -> m a
-instance MonadWidget (WidgetFor site) where
-    liftWidget = id
-    {-# INLINE liftWidget #-}
-
-liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
-liftWidgetT = liftWidget
-{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}
-
-#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
-#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
-GO(IdentityT)
-GO(ListT)
-GO(MaybeT)
-GO(ExceptT e)
-GO(ReaderT r)
-GO(StateT s)
-GOX(Monoid w, WriterT w)
-GOX(Monoid w, RWST r w s)
-GOX(Monoid w, Strict.RWST r w s)
-GO(Strict.StateT s)
-GOX(Monoid w, Strict.WriterT w)
-GO(Pipe l i o u)
-GO(ConduitM i o)
-#undef GO
-#undef GOX

yesod-core/src/Yesod/Core/Class/Yesod.hs

@@ -1,9 +1,12 @@
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Yesod.Core.Class.Yesod where
 
+import           RIO
+
 import           Yesod.Core.Content
 import           Yesod.Core.Handler
 
@@ -12,11 +15,6 @@ import           Yesod.Routes.Class
 import           Data.ByteString.Builder            (Builder)
 import           Data.Text.Encoding                 (encodeUtf8Builder)
 import           Control.Arrow                      ((***), second)
-import           Control.Exception                  (bracket)
-import           Control.Monad                      (forM, when, void)
-import           Control.Monad.IO.Class             (MonadIO (liftIO))
-import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
-                                                     LogSource, logErrorS)
 import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState)
 import qualified Data.ByteString.Char8              as S8
 import qualified Data.ByteString.Lazy               as L
@@ -30,15 +28,12 @@ import qualified Data.Text                          as T
 import qualified Data.Text.Encoding                 as TE
 import qualified Data.Text.Encoding.Error           as TEE
 import           Data.Text.Lazy.Builder             (toLazyText)
-import           Data.Text.Lazy.Encoding            (encodeUtf8)
+import qualified Data.Text.Lazy.Encoding            as TLE (encodeUtf8)
-import           Data.Word                          (Word64)
 import           Language.Haskell.TH.Syntax         (Loc (..))
 import           Network.HTTP.Types                 (encodePath)
 import qualified Network.Wai                        as W
 import           Network.Wai.Parse                  (lbsBackEnd,
                                                      tempFileBackEnd)
-import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
-import           System.Log.FastLogger
 import           Text.Blaze                         (customAttribute, textTag,
                                                      toValue, (!),
                                                      preEscapedToMarkup)
@@ -53,7 +48,6 @@ import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Data.CaseInsensitive (CI)
 import qualified Network.Wai.Request
-import Data.IORef
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -215,29 +209,15 @@ class RenderRoute site => Yesod site where
     maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
     maximumContentLengthIO a b = pure $ maximumContentLength a b
 
-    -- | Creates a @Logger@ to use for log messages.
+    -- | Get the 'LogFunc' from the foundation type.
     --
-    -- Note that a common technique (endorsed by the scaffolding) is to create
+    -- If this function returns a @Nothing@ (the default), the Yesod
-    -- a @Logger@ value and place it in your foundation datatype, and have this
+    -- codebase itself will create a log function for you with some
-    -- method return that already created value. That way, you can use that
+    -- default settings. Overriding this allows you to have more
-    -- same @Logger@ for printing messages during app initialization.
+    -- control, and also to share your log function with code outside
-    --
+    -- of your handlers.
-    -- Default: the 'defaultMakeLogger' function.
+    getLogFunc :: site -> Maybe LogFunc
-    makeLogger :: site -> IO Logger
+    getLogFunc _ = Nothing
-    makeLogger _ = defaultMakeLogger
-
-    -- | Send a message to the @Logger@ provided by @getLogger@.
-    --
-    -- Default: the 'defaultMessageLoggerSource' function, using
-    -- 'shouldLogIO' to check whether we should log.
-    messageLoggerSource :: site
-                        -> Logger
-                        -> Loc -- ^ position in source code
-                        -> LogSource
-                        -> LogLevel
-                        -> LogStr -- ^ message
-                        -> IO ()
-    messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site
 
     -- | Where to Load sripts from. We recommend the default value,
     -- 'BottomOfBody'.
@@ -268,14 +248,6 @@ class RenderRoute site => Yesod site where
         | size <= 50000 = FileUploadMemory lbsBackEnd
     fileUpload _ _ = FileUploadDisk tempFileBackEnd
 
-    -- | Should we log the given log source/level combination.
-    --
-    -- Default: the 'defaultShouldLogIO' function.
-    --
-    -- Since 1.2.4
-    shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
-    shouldLogIO _ = defaultShouldLogIO
-
     -- | A Yesod middleware, which will wrap every handler function. This
     -- allows you to run code before and after a normal handler.
     --
@@ -312,44 +284,6 @@ class RenderRoute site => Yesod site where
                 ^{body}
             |]
 
--- | Default implementation of 'makeLogger'. Sends to stdout and
--- automatically flushes on each write.
---
--- Since 1.4.10
-defaultMakeLogger :: IO Logger
-defaultMakeLogger = do
-    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
-    return $! Logger loggerSet' getter
-
--- | Default implementation of 'messageLoggerSource'. Checks if the
--- message should be logged using the provided function, and if so,
--- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO'
--- as the provided function.
---
--- Since 1.4.10
-defaultMessageLoggerSource ::
-       (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should
-                                          -- log this
-    -> Logger
-    -> Loc -- ^ position in source code
-    -> LogSource
-    -> LogLevel
-    -> LogStr -- ^ message
-    -> IO ()
-defaultMessageLoggerSource ckLoggable logger loc source level msg = do
-    loggable <- ckLoggable source level
-    when loggable $
-        formatLogMessage (loggerDate logger) loc source level msg >>=
-        loggerPutStr logger
-
--- | Default implementation of 'shouldLog'. Logs everything at or
--- above 'LevelInfo'.
---
--- Since 1.4.10
-defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
-defaultShouldLogIO _ level = return $ level >= LevelInfo
-
 -- | Default implementation of 'yesodMiddleware'. Adds the response header
 -- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
 -- performs authorization checks.
@@ -418,12 +352,10 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
 sslOnlyMiddleware :: Int -- ^ minutes
                   -> HandlerFor site res
                   -> HandlerFor site res
-sslOnlyMiddleware timeout handler = do
+sslOnlyMiddleware timeout' handler = do
     addHeader "Strict-Transport-Security"
-              $ T.pack $ concat [ "max-age="
+              $ utf8BuilderToText -- FIXME should we store headers as Utf8Builders?
-                                , show $ timeout * 60
+              $ "max-age=" <> display (timeout' * 60) <> "; includeSubDomains"
-                                , "; includeSubDomains"
-                                ]
     handler
 
 -- | Check if a given request is authorized via 'isAuthorized' and
@@ -449,7 +381,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
                               void $ redirect url'
                           provideRepType typeJson $
                               void notAuthenticated
-            Unauthorized s' -> permissionDenied s'
+            Unauthorized s' -> permissionDenied $ display s'
 
 -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
 --
@@ -520,19 +452,17 @@ defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddlew
 widgetToPageContent :: Yesod site
                     => WidgetFor site ()
                     -> HandlerFor site (PageContent (Route site))
-widgetToPageContent w = HandlerFor $ \hd -> do
+widgetToPageContent w = do
-  master <- unHandlerFor getYesod hd
+  master <- getYesod
   ref <- newIORef mempty
-  unWidgetFor w WidgetData
+  hd <- ask
-    { wdRef = ref
+  runRIO WidgetData { wdRef = ref, wdHandler = hd } w
-    , wdHandler = hd
-    }
   GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
   let title = maybe mempty unTitle mTitle
       scripts = runUniqueList scripts'
       stylesheets = runUniqueList stylesheets'
 
-  flip unHandlerFor hd $ do
+  do -- just to reduce whitespace diffs
     render <- getUrlRenderParams
     let renderLoc x =
             case x of
@@ -542,7 +472,7 @@ widgetToPageContent w = HandlerFor $ \hd -> do
     css <- forM (Map.toList style) $ \(mmedia, content) -> do
         let rendered = toLazyText $ content render
         x <- addStaticContent "css" "text/css; charset=utf-8"
-           $ encodeUtf8 rendered
+           $ TLE.encodeUtf8 $ rendered
         return (mmedia,
             case x of
                 Nothing -> Left $ preEscapedToMarkup rendered
@@ -552,7 +482,7 @@ widgetToPageContent w = HandlerFor $ \hd -> do
             Nothing -> return Nothing
             Just s -> do
                 x <- addStaticContent "js" "text/javascript; charset=utf-8"
-                   $ encodeUtf8 $ renderJavascriptUrl render s
+                   $ TLE.encodeUtf8 $ renderJavascriptUrl render s
                 return $ renderLoc x
 
     -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
@@ -673,7 +603,7 @@ defaultErrorHandler (InvalidArgs ia) = selectRep $ do
     provideRep $ return $ ("Invalid Arguments: " <> T.intercalate " " ia)
 
 defaultErrorHandler (InternalError e) = do
-    $logErrorS "yesod-core" e
+    logErrorS "yesod-core" $ display e
     selectRep $ do
         provideRep $ defaultLayout $ defaultMessageWidget
             "Internal Server Error"
@@ -711,43 +641,6 @@ asyncHelper render scripts jscript jsLoc =
                     Nothing -> Nothing
                     Just j -> Just $ jelper j
 
--- | Default formatting for log messages. When you use
--- the template haskell logging functions for to log with information
--- about the source location, that information will be appended to
--- the end of the log. When you use the non-TH logging functions,
--- like 'logDebugN', this function does not include source
--- information. This currently works by checking to see if the
--- package name is the string \"\<unknown\>\". This is a hack,
--- but it removes some of the visual clutter from non-TH logs.
---
--- Since 1.4.10
-formatLogMessage :: IO ZonedDate
-                 -> Loc
-                 -> LogSource
-                 -> LogLevel
-                 -> LogStr -- ^ message
-                 -> IO LogStr
-formatLogMessage getdate loc src level msg = do
-    now <- getdate
-    return $ mempty
-        `mappend` toLogStr now
-        `mappend` " ["
-        `mappend` (case level of
-            LevelOther t -> toLogStr t
-            _ -> toLogStr $ drop 5 $ show level)
-        `mappend` (if T.null src
-            then mempty
-            else "#" `mappend` toLogStr src)
-        `mappend` "] "
-        `mappend` msg
-        `mappend` sourceSuffix
-        `mappend` "\n"
-    where
-    sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty
-        `mappend` " @("
-        `mappend` toLogStr (fileLocationToString loc)
-        `mappend` ")"
-
 -- | Customize the cookies used by the session backend.  You may
 -- use this function on your definition of 'makeSessionBackend'.
 --

yesod-core/src/Yesod/Core/Dispatch.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.Core.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -38,7 +39,6 @@ module Yesod.Core.Dispatch
 
 import Prelude hiding (exp)
 import Yesod.Core.Internal.TH
-import Language.Haskell.TH.Syntax (qLocation)
 
 import Web.PathPieces
 
@@ -68,28 +68,43 @@ import Network.Wai.Middleware.AcceptOverride
 import Network.Wai.Middleware.RequestLogger
 import Network.Wai.Middleware.Gzip
 import Network.Wai.Middleware.MethodOverride
+import System.Log.FastLogger (fromLogStr)
 
 import qualified Network.Wai.Handler.Warp
-import System.Log.FastLogger
-import Control.Monad.Logger
 import Control.Monad (when)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
+import RIO
+
+-- | Get a 'LogFunc' from the site, or create if needed. Returns an
+-- @IORef@ with a finalizer to clean up when done.
+makeLogFunc :: Yesod site => site -> IO (LogFunc, IORef ())
+makeLogFunc site =
+  case getLogFunc site of
+    Just logFunc -> do
+      ref <- newIORef ()
+      pure (logFunc, ref)
+    Nothing -> do
+      (logFunc, cleanup) <- logOptionsHandle stderr False >>= newLogFunc
+      ref <- newIORef ()
+      _ <- mkWeakIORef ref cleanup
+      pure (logFunc, ref)
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This function will provide no middlewares; if you want commonly
 -- used middlewares, please use 'toWaiApp'.
 toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
 toWaiAppPlain site = do
-    logger <- makeLogger site
+    (logFunc, cleanup) <- makeLogFunc site
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre YesodRunnerEnv
-            { yreLogger = logger
+            { yreLogFunc = logFunc
             , yreSite = site
             , yreSessionBackend = sb
             , yreGen = defaultGen
             , yreGetMaxExpires = getMaxExpires
+            , yreCleanup = cleanup
             }
 
 defaultGen :: IO Int
@@ -143,28 +158,28 @@ toWaiAppYre yre req =
 -- * Accept header override with the _accept query string parameter
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
-    logger <- makeLogger site
+    (logFunc, cleanup) <- makeLogFunc site
-    toWaiAppLogger logger site
+    toWaiAppLogger logFunc cleanup site
 
-toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
+toWaiAppLogger
-toWaiAppLogger logger site = do
+  :: YesodDispatch site
+  => LogFunc
+  -> IORef () -- ^ cleanup
+  -> site
+  -> IO W.Application
+toWaiAppLogger logFunc cleanup site = do
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
-                { yreLogger = logger
+                { yreLogFunc = logFunc
                 , yreSite = site
                 , yreSessionBackend = sb
                 , yreGen = defaultGen
                 , yreGetMaxExpires = getMaxExpires
+                , yreCleanup = cleanup
                 }
-    messageLoggerSource
+    runRIO logFunc $ logInfoS "yesod-core" "Application launched"
-        site
+    middleware <- mkDefaultMiddlewares logFunc
-        logger
-        $(qLocation >>= liftLoc)
-        "yesod-core"
-        LevelInfo
-        (toLogStr ("Application launched" :: S.ByteString))
-    middleware <- mkDefaultMiddlewares logger
     return $ middleware $ toWaiAppYre yre
 
 -- | A convenience method to run an application using the Warp webserver on the
@@ -178,19 +193,15 @@ toWaiAppLogger logger site = do
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
 warp port site = do
-    logger <- makeLogger site
+    (logFunc, cleanup) <- makeLogFunc site
-    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
+    toWaiAppLogger logFunc cleanup site >>= Network.Wai.Handler.Warp.runSettings (
         Network.Wai.Handler.Warp.setPort port $
         Network.Wai.Handler.Warp.setServerName serverValue $
         Network.Wai.Handler.Warp.setOnException (\_ e ->
                 when (shouldLog' e) $
-                messageLoggerSource
+                runRIO logFunc $
-                    site
+                logErrorS "yesod-core" $
-                    logger
+                "Exception from Warp: " <> displayShow e)
-                    $(qLocation >>= liftLoc)
-                    "yesod-core"
-                    LevelError
-                    (toLogStr $ "Exception from Warp: " ++ show e))
         Network.Wai.Handler.Warp.defaultSettings)
   where
     shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
@@ -207,10 +218,14 @@ serverValue = S8.pack $ concat
 -- | A default set of middlewares.
 --
 -- Since 1.2.0
-mkDefaultMiddlewares :: Logger -> IO W.Middleware
+mkDefaultMiddlewares :: LogFunc -> IO W.Middleware
-mkDefaultMiddlewares logger = do
+mkDefaultMiddlewares logFunc = do
     logWare <- mkRequestLogger def
-        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
+        { destination = Network.Wai.Middleware.RequestLogger.Callback $
+            runRIO logFunc .
+            logInfoS "yesod-core" .
+            displayBytesUtf8 .
+            fromLogStr
         , outputFormat = Apache FromSocket
         }
     return $ logWare . defaultMiddlewaresNoLogging

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards     #-}
 {-# LANGUAGE RankNTypes        #-}
@@ -8,16 +9,13 @@
 module Yesod.Core.Internal.Run where
 
 
+import           RIO
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
-import           Control.Monad.IO.Class       (MonadIO, liftIO)
-import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
-                                               liftLoc)
 import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
-import qualified Data.IORef                   as I
 import qualified Data.Map                     as Map
 import           Data.Maybe                   (isJust, fromMaybe)
 import           Data.Monoid                  (appEndo)
@@ -25,11 +23,9 @@ import           Data.Text                    (Text)
 import qualified Data.Text                    as T
 import           Data.Text.Encoding           (encodeUtf8, decodeUtf8With)
 import           Data.Text.Encoding.Error     (lenientDecode)
-import           Language.Haskell.TH.Syntax   (Loc, qLocation)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
 import           Network.Wai.Internal
-import           System.Log.FastLogger        (LogStr, toLogStr)
 import           Yesod.Core.Content
 import           Yesod.Core.Class.Yesod
 import           Yesod.Core.Types
@@ -38,7 +34,6 @@ import           Yesod.Core.Internal.Request  (parseWaiRequest,
 import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
-import           UnliftIO.Exception
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -67,13 +62,13 @@ basicRunHandler :: ToTypedContent c
 basicRunHandler rhe handler yreq resState = do
     -- Create a mutable ref to hold the state. We use mutable refs so
     -- that the updates will survive runtime exceptions.
-    istate <- I.newIORef defState
+    istate <- newIORef defState
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
     contents' <- catchAny
         (do
-            res <- unHandlerFor handler (hd istate)
+            res <- runRIO (hd istate) handler
             tc <- evaluate (toTypedContent res)
             -- Success! Wrap it up in an @HCContent@
             return (HCContent defaultStatus tc))
@@ -83,7 +78,7 @@ basicRunHandler rhe handler yreq resState = do
                 Nothing -> HCError <$> toErrorHandler e)
 
     -- Get the raw state and return
-    state <- I.readIORef istate
+    state <- readIORef istate
     return (state, contents')
   where
     defState = GHState
@@ -94,7 +89,7 @@ basicRunHandler rhe handler yreq resState = do
         , ghsCacheBy = mempty
         , ghsHeaders = mempty
         }
-    hd istate = HandlerData
+    hd istate = HandlerData $ SubHandlerData
         { handlerRequest = yreq
         , handlerEnv     = rhe
         , handlerState   = istate
@@ -203,12 +198,11 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
         headers
         contents3
 
-safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+safeEh :: LogFunc -> ErrorResponse -> YesodApp
-       -> ErrorResponse
+safeEh logFunc er req = do
-       -> YesodApp
+    runRIO logFunc $
-safeEh log' er req = do
+      logErrorS "yesod-core" $
-    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
+      "Error handler errored out: " <> displayShow er
-           $ toLogStr $ "Error handler errored out: " ++ show er
     return $ YRPlain
         H.status500
         []
@@ -238,14 +232,14 @@ safeEh log' er req = do
 -- @HandlerT@'s return value.
 runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
-               -> (site -> Logger)
+               -> LogFunc
                -> site
                -> HandlerFor site a
                -> m (Either ErrorResponse a)
-runFakeHandler fakeSessionMap logger site handler = liftIO $ do
+runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do
-  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
+  ret <- newIORef (Left $ InternalError "runFakeHandler: no result")
   maxExpires <- getCurrentMaxExpiresRFC1123
-  let handler' = liftIO . I.writeIORef ret . Right =<< handler
+  let handler' = writeIORef ret . Right =<< handler
   let yapp = runHandler
          RunHandlerEnv
             { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
@@ -254,13 +248,13 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheChild = site
             , rheSite = site
             , rheUpload = fileUpload site
-            , rheLog = messageLoggerSource site $ logger site
+            , rheLogFunc = logFunc
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
             }
         handler'
       errHandler err req = do
-          liftIO $ I.writeIORef ret (Left err)
+          writeIORef ret (Left err)
           return $ YRPlain
                      H.status500
                      []
@@ -296,7 +290,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
           , reqSession    = fakeSessionMap
           }
   _ <- runResourceT $ yapp fakeRequest
-  I.readIORef ret
+  readIORef ret
 
 yesodRunner :: (ToTypedContent res, Yesod site)
             => HandlerFor site res
@@ -318,8 +312,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
                   Left yreq' -> yreq'
                   Right needGen -> needGen yreGen
       let ra = resolveApproot yreSite req
-      let log' = messageLoggerSource yreSite yreLogger
+      let -- We set up two environments: the first one has a "safe" error handler
-          -- We set up two environments: the first one has a "safe" error handler
           -- which will never throw an exception. The second one uses the
           -- user-provided errorHandler function. If that errorHandler function
           -- errors out, it will use the safeEh below to recover.
@@ -330,8 +323,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheChild = yreSite
               , rheSite = yreSite
               , rheUpload = fileUpload yreSite
-              , rheLog = log'
+              , rheLogFunc = yreLogFunc
-              , rheOnError = safeEh log'
+              , rheOnError = safeEh yreLogFunc
               , rheMaxExpires = maxExpires
               }
           rhe = rheSafe

yesod-core/src/Yesod/Core/Json.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Core.Json
     ( -- * Convert from a JSON value
       defaultLayoutJson
@@ -34,13 +33,13 @@ module Yesod.Core.Json
     , acceptsJson
     ) where
 
+import RIO
 import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
 import Control.Monad.Trans.Writer (Writer)
 import Data.Monoid (Endo)
 import Yesod.Core.Content (TypedContent)
-import Yesod.Core.Types (reqAccept)
+import Yesod.Core.Types (reqAccept, HasHandlerData (..))
 import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
-import Yesod.Core.Class.Handler
 import Yesod.Core.Widget (WidgetFor)
 import Yesod.Routes.Class
 import qualified Data.Aeson as J
@@ -98,7 +97,7 @@ provideJson = provideRep . return . J.toEncoding
 -- | Same as 'parseInsecureJsonBody'
 --
 -- @since 0.3.0
-parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseJsonBody = parseInsecureJsonBody
 {-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}
 
@@ -108,7 +107,7 @@ parseJsonBody = parseInsecureJsonBody
 -- Note: This function is vulnerable to CSRF attacks.
 --
 -- @since 1.6.11
-parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseInsecureJsonBody = do
     eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
     return $ case eValue of
@@ -131,7 +130,7 @@ parseInsecureJsonBody = do
 -- body will no longer be available.
 --
 -- @since 0.3.0
-parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env (J.Result a)
 parseCheckJsonBody = do
     mct <- lookupHeader "content-type"
     case fmap (B8.takeWhile (/= ';')) mct of
@@ -140,13 +139,13 @@ parseCheckJsonBody = do
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
+parseJsonBody_ :: (HasHandlerData env, J.FromJSON a) => RIO env a
 parseJsonBody_ = requireInsecureJsonBody
 {-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
 -- error.
-requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireJsonBody = requireInsecureJsonBody
 {-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}
 
@@ -154,7 +153,7 @@ requireJsonBody = requireInsecureJsonBody
 -- error.
 --
 -- @since 1.6.11
-requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireInsecureJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireInsecureJsonBody = do
     ra <- parseInsecureJsonBody
     case ra of
@@ -163,7 +162,7 @@ requireInsecureJsonBody = do
 
 -- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse
 -- error.
-requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireCheckJsonBody :: (HasHandlerData env, J.FromJSON a) => RIO env a
 requireCheckJsonBody = do
     ra <- parseCheckJsonBody
     case ra of
@@ -181,10 +180,10 @@ array = J.Array . V.fromList . map J.toJSON
 --     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
 --
 --     2. 3xx otherwise, following the PRG pattern.
-jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
+jsonOrRedirect :: (HasHandlerData env, J.ToJSON a)
-               => Route (HandlerSite m) -- ^ Redirect target
+               => Route (HandlerSite env) -- ^ Redirect target
                -> a            -- ^ Data to send via JSON
-               -> m J.Value
+               -> RIO env J.Value
 jsonOrRedirect = jsonOrRedirect' J.toJSON
 
 -- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different
@@ -195,17 +194,17 @@ jsonOrRedirect = jsonOrRedirect' J.toJSON
 --
 --     2. 3xx otherwise, following the PRG pattern.
 -- @since 1.4.21
-jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
+jsonEncodingOrRedirect :: (HasHandlerData env, J.ToJSON a)
-            => Route (HandlerSite m) -- ^ Redirect target
+            => Route (HandlerSite env) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> m J.Encoding
+            -> RIO env J.Encoding
 jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding
 
-jsonOrRedirect' :: MonadHandler m
+jsonOrRedirect' :: HasHandlerData env
             => (a -> b)
-            -> Route (HandlerSite m) -- ^ Redirect target
+            -> Route (HandlerSite env) -- ^ Redirect target
             -> a            -- ^ Data to send via JSON
-            -> m b
+            -> RIO env b
 jsonOrRedirect' f r j = do
     q <- acceptsJson
     if q then return (f j)
@@ -213,7 +212,7 @@ jsonOrRedirect' f r j = do
 
 -- | Returns @True@ if the client prefers @application\/json@ as
 -- indicated by the @Accept@ HTTP header.
-acceptsJson :: MonadHandler m => m Bool
+acceptsJson :: HasHandlerData env => RIO env Bool
 acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
             .  listToMaybe
             .  reqAccept)

yesod-core/src/Yesod/Core/Types.hs

@@ -1,61 +1,51 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+-- FIXME rename to Internal
 module Yesod.Core.Types where
 
 import qualified Data.ByteString.Builder            as BB
-import           Control.Arrow                      (first)
+import           Control.Monad.Trans.Resource       (ResourceT)
-import           Control.Exception                  (Exception)
-import           Control.Monad                      (ap)
-import           Control.Monad.IO.Class             (MonadIO (liftIO))
-import           Control.Monad.Logger               (LogLevel, LogSource,
-                                                     MonadLogger (..))
-import           Control.Monad.Primitive            (PrimMonad (..))
-import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
-import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
 import           Data.CaseInsensitive               (CI)
-import           Data.Conduit                       (Flush, ConduitT)
+import           Conduit                            (Flush, ConduitT)
-import           Data.IORef                         (IORef, modifyIORef')
+import           RIO.Map                            (unionWith)
-import           Data.Map                           (Map, unionWith)
+import qualified RIO.Map                            as Map
-import qualified Data.Map                           as Map
 import           Data.Monoid                        (Endo (..), Last (..))
-import           Data.Semigroup                     (Semigroup(..))
 import           Data.Serialize                     (Serialize (..),
                                                      putByteString)
 import           Data.String                        (IsString (fromString))
-import           Data.Text                          (Text)
 import qualified Data.Text                          as T
 import qualified Data.Text.Lazy.Builder             as TBuilder
 import           Data.Time                          (UTCTime)
 import           Data.Typeable                      (Typeable)
 import           GHC.Generics                       (Generic)
-import           Language.Haskell.TH.Syntax         (Loc)
 import qualified Network.HTTP.Types                 as H
 import           Network.Wai                        (FilePart,
                                                      RequestBodyLength)
 import qualified Network.Wai                        as W
 import qualified Network.Wai.Parse                  as NWP
-import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)
-import           Network.Wai.Logger                 (DateCacheGetter)
 import           Text.Blaze.Html                    (Html, toHtml)
 import           Text.Hamlet                        (HtmlUrl)
 import           Text.Julius                        (JavascriptUrl)
 import           Web.Cookie                         (SetCookie)
 import           Yesod.Core.Internal.Util           (getTime, putTime)
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
-import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
-import Control.Monad.Logger (MonadLoggerIO (..))
+
-import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
+import RIO
+import RIO.Orphans
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -131,7 +121,7 @@ data FileInfo = FileInfo
     }
 
 data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
-                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
+                | FileUploadDisk !(ResourceMap -> NWP.BackEnd FilePath)
                 | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
 
 -- | How to determine the root of the application for constructing URLs.
@@ -176,28 +166,73 @@ data RunHandlerEnv child site = RunHandlerEnv
     , rheSite     :: !site
     , rheChild    :: !child
     , rheUpload   :: !(RequestBodyLength -> FileUpload)
-    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    , rheLogFunc  :: !LogFunc
     , rheOnError  :: !(ErrorResponse -> YesodApp)
       -- ^ How to respond when an error is thrown internally.
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
     }
+instance HasLogFunc (RunHandlerEnv child site) where
+  logFuncL = lens rheLogFunc (\x y -> x { rheLogFunc = y })
 
-data HandlerData child site = HandlerData
+data SubHandlerData child site = SubHandlerData
     { handlerRequest  :: !YesodRequest
     , handlerEnv      :: !(RunHandlerEnv child site)
     , handlerState    :: !(IORef GHState)
-    , handlerResource :: !InternalState
+    , handlerResource :: !ResourceMap
     }
 
+class (HasResourceMap env, HasLogFunc env) => HasHandlerData env where
+  type HandlerSite env
+  type SubHandlerSite env
+
+  subHandlerDataL :: Lens' env (SubHandlerData (SubHandlerSite env) (HandlerSite env))
+class (HasHandlerData env, HandlerSite env ~ SubHandlerSite env) => HasWidgetData env where
+  widgetDataL :: Lens' env (WidgetData (HandlerSite env))
+
+instance HasHandlerData (SubHandlerData child site) where
+  type HandlerSite (SubHandlerData child site) = site
+  type SubHandlerSite (SubHandlerData child site) = child
+  subHandlerDataL = id
+instance HasLogFunc (SubHandlerData child site) where
+  logFuncL = lens handlerEnv (\x y -> x { handlerEnv = y }).logFuncL
+instance HasResourceMap (SubHandlerData child site) where
+  resourceMapL = lens handlerResource (\x y -> x { handlerResource = y })
+
+instance HasHandlerData (HandlerData site) where
+  type HandlerSite (HandlerData site) = site
+  type SubHandlerSite (HandlerData site) = site
+  subHandlerDataL = lens unHandlerData (\_ y -> HandlerData y)
+instance HasLogFunc (HandlerData site) where
+  logFuncL = subHandlerDataL.logFuncL
+instance HasResourceMap (HandlerData site) where
+  resourceMapL = subHandlerDataL.resourceMapL
+
+instance HasHandlerData (WidgetData site) where
+  type HandlerSite (WidgetData site) = site
+  type SubHandlerSite (WidgetData site) = site
+  subHandlerDataL =
+    (lens wdHandler (\x y -> x { wdHandler = y })).subHandlerDataL
+instance HasWidgetData (WidgetData site) where
+  widgetDataL = id
+instance HasLogFunc (WidgetData site) where
+  logFuncL = subHandlerDataL.logFuncL
+instance HasResourceMap (WidgetData site) where
+  resourceMapL = subHandlerDataL.resourceMapL
+
+newtype HandlerData site = HandlerData { unHandlerData :: SubHandlerData site site }
+
 data YesodRunnerEnv site = YesodRunnerEnv
-    { yreLogger         :: !Logger
+    { yreLogFunc        :: !LogFunc
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !(IO Int)
     -- ^ Generate a random number
     , yreGetMaxExpires  :: !(IO Text)
+    , yreCleanup        :: !(IORef ())
+    -- ^ Used to ensure some cleanup actions can be performed via
+    -- garbage collection.
     }
 
 data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
@@ -215,10 +250,7 @@ type ParentRunner parent
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
-newtype HandlerFor site a = HandlerFor
+type HandlerFor site = RIO (HandlerData site)
-    { unHandlerFor :: HandlerData site site -> IO a
-    }
-    deriving Functor
 
 data GHState = GHState
     { ghsSession :: !SessionMap
@@ -237,24 +269,13 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
-newtype WidgetFor site a = WidgetFor
+type WidgetFor site = RIO (WidgetData site)
-    { unWidgetFor :: WidgetData site -> IO a
-    }
-    deriving Functor
 
 data WidgetData site = WidgetData
   { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
-  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)
+  , wdHandler :: {-# UNPACK #-} !(HandlerData site)
   }
 
-instance a ~ () => Monoid (WidgetFor site a) where
-    mempty = return ()
-#if !(MIN_VERSION_base(4,11,0))
-    mappend = (<>)
-#endif
-instance a ~ () => Semigroup (WidgetFor site a) where
-    x <> y = x >> y
-
 -- | A 'String' can be trivially promoted to a widget.
 --
 -- For example, in a yesod-scaffold site you could use:
@@ -264,8 +285,10 @@ instance a ~ () => IsString (WidgetFor site a) where
     fromString = toWidget . toHtml . T.pack
       where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
 
-tellWidget :: GWData (Route site) -> WidgetFor site ()
+tellWidget :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env ()
-tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
+tellWidget d = do
+  wd <- view widgetDataL
+  modifyIORef' (wdRef wd) (<> d)
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
@@ -288,8 +311,8 @@ data PageContent url = PageContent
     , pageBody  :: !(HtmlUrl url)
     }
 
-data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
+data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
+             | ContentSource !(ConduitT () (Flush Builder) (ResourceT IO) ())
              | ContentFile !FilePath !(Maybe FilePart)
              | ContentDontEvaluate !Content
 
@@ -330,9 +353,6 @@ data Header =
     -- ^ key and value
     deriving (Eq, Show)
 
--- FIXME In the next major version bump, let's just add strictness annotations
--- to Header (and probably everywhere else). We can also add strictness
--- annotations to SetCookie in the cookie package.
 instance NFData Header where
     rnf (AddCookie x) = rnf x
     rnf (DeleteCookie x y) = x `seq` y `seq` ()
@@ -373,9 +393,7 @@ data GWData a = GWData
     }
 instance Monoid (GWData a) where
     mempty = GWData mempty mempty mempty mempty mempty mempty mempty
-#if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
-#endif
 instance Semigroup (GWData a) where
     GWData a1 a2 a3 a4 a5 a6 a7 <>
       GWData b1 b2 b3 b4 b5 b6 b7 = GWData
@@ -407,84 +425,9 @@ instance Show HandlerContents where
     show (HCWaiApp _) = "HCWaiApp"
 instance Exception HandlerContents
 
--- Instances for WidgetFor
-instance Applicative (WidgetFor site) where
-    pure = WidgetFor . const . pure
-    (<*>) = ap
-instance Monad (WidgetFor site) where
-    return = pure
-    WidgetFor x >>= f = WidgetFor $ \wd -> do
-        a <- x wd
-        unWidgetFor (f a) wd
-instance MonadIO (WidgetFor site) where
-    liftIO = WidgetFor . const
--- | @since 1.6.7
-instance PrimMonad (WidgetFor site) where
-    type PrimState (WidgetFor site) = PrimState IO
-    primitive = liftIO . primitive
--- | @since 1.4.38
-instance MonadUnliftIO (WidgetFor site) where
-  {-# INLINE askUnliftIO #-}
-  askUnliftIO = WidgetFor $ \wd ->
-                return (UnliftIO (flip unWidgetFor wd))
-instance MonadReader (WidgetData site) (WidgetFor site) where
-    ask = WidgetFor return
-    local f (WidgetFor g) = WidgetFor $ g . f
-
-instance MonadThrow (WidgetFor site) where
-    throwM = liftIO . throwM
-
-instance MonadResource (WidgetFor site) where
-    liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
-
-instance MonadLogger (WidgetFor site) where
-    monadLoggerLog a b c d = WidgetFor $ \wd ->
-        rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
-
-instance MonadLoggerIO (WidgetFor site) where
-    askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
-
--- Instances for HandlerT
-instance Applicative (HandlerFor site) where
-    pure = HandlerFor . const . return
-    (<*>) = ap
-instance Monad (HandlerFor site) where
-    return = pure
-    HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
-instance MonadIO (HandlerFor site) where
-    liftIO = HandlerFor . const
--- | @since 1.6.7
-instance PrimMonad (HandlerFor site) where
-    type PrimState (HandlerFor site) = PrimState IO
-    primitive = liftIO . primitive
-instance MonadReader (HandlerData site site) (HandlerFor site) where
-    ask = HandlerFor return
-    local f (HandlerFor g) = HandlerFor $ g . f
-
--- | @since 1.4.38
-instance MonadUnliftIO (HandlerFor site) where
-  {-# INLINE askUnliftIO #-}
-  askUnliftIO = HandlerFor $ \r ->
-                return (UnliftIO (flip unHandlerFor r))
-
-instance MonadThrow (HandlerFor site) where
-    throwM = liftIO . throwM
-
-instance MonadResource (HandlerFor site) where
-    liftResourceT f = HandlerFor $ runInternalState f . handlerResource
-
-instance MonadLogger (HandlerFor site) where
-    monadLoggerLog a b c d = HandlerFor $ \hd ->
-        rheLog (handlerEnv hd) a b c (toLogStr d)
-
-instance MonadLoggerIO (HandlerFor site) where
-    askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
-
 instance Monoid (UniqueList x) where
     mempty = UniqueList id
-#if !(MIN_VERSION_base(4,11,0))
     mappend = (<>)
-#endif
 instance Semigroup (UniqueList x) where
     UniqueList x <> UniqueList y = UniqueList $ x . y
 
@@ -506,49 +449,34 @@ instance RenderRoute WaiSubsiteWithAuth where
 instance ParseRoute WaiSubsiteWithAuth where
   parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y
 
-data Logger = Logger
-    { loggerSet :: !LoggerSet
-    , loggerDate :: !DateCacheGetter
-    }
-
-loggerPutStr :: Logger -> LogStr -> IO ()
-loggerPutStr (Logger ls _) = pushLogStr ls
-
 -- | A handler monad for subsite
 --
 -- @since 1.6.0
-newtype SubHandlerFor sub master a = SubHandlerFor
+type SubHandlerFor sub master = RIO (SubHandlerData sub master)
-    { unSubHandlerFor :: HandlerData sub master -> IO a
-    }
-    deriving Functor
 
-instance Applicative (SubHandlerFor child master) where
+-- | Convert a concrete 'HandlerFor' action into an arbitrary other monad.
-    pure = SubHandlerFor . const . return
+liftHandler
-    (<*>) = ap
+  :: (MonadIO m, MonadReader env m, HasHandlerData env)
-instance Monad (SubHandlerFor child master) where
+  => HandlerFor (HandlerSite env) a
-    return = pure
+  -> m a
-    SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
+liftHandler action = do
-instance MonadIO (SubHandlerFor child master) where
+  shd <- view subHandlerDataL
-    liftIO = SubHandlerFor . const
+  let hd = HandlerData $ shd
-instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
+            { handlerEnv =
-    ask = SubHandlerFor return
+                let rhe = handlerEnv shd
-    local f (SubHandlerFor g) = SubHandlerFor $ g . f
+                 in rhe
+                      { rheRoute = rheRouteToMaster rhe <$> rheRoute rhe
+                      , rheChild = rheSite rhe
+                      , rheRouteToMaster = id
+                      }
+            }
+  runRIO hd action
 
--- | @since 1.4.38
+-- | Convert a concrete 'WidgetFor' action into an arbitrary other monad.
-instance MonadUnliftIO (SubHandlerFor child master) where
+liftWidget
-  {-# INLINE askUnliftIO #-}
+  :: (MonadIO m, MonadReader env m, HasWidgetData env)
-  askUnliftIO = SubHandlerFor $ \r ->
+  => WidgetFor (HandlerSite env) a
-                return (UnliftIO (flip unSubHandlerFor r))
+  -> m a
-
+liftWidget action = do
-instance MonadThrow (SubHandlerFor child master) where
+  hd <- view widgetDataL
-    throwM = liftIO . throwM
+  runRIO hd action
-
-instance MonadResource (SubHandlerFor child master) where
-    liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
-
-instance MonadLogger (SubHandlerFor child master) where
-    monadLoggerLog a b c d = SubHandlerFor $ \sd ->
-        rheLog (handlerEnv sd) a b c (toLogStr d)
-
-instance MonadLoggerIO (SubHandlerFor child master) where
-    askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv

yesod-core/src/Yesod/Core/Unsafe.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 -- | This is designed to be used as
 --
 -- > import qualified Yesod.Core.Unsafe as Unsafe
@@ -5,21 +6,21 @@
 -- This serves as a reminder that the functions are unsafe to use in many situations.
 module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where
 
+import RIO
 import Yesod.Core.Internal.Run (runFakeHandler)
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
-import Control.Monad.IO.Class (MonadIO)
 
 -- | designed to be used as
 --
 -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 fakeHandlerGetLogger :: (Yesod site, MonadIO m)
-                     => (site -> Logger)
+                     => LogFunc
                      -> site
                      -> HandlerFor site a
                      -> m a
-fakeHandlerGetLogger getLogger app f =
+fakeHandlerGetLogger logFunc app f =
-     runFakeHandler mempty getLogger app f
+     runFakeHandler mempty logFunc app f
  >>= either (error . ("runFakeHandler issue: " `mappend`) . show)
             return

yesod-core/src/Yesod/Core/Widget.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
@@ -57,8 +58,7 @@ import Text.Julius
 import Yesod.Routes.Class
 import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
 import Text.Shakespeare.I18N (RenderMessage)
-import Data.Text (Text)
+import qualified RIO.Map as Map
-import qualified Data.Map as Map
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
 
@@ -68,8 +68,8 @@ import Text.Blaze.Html (toHtml, preEscapedToMarkup)
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
 
+import RIO
 import Yesod.Core.Types
-import Yesod.Core.Class.Handler
 
 type WidgetT site (m :: * -> *) = WidgetFor site
 {-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
@@ -78,7 +78,7 @@ preEscapedLazyText :: TL.Text -> Html
 preEscapedLazyText = preEscapedToMarkup
 
 class ToWidget site a where
-    toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+    toWidget :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
 
 instance render ~ RY site => ToWidget site (render -> Html) where
     toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
@@ -115,10 +115,10 @@ class ToWidgetMedia site a where
     -- | Add the given content to the page, but only for the given media type.
     --
     -- Since 1.2
-    toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
+    toWidgetMedia :: (HasWidgetData env, HandlerSite env ~ site)
                   => Text -- ^ media value
                   -> a
-                  -> m ()
+                  -> RIO env ()
 instance render ~ RY site => ToWidgetMedia site (render -> Css) where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
 instance ToWidgetMedia site Css where
@@ -129,7 +129,7 @@ instance ToWidgetMedia site CssBuilder where
     toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
 
 class ToWidgetBody site a where
-    toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+    toWidgetBody :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
 
 instance render ~ RY site => ToWidgetBody site (render -> Html) where
     toWidgetBody = toWidget
@@ -141,7 +141,7 @@ instance ToWidgetBody site Html where
     toWidgetBody = toWidget
 
 class ToWidgetHead site a where
-    toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+    toWidgetHead :: (HasWidgetData env, HandlerSite env ~ site) => a -> RIO env ()
 
 instance render ~ RY site => ToWidgetHead site (render -> Html) where
     toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
@@ -162,59 +162,59 @@ instance ToWidgetHead site Html where
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
-setTitle :: MonadWidget m => Html -> m ()
+setTitle :: HasWidgetData env => Html -> RIO env ()
 setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
-setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
+setTitleI :: (HasWidgetData env, RenderMessage (HandlerSite env) msg) => msg -> RIO env ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
 -- | Link to the specified local stylesheet.
-addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
+addStylesheet :: HasWidgetData env => Route (HandlerSite env) -> RIO env ()
 addStylesheet = flip addStylesheetAttrs []
 
 -- | Link to the specified local stylesheet.
-addStylesheetAttrs :: MonadWidget m
+addStylesheetAttrs :: HasWidgetData env
-                   => Route (HandlerSite m)
+                   => Route (HandlerSite env)
                    -> [(Text, Text)]
-                   -> m ()
+                   -> RIO env ()
 addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemote :: MonadWidget m => Text -> m ()
+addStylesheetRemote :: HasWidgetData env => Text -> RIO env ()
 addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addStylesheetRemoteAttrs :: HasWidgetData env => Text -> [(Text, Text)] -> RIO env ()
 addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
-addStylesheetEither :: MonadWidget m
+addStylesheetEither :: HasWidgetData env
-                    => Either (Route (HandlerSite m)) Text
+                    => Either (Route (HandlerSite env)) Text
-                    -> m ()
+                    -> RIO env ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
 
-addScriptEither :: MonadWidget m
+addScriptEither :: HasWidgetData env
-                => Either (Route (HandlerSite m)) Text
+                => Either (Route (HandlerSite env)) Text
-                -> m ()
+                -> RIO env ()
 addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
-addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
+addScript :: HasWidgetData env => Route (HandlerSite env) -> RIO env ()
 addScript = flip addScriptAttrs []
 
 -- | Link to the specified local script.
-addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
+addScriptAttrs :: HasWidgetData env => Route (HandlerSite env) -> [(Text, Text)] -> RIO env ()
 addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
-addScriptRemote :: MonadWidget m => Text -> m ()
+addScriptRemote :: HasWidgetData env => Text -> RIO env ()
 addScriptRemote = flip addScriptRemoteAttrs []
 
 -- | Link to the specified remote script.
-addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addScriptRemoteAttrs :: HasWidgetData env => Text -> [(Text, Text)] -> RIO env ()
 addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 whamlet :: QuasiQuoter
@@ -247,28 +247,28 @@ rules = do
     return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
-ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
+ihamletToRepHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message)
-                 => HtmlUrlI18n message (Route (HandlerSite m))
+                 => HtmlUrlI18n message (Route (HandlerSite env))
-                 -> m Html
+                 -> RIO env Html
 ihamletToRepHtml = ihamletToHtml
 {-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
 --
 -- Since 1.2.1
-ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
+ihamletToHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message)
-              => HtmlUrlI18n message (Route (HandlerSite m))
+              => HtmlUrlI18n message (Route (HandlerSite env))
-              -> m Html
+              -> RIO env Html
 ihamletToHtml ih = do
     urender <- getUrlRenderParams
     mrender <- getMessageRender
     return $ ih (toHtml . mrender) urender
 
-tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
+tell :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env ()
 tell = liftWidget . tellWidget
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
 
 handlerToWidget :: HandlerFor site a -> WidgetFor site a
-handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
+handlerToWidget = liftHandler

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -56,7 +56,7 @@ instance Yesod App where
 
 getHomeR :: Handler Html
 getHomeR = do
-    $logDebug "Testing logging"
+    logDebug "Testing logging"
     defaultLayout $ toWidget [hamlet|
 $doctype 5
 

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -21,13 +21,13 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 getSubsite :: a -> Subsite
 getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
 
-getBarR :: MonadHandler m => m T.Text
+getBarR :: Monad m => m T.Text
 getBarR = return $ T.pack "BarR"
 
-getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
+getBazR :: (HasHandlerData env, Yesod (HandlerSite env)) => RIO env Html
 getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
 
-getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
+getBinR :: (HasHandlerData env, Yesod (HandlerSite env), SubHandlerSite env ~ Subsite) => RIO env Html
 getBinR = do
     routeToParent <- getRouteToParent
     liftHandler $ defaultLayout [whamlet|

yesod-core/yesod-core.cabal

@@ -24,7 +24,7 @@ extra-source-files:
 library
     hs-source-dirs: src
 
-    build-depends:   base                  >= 4.9      && < 5
+    build-depends:   base                  >= 4.11     && < 5
                    , aeson                 >= 1.0
                    , auto-update
                    , blaze-html            >= 0.5
@@ -41,25 +41,24 @@ library
                    , fast-logger           >= 2.2
                    , http-types            >= 0.7
                    , memory
-                   , monad-logger          >= 0.3.10   && < 0.4
                    , mtl
                    , parsec                >= 2        && < 3.2
                    , path-pieces           >= 0.1.2    && < 0.3
-                   , primitive             >= 0.6
                    , random                >= 1.0.0.2  && < 1.2
                    , resourcet             >= 1.2
-                   , rio
+                   , rio                   >= 0.1.9
+                   , rio-orphans
                    , shakespeare           >= 2.0
                    , template-haskell      >= 2.11
                    , text                  >= 0.7
                    , time                  >= 1.5
                    , transformers          >= 0.4
                    , unix-compat
-                   , unliftio
                    , unordered-containers  >= 0.2
                    , vector                >= 0.9      && < 0.13
                    , wai                   >= 3.2
                    , wai-extra             >= 3.0.7
+                   -- FIXME remove?
                    , wai-logger            >= 0.2
                    , warp                  >= 3.0.2
                    , word8
@@ -76,7 +75,6 @@ library
                      Yesod.Routes.TH.Types
     other-modules:   Yesod.Core.Internal.Session
                      Yesod.Core.Internal.Request
-                     Yesod.Core.Class.Handler
                      Yesod.Core.Internal.Util
                      Yesod.Core.Internal.Response
                      Yesod.Core.Internal.Run

yesod-eventsource/Yesod/EventSource.hs

@@ -22,7 +22,7 @@ import qualified Network.Wai.EventSource.EventStream as ES
 
 -- | (Internal) Find out the request's 'EventSourcePolyfill' and
 -- set any necessary headers.
-prepareForEventSource :: MonadHandler m => m EventSourcePolyfill
+prepareForEventSource :: HasHandlerData env => RIO env EventSourcePolyfill
 prepareForEventSource = do
   reqWith <- lookup "X-Requested-With" . W.requestHeaders Data.Functor.<$> waiRequest
   let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill

yesod-form/Yesod/Form/Bootstrap3.hs

@@ -140,7 +140,7 @@ data BootstrapFormLayout =
 -- | Render the given form using Bootstrap v3 conventions.
 --
 -- Since: yesod-form 1.3.8
-renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+renderBootstrap3 :: BootstrapFormLayout -> FormRender site a
 renderBootstrap3 formLayout aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -223,8 +223,8 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
 --
 -- Since: yesod-form 1.3.8
 bootstrapSubmit
-    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    :: RenderMessage site msg
-    => BootstrapSubmit msg -> AForm m ()
+    => BootstrapSubmit msg -> AForm site ()
 bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 
 
@@ -234,8 +234,8 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
 --
 -- Since: yesod-form 1.3.8
 mbootstrapSubmit
-    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    :: RenderMessage site msg
-    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+    => BootstrapSubmit msg -> MForm site (FormResult (), FieldView site)
 mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
     let res = FormSuccess ()
         widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]

yesod-form/Yesod/Form/Fields.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -60,11 +61,13 @@ module Yesod.Form.Fields
     , optionsEnum
     ) where
 
+import RIO
 import Yesod.Form.Types
 import Yesod.Form.I18n.English
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Core
 import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
+import Prelude (zipWith)
 #define ToHtml ToMarkup
 #define toHtml toMarkup
 #define preEscapedText preEscapedToMarkup
@@ -117,10 +120,10 @@ defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
 -- | Creates a input with @type="number"@ and @step=1@.
-intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
+intField :: (Integral i, RenderMessage site FormMessage) => Field site i
 intField = Field
     { fieldParse = parseHelper $ \s ->
-        case Data.Text.Read.signed Data.Text.Read.decimal s of
+        case Data.Text.Read.signed Data.Text.Read.decimal s of -- FIXME it overflows
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidInteger s
 
@@ -135,7 +138,7 @@ $newline never
     showI x = show (fromIntegral x :: Integer)
 
 -- | Creates a input with @type="number"@ and @step=any@.
-doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
+doubleField :: RenderMessage site FormMessage => Field site Double
 doubleField = Field
     { fieldParse = parseHelper $ \s ->
         case Data.Text.Read.double (prependZero s) of
@@ -153,7 +156,7 @@ $newline never
 -- | Creates an input with @type="date"@, validating the input using the 'parseDate' function.
 --
 -- Add the @time@ package and import the "Data.Time.Calendar" module to use this function.
-dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
+dayField :: RenderMessage site FormMessage => Field site Day
 dayField = Field
     { fieldParse = parseHelper $ parseDate . unpack
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -165,7 +168,7 @@ $newline never
   where showVal = either id (pack . show)
 
 -- | An alias for 'timeFieldTypeTime'.
-timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+timeField :: RenderMessage site FormMessage => Field site TimeOfDay
 timeField = timeFieldTypeTime
 
 -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
@@ -173,7 +176,7 @@ timeField = timeFieldTypeTime
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
 -- Since 1.4.2
-timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay  
+timeFieldTypeTime :: RenderMessage site FormMessage => Field site TimeOfDay  
 timeFieldTypeTime = timeFieldOfType "time"
 
 -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
@@ -183,10 +186,10 @@ timeFieldTypeTime = timeFieldOfType "time"
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
 -- Since 1.4.2
-timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
+timeFieldTypeText :: RenderMessage site FormMessage => Field site TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
-timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay
+timeFieldOfType :: RenderMessage site FormMessage => Text -> Field site TimeOfDay
 timeFieldOfType inputType = Field
     { fieldParse = parseHelper parseTime
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -203,7 +206,7 @@ $newline never
         fullSec = fromInteger $ floor $ todSec tod
 
 -- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags.
-htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
+htmlField :: RenderMessage site FormMessage => Field site Html
 htmlField = Field
     { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -239,7 +242,7 @@ instance ToHtml Textarea where
         writeHtmlEscapedChar c    = B.writeHtmlEscapedChar c
 
 -- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.
-textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
+textareaField :: RenderMessage site FormMessage => Field site Textarea
 textareaField = Field
     { fieldParse = parseHelper $ Right . Textarea
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@@ -250,8 +253,8 @@ $newline never
     }
 
 -- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field).
-hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
+hiddenField :: (PathPiece p, RenderMessage site FormMessage)
-            => Field m p
+            => Field site p
 hiddenField = Field
     { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@@ -262,7 +265,7 @@ $newline never
     }
 
 -- | Creates a input with @type="text"@.
-textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+textField :: RenderMessage site FormMessage => Field site Text
 textField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq ->
@@ -273,7 +276,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="password"@.
-passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+passwordField :: RenderMessage site FormMessage => Field site Text
 passwordField = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
@@ -283,15 +286,10 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 
-readMay :: Read a => String -> Maybe a
-readMay s = case filter (Prelude.null . snd) $ reads s of
-                (x, _):_ -> Just x
-                [] -> Nothing
-
 -- | Parses a 'Day' from a 'String'.
 parseDate :: String -> Either FormMessage Day
 parseDate = maybe (Left MsgInvalidDay) Right
-              . readMay . replace '/' '-'
+              . readMaybe . replace '/' '-'
 
 -- | Replaces all instances of a value in a list by another value.
 -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
@@ -299,7 +297,7 @@ replace :: Eq a => a -> a -> [a] -> [a]
 replace x y = map (\z -> if z == x then y else z)
 
 parseTime :: Text -> Either FormMessage TimeOfDay
-parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMaybe . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
 
 timeParser :: Parser TimeOfDay
 timeParser = do
@@ -331,7 +329,10 @@ timeParser = do
         x <- digit
         y <- (return Control.Applicative.<$> digit) <|> return []
         let xy = x : y
-        let i = read xy
+        let i =
+              case readMaybe xy of
+                Just i' -> i'
+                Nothing -> error $ "The impossible happened parsing: " ++ show xy
         if i < 0 || i >= 24
             then fail $ show $ MsgInvalidHour $ pack xy
             else return i
@@ -340,13 +341,16 @@ timeParser = do
         x <- digit
         y <- digit <|> fail (show $ msg $ pack [x])
         let xy = [x, y]
-        let i = read xy
+        let i =
+              case readMaybe xy of
+                Just i' -> i'
+                Nothing -> error $ "The impossible happened parsing: " ++ show xy
         if i < 0 || i >= 60
             then fail $ show $ msg $ pack xy
             else return $ fromIntegral (i :: Int)
             
 -- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
-emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+emailField :: RenderMessage site FormMessage => Field site Text
 emailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -363,7 +367,7 @@ $newline never
 -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
 -- Since 1.3.7
-multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
+multiEmailField :: RenderMessage site FormMessage => Field site [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
         \s ->
@@ -387,7 +391,7 @@ $newline never
 
 type AutoFocus = Bool
 -- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true.
-searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
+searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
 searchField autoFocus = Field
     { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
@@ -408,7 +412,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 -- | Creates an input with @type="url"@, validating the URL according to RFC3986.
-urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
+urlField :: RenderMessage site FormMessage => Field site Text
 urlField = Field
     { fieldParse = parseHelper $ \s ->
         case parseURI $ unpack s of
@@ -424,7 +428,7 @@ urlField = Field
 -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
 selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                 => [(msg, a)]
-                -> Field (HandlerFor site) a
+                -> Field site a
 selectFieldList = selectField . optionsPairs
 
 -- | Creates a @\<select>@ tag for selecting one option. Example usage:
@@ -432,7 +436,7 @@ selectFieldList = selectField . optionsPairs
 -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
 selectField :: (Eq a, RenderMessage site FormMessage)
             => HandlerFor site (OptionList a)
-            -> Field (HandlerFor site) a
+            -> Field site a
 selectField = selectFieldHelper
     (\theId name attrs inside -> [whamlet|
 $newline never
@@ -450,15 +454,15 @@ $newline never
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectFieldList :: (Eq a, RenderMessage site msg)
                      => [(msg, a)]
-                     -> Field (HandlerFor site) [a]
+                     -> Field site [a]
 multiSelectFieldList = multiSelectField . optionsPairs
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field (HandlerFor site) [a]
+                 -> Field site [a]
 multiSelectField ioptlist =
-    Field parse view UrlEncoded
+    Field parse view' UrlEncoded
   where
     parse [] _ = return $ Right Nothing
     parse optlist _ = do
@@ -467,7 +471,7 @@ multiSelectField ioptlist =
              Nothing -> return $ Left "Error parsing values"
              Just res -> return $ Right $ Just res
 
-    view theId name attrs val isReq = do
+    view' theId name attrs val isReq = do
         opts <- fmap olOptions $ handlerToWidget ioptlist
         let selOpts = map (id &&& (optselected val)) opts
         [whamlet|
@@ -482,18 +486,18 @@ multiSelectField ioptlist =
 -- | Creates an input with @type="radio"@ for selecting one option.
 radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                => [(msg, a)]
-               -> Field (HandlerFor site) a
+               -> Field site a
 radioFieldList = radioField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-                     -> Field (HandlerFor site) [a]
+                     -> Field site [a]
 checkboxesFieldList = checkboxesField . optionsPairs
 
 -- | Creates an input with @type="checkbox"@ for selecting multiple options.
 checkboxesField :: Eq a
                  => HandlerFor site (OptionList a)
-                 -> Field (HandlerFor site) [a]
+                 -> Field site [a]
 checkboxesField ioptlist = (multiSelectField ioptlist)
     { fieldView =
         \theId name attrs val _isReq -> do
@@ -511,7 +515,7 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
 -- | Creates an input with @type="radio"@ for selecting one option.
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
-           -> Field (HandlerFor site) a
+           -> Field site a
 radioField = selectFieldHelper
     (\theId _name _attrs inside -> [whamlet|
 $newline never
@@ -539,7 +543,7 @@ $newline never
 -- If this field is required, the first radio button is labeled \"Yes" and the second \"No". 
 --
 -- (Exact label titles will depend on localization).
-boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
+boolField :: RenderMessage site FormMessage => Field site Bool
 boolField = Field
       { fieldParse = \e _ -> return $ boolParser e
       , fieldView = \theId name attrs val isReq -> [whamlet|
@@ -578,7 +582,7 @@ $newline never
 --
 --   Note that this makes the field always optional.
 --
-checkBoxField :: Monad m => Field m Bool
+checkBoxField :: Field site Bool
 checkBoxField = Field
     { fieldParse = \e _ -> return $ checkBoxParser e
     , fieldView  = \theId name attrs val _ -> [whamlet|
@@ -623,22 +627,21 @@ data Option a = Option
 
 -- | Since 1.4.6
 instance Functor Option where
-    fmap f (Option display internal external) = Option display (f internal) external
+    fmap f (Option display' internal external) = Option display' (f internal) external
 
 -- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
-optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
+optionsPairs :: RenderMessage site msg => [(msg, a)] -> HandlerFor site (OptionList a)
-             => [(msg, a)] -> m (OptionList a)
 optionsPairs opts = do
   mr <- getMessageRender
-  let mkOption external (display, internal) =
+  let mkOption external (display', internal) =
-          Option { optionDisplay       = mr display
+          Option { optionDisplay       = mr display'
                  , optionInternalValue = internal
                  , optionExternalValue = pack $ show external
                  }
   return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
 
 -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
-optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
+optionsEnum :: (Show a, Enum a, Bounded a) => HandlerFor site (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 -- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage:
@@ -656,33 +659,22 @@ optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 -- >         <$> areq (selectField countries) "Which country do you live in?" Nothing
 -- >         where
 -- >           countries = optionsPersist [] [Asc CountryName] countryName
-#if MIN_VERSION_persistent(2,5,0)
 optionsPersist :: ( YesodPersist site
                   , PersistQueryRead backend
                   , PathPiece (Key a)
                   , RenderMessage site msg
                   , YesodPersistBackend site ~ backend
                   , PersistRecordBackend a backend
+                  , site ~ HandlerSite env
+                  , HasHandlerData env
                   )
                => [Filter a]
                -> [SelectOpt a]
                -> (a -> msg)
-               -> HandlerFor site (OptionList (Entity a))
+               -> RIO env (OptionList (Entity a))
-#else
-optionsPersist :: ( YesodPersist site, PersistEntity a
-                  , PersistQuery (PersistEntityBackend a)
-                  , PathPiece (Key a)
-                  , RenderMessage site msg
-                  , YesodPersistBackend site ~ PersistEntityBackend a
-                  )
-               => [Filter a]
-               -> [SelectOpt a]
-               -> (a -> msg)
-               -> HandlerFor site (OptionList (Entity a))
-#endif
 optionsPersist filts ords toDisplay = fmap mkOptionList $ do
     mr <- getMessageRender
-    pairs <- runDB $ selectList filts ords
+    pairs <- liftHandler $ runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
         { optionDisplay = mr (toDisplay value)
         , optionInternalValue = Entity key value
@@ -693,35 +685,21 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
 -- the entire 'Entity'.
 --
 -- Since 1.3.2
-#if MIN_VERSION_persistent(2,5,0)
 optionsPersistKey
-  :: (YesodPersist site
+  :: ( YesodPersist site
      , PersistQueryRead backend
      , PathPiece (Key a)
      , RenderMessage site msg
      , backend ~ YesodPersistBackend site
+     , site ~ HandlerSite env
      , PersistRecordBackend a backend
+     , HasHandlerData env
      )
   => [Filter a]
   -> [SelectOpt a]
   -> (a -> msg)
-  -> HandlerFor site (OptionList (Key a))
+  -> RIO env (OptionList (Key a))
-#else
+optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
-optionsPersistKey
-  :: (YesodPersist site
-     , PersistEntity a
-     , PersistQuery (PersistEntityBackend a)
-     , PathPiece (Key a)
-     , RenderMessage site msg
-     , YesodPersistBackend site ~ PersistEntityBackend a
-     )
-  => [Filter a]
-  -> [SelectOpt a]
-  -> (a -> msg)
-  -> HandlerFor site (OptionList (Key a))
-#endif
-
-optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
     mr <- getMessageRender
     pairs <- runDB $ selectList filts ords
     return $ map (\(Entity key value) -> Option
@@ -740,7 +718,7 @@ selectFieldHelper
         -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
         -> HandlerFor site (OptionList a)
-        -> Field (HandlerFor site) a
+        -> Field site a
 selectFieldHelper outside onOpt inside opts' = Field
     { fieldParse = \x _ -> do
         opts <- opts'
@@ -770,8 +748,7 @@ selectFieldHelper outside onOpt inside opts' = Field
                     Just y -> Right $ Just y
 
 -- | Creates an input with @type="file"@.
-fileField :: Monad m
+fileField :: Field site FileInfo
-          => Field m FileInfo
 fileField = Field
     { fieldParse = \_ files -> return $
         case files of
@@ -783,18 +760,23 @@ fileField = Field
     , fieldEnctype = Multipart
     }
 
-fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
+fileAFormReq :: RenderMessage site FormMessage
-             => FieldSettings (HandlerSite m) -> AForm m FileInfo
+             => FieldSettings site -> AForm site FileInfo
-fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
+fileAFormReq fs = AForm $ do
+    site <- getYesod
+    langs <- reqLangs <$> getRequest
+    WFormData viewsDeque mfd <- view id
+    ints <- readIORef $ mfdInts mfd
     let (name, ints') =
             case fsName fs of
                 Just x -> (x, ints)
                 Nothing ->
                     let i' = incrInts ints
                      in (pack $ 'f' : show i', i')
+    writeIORef (mfdInts mfd) ints'
     id' <- maybe newIdent return $ fsId fs
     let (res, errs) =
-            case menvs of
+            case mfdParams mfd of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -813,21 +795,26 @@ $newline never
             , fvErrors = errs
             , fvRequired = True
             }
-    return (res, (fv :), ints', Multipart)
+    writeIORef (mfdEnctype mfd) Multipart
+    pushBackDeque viewsDeque fv
+    return res
 
-fileAFormOpt :: MonadHandler m
+fileAFormOpt :: FieldSettings site -> AForm site (Maybe FileInfo)
-             => FieldSettings (HandlerSite m)
+fileAFormOpt fs = AForm $ do
-             -> AForm m (Maybe FileInfo)
+    master <- getYesod
-fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
+    langs <- reqLangs <$> getRequest
+    WFormData viewsDeque mfd <- view id
+    ints <- readIORef $ mfdInts mfd
     let (name, ints') =
             case fsName fs of
                 Just x -> (x, ints)
                 Nothing ->
                     let i' = incrInts ints
                      in (pack $ 'f' : show i', i')
+    writeIORef (mfdInts mfd) ints'
     id' <- maybe newIdent return $ fsId fs
     let (res, errs) =
-            case menvs of
+            case mfdParams mfd of
                 Nothing -> (FormMissing, Nothing)
                 Just (_, fenv) ->
                     case Map.lookup name fenv of
@@ -844,7 +831,9 @@ $newline never
             , fvErrors = errs
             , fvRequired = False
             }
-    return (res, (fv :), ints', Multipart)
+    writeIORef (mfdEnctype mfd) Multipart
+    pushBackDeque viewsDeque fv
+    return res
 
 incrInts :: Ints -> Ints
 incrInts (IntSingle i) = IntSingle $ i + 1

yesod-form/Yesod/Form/Functions.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -38,7 +39,6 @@ module Yesod.Form.Functions
     , renderTable
     , renderDivs
     , renderDivsNoLabels
-    , renderBootstrap
     , renderBootstrap2
       -- * Validation
     , check
@@ -55,13 +55,12 @@ module Yesod.Form.Functions
     , removeClass
     ) where
 
+import RIO hiding (ask, local)
 import Yesod.Form.Types
+import Yesod.Core.Types (liftHandler)
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import Control.Arrow (second)
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
-import Control.Monad.Trans.Writer (runWriterT, writer)
 import Control.Monad (liftM, join)
 import Data.Byteable (constEqBytes)
 import Text.Blaze (Markup, toMarkup)
@@ -75,8 +74,28 @@ import qualified Data.Map as Map
 import qualified Data.Text.Encoding as TE
 import Control.Arrow (first)
 
+get :: MForm site Ints
+get = view (to mfdInts) >>= readIORef
+
+put :: Ints -> MForm site ()
+put ints = view (to mfdInts) >>= (`writeIORef` ints)
+
+tell :: Enctype -> MForm site ()
+tell ec = view (to mfdEnctype) >>= (`writeIORef` ec)
+
+local
+  :: ( Maybe (Env, FileEnv)
+    -> Maybe (Env, FileEnv)
+     )
+  -> MForm site a
+  -> MForm site a
+local f inner = do
+  mfd <- view id
+  let mfd' = mfd { mfdParams = f $ mfdParams mfd }
+  runRIO mfd' inner
+
 -- | Get a unique identifier.
-newFormIdent :: Monad m => MForm m Text
+newFormIdent :: MForm site Text
 newFormIdent = do
     i <- get
     let i' = incrInts i
@@ -86,43 +105,34 @@ newFormIdent = do
     incrInts (IntSingle i) = IntSingle $ i + 1
     incrInts (IntCons i is) = (i + 1) `IntCons` is
 
-formToAForm :: (HandlerSite m ~ site, Monad m)
+formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a
-            => MForm m (FormResult a, [FieldView site])
+formToAForm mform = AForm $ do
-            -> AForm m a
+  WFormData viewsDeque mfd <- view id
-formToAForm form = AForm $ \(site, langs) env ints -> do
+  (a, views) <- runRIO mfd mform
-    ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints
+  for_ views $ pushBackDeque viewsDeque
-    return (a, (++) xmls, ints', enc)
+  pure a
 
-aFormToForm :: (Monad m, HandlerSite m ~ site)
+aFormToForm :: AForm site a
-            => AForm m a
+            -> MForm site (FormResult a, [FieldView site] -> [FieldView site])
-            -> MForm m (FormResult a, [FieldView site] -> [FieldView site])
+aFormToForm (AForm wform) = do
-aFormToForm (AForm aform) = do
+    (res, views) <- wFormToMForm wform
-    ints <- get
+    pure (res, (views++))
-    (env, site, langs) <- ask
-    (a, xml, ints', enc) <- lift $ aform (site, langs) env ints
-    put ints'
-    tell enc
-    return (a, xml)
 
-askParams :: Monad m => MForm m (Maybe Env)
+askParams :: MForm site (Maybe Env)
-askParams = do
+askParams = view $ to (fmap fst . mfdParams)
-    (x, _, _) <- ask
-    return $ liftM fst x
 
-askFiles :: Monad m => MForm m (Maybe FileEnv)
+askFiles :: MForm site (Maybe FileEnv)
-askFiles = do
+askFiles = view $ to (fmap snd . mfdParams)
-    (x, _, _) <- ask
-    return $ liftM snd x
 
 -- | Converts a form field into monadic form 'WForm'. This field requires a
 -- value and will return 'FormFailure' if left empty.
 --
 -- @since 1.4.14
-wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+wreq :: RenderMessage site FormMessage
-     => Field m a           -- ^ form field
+     => Field site a        -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> WForm m (FormResult a)
+     -> WForm site (FormResult a)
 wreq f fs = mFormToWForm . mreq f fs
 
 -- | Converts a form field into monadic form 'WForm'. This field is optional,
@@ -131,75 +141,78 @@ wreq f fs = mFormToWForm . mreq f fs
 -- value).
 --
 -- @since 1.4.14
-wopt :: (MonadHandler m, HandlerSite m ~ site)
+wopt :: Field site a        -- ^ form field
-     => Field m a           -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe (Maybe a)     -- ^ optional default value
-     -> WForm m (FormResult (Maybe a))
+     -> WForm site (FormResult (Maybe a))
 wopt f fs = mFormToWForm . mopt f fs
 
 -- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
 --
 -- @since 1.4.14
-wFormToAForm :: MonadHandler m
+wFormToAForm
-             => WForm m (FormResult a)  -- ^ input form
+  :: WForm site (FormResult a)  -- ^ input form
-             -> AForm m a               -- ^ output form
+  -> AForm site a               -- ^ output form
 wFormToAForm = formToAForm . wFormToMForm
 
 -- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
 --
 -- @since 1.4.14
-wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
+wFormToMForm
-             => WForm m a                      -- ^ input form
+  :: WForm site a                      -- ^ input form
-             -> MForm m (a, [FieldView site])  -- ^ output form
+  -> MForm site (a, [FieldView site])  -- ^ output form
-wFormToMForm = mapRWST (fmap group . runWriterT)
+wFormToMForm wform = do
-  where
+  viewsDeque <- newDeque
-    group ((a, ints, enctype), views) = ((a, views), ints, enctype)
+  mfd <- view id
+  a <- runRIO (WFormData viewsDeque mfd) wform
+  views <- dequeToList viewsDeque
+  pure (a, views)
 
 -- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
 --
 -- @since 1.4.14
-mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
+mFormToWForm
-             => MForm m (a, FieldView site)  -- ^ input form
+  :: MForm site (a, FieldView site)  -- ^ input form
-             -> WForm m a                    -- ^ output form
+  -> WForm site a                    -- ^ output form
-mFormToWForm = mapRWST $ \f -> do
+mFormToWForm mform = do
-  ((a, view), ints, enctype) <- lift f
+  WFormData viewsDeque mfd <- view id
-  writer ((a, ints, enctype), [view])
+  (a, view') <- runRIO mfd mform
+  pushBackDeque viewsDeque view'
+  pure a
 
 -- | Converts a form field into monadic form. This field requires a value
 -- and will return 'FormFailure' if left empty.
-mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+mreq :: RenderMessage site FormMessage
-     => Field m a           -- ^ form field
+     => Field site a         -- ^ form field
      -> FieldSettings site  -- ^ settings for this field
      -> Maybe a             -- ^ optional default value
-     -> MForm m (FormResult a, FieldView site)
+     -> MForm site (FormResult a, FieldView site)
 mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
 -- | Converts a form field into monadic form. This field is optional, i.e.
 -- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
 -- Arguments are the same as for 'mreq' (apart from type of default value).
-mopt :: (site ~ HandlerSite m, MonadHandler m)
+mopt :: Field site a
-     => Field m a
      -> FieldSettings site
      -> Maybe (Maybe a)
-     -> MForm m (FormResult (Maybe a), FieldView site)
+     -> MForm site (FormResult (Maybe a), FieldView site)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
-mhelper :: (site ~ HandlerSite m, MonadHandler m)
+mhelper :: Field site a
-        => Field m a
         -> FieldSettings site
         -> Maybe a
         -> (site -> [Text] -> FormResult b) -- ^ on missing
         -> (a -> FormResult b) -- ^ on success
         -> Bool -- ^ is it required?
-        -> MForm m (FormResult b, FieldView site)
+        -> MForm site (FormResult b, FieldView site)
 
 mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     tell fieldEnctype
     mp <- askParams
     name <- maybe newFormIdent return fsName
-    theId <- lift $ maybe newIdent return fsId
+    theId <- maybe newIdent return fsId
-    (_, site, langs) <- ask
+    site <- getYesod
+    langs <- reqLangs <$> getRequest
     let mr2 = renderMessage site langs
     (res, val) <-
         case mp of
@@ -208,7 +221,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
                 mfs <- askFiles
                 let mvals = fromMaybe [] $ Map.lookup name p
                     files = fromMaybe [] $ mfs >>= Map.lookup name
-                emx <- lift $ fieldParse mvals files
+                emx <- liftHandler $ fieldParse mvals files
                 return $ case emx of
                     Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
                     Right mx ->
@@ -228,28 +241,37 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         })
 
 -- | Applicative equivalent of 'mreq'.
-areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+areq :: RenderMessage site FormMessage
-     => Field m a
+     => Field site a
      -> FieldSettings site
      -> Maybe a
-     -> AForm m a
+     -> AForm site a
 areq a b = formToAForm . liftM (second return) . mreq a b
 
 -- | Applicative equivalent of 'mopt'.
-aopt :: MonadHandler m
+aopt :: Field site a
-     => Field m a
+     -> FieldSettings site
-     -> FieldSettings (HandlerSite m)
      -> Maybe (Maybe a)
-     -> AForm m (Maybe a)
+     -> AForm site (Maybe a)
 aopt a b = formToAForm . liftM (second return) . mopt a b
 
-runFormGeneric :: Monad m
+runFormGeneric
-               => MForm m a
+  :: HasHandlerData env
-               -> HandlerSite m
+  => MForm (HandlerSite env) a
-               -> [Text]
+  -> Maybe (Env, FileEnv)
-               -> Maybe (Env, FileEnv)
+  -> RIO env (a, Enctype)
-               -> m (a, Enctype)
+runFormGeneric mform params = do
-runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
+  hd <- liftHandler $ view subHandlerDataL
+  enctypeRef <- newIORef mempty
+  intsRef <- newIORef $! IntSingle 0
+  let mfd = MFormData
+        { mfdHandlerData = hd
+        , mfdEnctype = enctypeRef
+        , mfdParams = params
+        , mfdInts = intsRef
+        }
+  a <- runRIO mfd mform
+  (,) a <$> readIORef enctypeRef
 
 -- | This function is used to both initially render a form and to later extract
 -- results from it. Note that, due to CSRF protection and a few other issues,
@@ -260,17 +282,19 @@ runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle
 -- For example, a common case is displaying a form on a GET request and having
 -- the form submit to a POST page. In such a case, both the GET and POST
 -- handlers should use 'runFormPost'.
-runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
+runFormPost
-            => (Html -> MForm m (FormResult a, xml))
+  :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
-            -> m ((FormResult a, xml), Enctype)
+  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
+  -> RIO env ((FormResult a, xml), Enctype)
 runFormPost form = do
     env <- postEnv
     postHelper form env
 
-postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
+postHelper
-            => (Html -> MForm m (FormResult a, xml))
+  :: (HasHandlerData env, RenderMessage (HandlerSite env) FormMessage)
-            -> Maybe (Env, FileEnv)
+  => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-            -> m ((FormResult a, xml), Enctype)
+  -> Maybe (Env, FileEnv)
+  -> RIO env ((FormResult a, xml), Enctype)
 postHelper form env = do
     req <- getRequest
     let tokenKey = defaultCsrfParamName
@@ -278,15 +302,14 @@ postHelper form env = do
             case reqToken req of
                 Nothing -> Data.Monoid.mempty
                 Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
-    m <- getYesod
+    ((res, xml), enctype) <- runFormGeneric (form token) env
-    langs <- languages
+    site <- getYesod
-    ((res, xml), enctype) <- runFormGeneric (form token) m langs env
     let res' =
             case (res, env) of
                 (_, Nothing) -> FormMissing
                 (FormSuccess{}, Just (params, _))
                     | not (Map.lookup tokenKey params === reqToken req) ->
-                        FormFailure [renderMessage m langs MsgCsrfWarning]
+                        FormFailure [renderMessage site (reqLangs req) MsgCsrfWarning]
                 _ -> res
             -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
             where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
@@ -299,12 +322,12 @@ postHelper form env = do
 -- page will both receive and incoming form and produce a new, blank form. For
 -- general usage, you can stick with @runFormPost@.
 generateFormPost
-    :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
+    :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
-    => (Html -> MForm m (FormResult a, xml))
+    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-    -> m (xml, Enctype)
+    -> RIO env (xml, Enctype)
 generateFormPost form = first snd `liftM` postHelper form Nothing
 
-postEnv :: MonadHandler m => m (Maybe (Env, FileEnv))
+postEnv :: HasHandlerData env => RIO env (Maybe (Env, FileEnv))
 postEnv = do
     req <- getRequest
     if requestMethod (reqWaiRequest req) == "GET"
@@ -314,18 +337,16 @@ postEnv = do
             let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
             return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
 
-runFormPostNoToken :: MonadHandler m
+runFormPostNoToken :: HasHandlerData env
-                   => (Html -> MForm m a)
+                   => (Html -> MForm (HandlerSite env) a)
-                   -> m (a, Enctype)
+                   -> RIO env (a, Enctype)
 runFormPostNoToken form = do
-    langs <- languages
+    params <- postEnv
-    m <- getYesod
+    runFormGeneric (form mempty) params
-    env <- postEnv
-    runFormGeneric (form mempty) m langs env
 
-runFormGet :: MonadHandler m
+runFormGet :: HasHandlerData env
-           => (Html -> MForm m a)
+           => (Html -> MForm (HandlerSite env) a)
-           -> m (a, Enctype)
+           -> RIO env (a, Enctype)
 runFormGet form = do
     gets <- liftM reqGetParams getRequest
     let env =
@@ -339,29 +360,27 @@ runFormGet form = do
 --
 -- Since 1.3.11
 generateFormGet'
-    :: MonadHandler m
+    :: HasHandlerData env
-    => (Html -> MForm m (FormResult a, xml))
+    => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-    -> m (xml, Enctype)
+    -> RIO env (xml, Enctype)
 generateFormGet' form = first snd `liftM` getHelper form Nothing
 
 {-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
-generateFormGet :: MonadHandler m
+generateFormGet :: HasHandlerData env
-                => (Html -> MForm m a)
+                => (Html -> MForm (HandlerSite env) a)
-                -> m (a, Enctype)
+                -> RIO env (a, Enctype)
 generateFormGet form = getHelper form Nothing
 
 getKey :: Text
 getKey = "_hasdata"
 
-getHelper :: MonadHandler m
+getHelper :: HasHandlerData env
-          => (Html -> MForm m a)
+          => (Html -> MForm (HandlerSite env) a)
           -> Maybe (Env, FileEnv)
-          -> m (a, Enctype)
+          -> RIO env (a, Enctype)
-getHelper form env = do
+getHelper form params = do
     let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
-    langs <- languages
+    runFormGeneric (form fragment) params
-    m <- getYesod
-    runFormGeneric (form fragment) m langs env
 
 
 -- | Creates a hidden field on the form that identifies it.  This
@@ -386,10 +405,9 @@ getHelper form env = do
 -- even if their number or order change between the HTML
 -- generation and the form submission.
 identifyForm
-  :: Monad m
+  :: Text -- ^ Form identification string.
-  => Text -- ^ Form identification string.
+  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
-  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
+  -> (Html -> MForm site (FormResult a, WidgetFor site ()))
-  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
 identifyForm identVal form = \fragment -> do
     -- Create hidden <input>.
     let fragment' =
@@ -406,7 +424,7 @@ identifyForm identVal form = \fragment -> do
     -- data is missing, then do not provide any params to the
     -- form, which will turn its result into FormMissing.  Also,
     -- doing this avoids having lots of fields with red errors.
-    let eraseParams | missing   = local (\(_, h, l) -> (Nothing, h, l))
+    let eraseParams | missing   = local (const Nothing)
                     | otherwise = id
     ( res', w) <- eraseParams (form fragment')
 
@@ -418,12 +436,12 @@ identifyFormKey :: Text
 identifyFormKey = "_formid"
 
 
-type FormRender m a =
+type FormRender site a =
-       AForm m a
+       AForm site a
     -> Html
-    -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
+    -> MForm site (FormResult a, WidgetFor site ())
 
-renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
+renderTable, renderDivs, renderDivsNoLabels :: FormRender env a
 -- | Render a form into a series of tr tags. Note that, in order to allow
 -- you to add extra rows to the table, this function does /not/ wrap up
 -- the resulting HTML in a table tag; you must do that yourself.
@@ -457,7 +475,7 @@ renderDivs = renderDivsMaybeLabels True
 -- | render a field inside a div, not displaying any label
 renderDivsNoLabels = renderDivsMaybeLabels False
 
-renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
+renderDivsMaybeLabels :: Bool -> FormRender env a
 renderDivsMaybeLabels withLabels aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -495,7 +513,7 @@ $forall view <- views
 -- >        <input .btn .primary type=submit value=_{MsgSubmit}>
 --
 -- Since 1.3.14
-renderBootstrap2 :: Monad m => FormRender m a
+renderBootstrap2 :: FormRender env a
 renderBootstrap2 aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
@@ -516,26 +534,21 @@ renderBootstrap2 aform fragment = do
                 |]
     return (res, widget)
 
--- | Deprecated synonym for 'renderBootstrap2'.
+check :: RenderMessage site msg
-renderBootstrap :: Monad m => FormRender m a
-renderBootstrap = renderBootstrap2
-{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
-
-check :: (Monad m, RenderMessage (HandlerSite m) msg)
       => (a -> Either msg a)
-      -> Field m a
+      -> Field site a
-      -> Field m a
+      -> Field site a
 check f = checkM $ return . f
 
 -- | Return the given error message if the predicate is false.
-checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
+checkBool :: RenderMessage site msg
-          => (a -> Bool) -> msg -> Field m a -> Field m a
+          => (a -> Bool) -> msg -> Field site a -> Field site a
 checkBool b s = check $ \x -> if b x then Right x else Left s
 
-checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
+checkM :: RenderMessage site msg
-       => (a -> m (Either msg a))
+       => (a -> HandlerFor site (Either msg a))
-       -> Field m a
+       -> Field site a
-       -> Field m a
+       -> Field site a
 checkM f = checkMMap f id
 
 -- | Same as 'checkM', but modifies the datatype.
@@ -544,11 +557,11 @@ checkM f = checkMMap f id
 -- the new datatype to the old one (the second argument to this function).
 --
 -- Since 1.1.2
-checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
+checkMMap :: RenderMessage site msg
-          => (a -> m (Either msg b))
+          => (a -> HandlerFor site (Either msg b))
           -> (b -> a)
-          -> Field m a
+          -> Field site a
-          -> Field m b
+          -> Field site b
 checkMMap f inv field = field
     { fieldParse = \ts fs -> do
         e1 <- fieldParse field ts fs
@@ -560,7 +573,7 @@ checkMMap f inv field = field
     }
 
 -- | Allows you to overwrite the error message on parse error.
-customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a
+customErrorMessage :: SomeMessage site -> Field site a -> Field site a
 customErrorMessage msg field = field
     { fieldParse = \ts fs ->
         liftM (either (const $ Left msg) Right)
@@ -611,11 +624,10 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
 -- > lazyTextField = convertField TL.fromStrict TL.toStrict textField
 --
 -- Since 1.3.16
-convertField :: (Functor m)
+convertField :: (a -> b) -> (b -> a)
-             => (a -> b) -> (b -> a)
+             -> Field env a -> Field env b
-             -> Field m a -> Field m b
+convertField to' from (Field fParse fView fEnctype) = let
-convertField to from (Field fParse fView fEnctype) = let
+  fParse' ts = fmap (fmap (fmap to')) . fParse ts
-  fParse' ts = fmap (fmap (fmap to)) . fParse ts
   fView' ti tn at ei = fView ti tn at (fmap from ei)
   in Field fParse' fView' fEnctype
 

yesod-form/Yesod/Form/Input.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 -- | Provides for getting input from either GET or POST params without
@@ -26,14 +27,13 @@ type DText = [Text] -> [Text]
 
 -- | Type for a form which parses a value of type @a@ with the base monad @m@
 -- (usually your @Handler@). Can compose this using its @Applicative@ instance.
-newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
+newtype FormInput site a = FormInput { unFormInput :: Env -> FileEnv -> HandlerFor site (Either DText a) }
-instance Monad m => Functor (FormInput m) where
+  deriving Functor
-    fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'
+instance Control.Applicative.Applicative (FormInput site) where
-instance Monad m => Control.Applicative.Applicative (FormInput m) where
+    pure x = FormInput $ \_env _filenv -> pure $ Right x
-    pure = FormInput . const . const . const . const . return . Right
+    (FormInput f) <*> (FormInput x) = FormInput $ \env fileEnv -> do
-    (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do
+        res1 <- f env fileEnv
-        res1 <- f c d e e'
+        res2 <- x env fileEnv
-        res2 <- x c d e e'
         return $ case (res1, res2) of
             (Left a, Left b) -> Left $ a . b
             (Left a, _) -> Left a
@@ -42,14 +42,16 @@ instance Monad m => Control.Applicative.Applicative (FormInput m) where
 
 -- | Promote a @Field@ into a @FormInput@, requiring that the value be present
 -- and valid.
-ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)
+ireq :: RenderMessage site FormMessage
-     => Field m a
+     => Field site a
      -> Text -- ^ name of the field
-     -> FormInput m a
+     -> FormInput site a
-ireq field name = FormInput $ \m l env fenv -> do
+ireq field name = FormInput $ \env fenv -> do
       let filteredEnv = fromMaybe [] $ Map.lookup name env
           filteredFEnv = fromMaybe [] $ Map.lookup name fenv
       emx <- fieldParse field filteredEnv filteredFEnv
+      m <- getYesod
+      l <- reqLangs <$> getRequest
       return $ case emx of
           Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
           Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
@@ -57,33 +59,34 @@ ireq field name = FormInput $ \m l env fenv -> do
 
 -- | Promote a @Field@ into a @FormInput@, with its presence being optional. If
 -- the value is present but does not parse correctly, the form will still fail.
-iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a)
+iopt :: Field site a -> Text -> FormInput site (Maybe a)
-iopt field name = FormInput $ \m l env fenv -> do
+iopt field name = FormInput $ \env fenv -> do
       let filteredEnv = fromMaybe [] $ Map.lookup name env
           filteredFEnv = fromMaybe [] $ Map.lookup name fenv
       emx <- fieldParse field filteredEnv filteredFEnv
-      return $ case emx of
+      case emx of
-        Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
+        Left (SomeMessage e) -> do
-        Right x -> Right x
+            site <- getYesod
+            l <- reqLangs <$> getRequest
+            pure $ Left $ (:) $ renderMessage site l e
+        Right x -> pure $ Right x
 
 -- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing
 -- fails, calls 'invalidArgs'.
-runInputGet :: MonadHandler m => FormInput m a -> m a
+runInputGet :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
 runInputGet = either invalidArgs return <=< runInputGetHelper
 
 -- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/
 -- throw exceptions on failure.
 --
 -- Since 1.4.1
-runInputGetResult :: MonadHandler m => FormInput m a -> m (FormResult a)
+runInputGetResult :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
 runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper
 
-runInputGetHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
+runInputGetHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
 runInputGetHelper (FormInput f) = do
     env <- liftM (toMap . reqGetParams) getRequest
-    m <- getYesod
+    emx <- liftHandler $ f env Map.empty
-    l <- languages
-    emx <- f m l env Map.empty
     return $ either (Left . ($ [])) Right emx
 
 toMap :: [(Text, a)] -> Map.Map Text [a]
@@ -91,17 +94,15 @@ toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
 
 -- | Run a @FormInput@ on the POST parameters (i.e., request body). If parsing
 -- fails, calls 'invalidArgs'.
-runInputPost :: MonadHandler m => FormInput m a -> m a
+runInputPost :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
 runInputPost = either invalidArgs return <=< runInputPostHelper
 
 -- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/
 -- throw exceptions on failure.
-runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
+runInputPostResult :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
 runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper
 
-runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
+runInputPostHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
-runInputPostHelper (FormInput f) = do
+runInputPostHelper (FormInput f) = liftHandler $ do
     (env, fenv) <- liftM (toMap *** toMap) runRequestBody
-    m <- getYesod
+    fmap (either (Left . ($ [])) Right) $ f env fenv
-    l <- languages
-    fmap (either (Left . ($ [])) Right) $ f m l env fenv

yesod-form/Yesod/Form/Jquery.hs

@@ -53,16 +53,16 @@ class YesodJquery a where
     urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
     urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
 
-jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
+jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day
 jqueryDayField = flip jqueryDayField' "date"
 
 -- | Use jQuery's datepicker as the underlying implementation.
 --
 -- Since 1.4.3
-jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
+jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day
 jqueryDatePickerDayField = flip jqueryDayField' "text"
 
-jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day
+jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field site Day
 jqueryDayField' jds inputType = Field
     { fieldParse = parseHelper $ maybe
                   (Left MsgInvalidDay)
@@ -107,13 +107,13 @@ $(function(){
         ]
 
 jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
-                        => Route site -> Field (HandlerFor site) Text
+                        => Route site -> Field site Text
 jqueryAutocompleteField = jqueryAutocompleteField' 2
 
 jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
                          => Int -- ^ autocomplete minimum length
                          -> Route site
-                         -> Field (HandlerFor site) Text
+                         -> Field site Text
 jqueryAutocompleteField' minLen src = Field
     { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq -> do
@@ -130,14 +130,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:#{toJS
     , fieldEnctype = UrlEncoded
     }
 
-addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m ()
+addScript' :: (site -> Either (Route site) Text) -> WidgetFor site ()
 addScript' f = do
     y <- getYesod
     addScriptEither $ f y
 
-addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)
+addStylesheet' :: (HasWidgetData env, HandlerSite env ~ site)
                => (site -> Either (Route site) Text)
-               -> m ()
+               -> RIO env ()
 addStylesheet' f = do
     y <- getYesod
     addStylesheetEither $ f y

yesod-form/Yesod/Form/MassInput.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -11,11 +12,11 @@ module Yesod.Form.MassInput
     , massTable
     ) where
 
+import RIO
 import Yesod.Form.Types
 import Yesod.Form.Functions
 import Yesod.Form.Fields (checkBoxField)
 import Yesod.Core
-import Control.Monad.Trans.RWS (get, put, ask)
 import Data.Maybe (fromMaybe)
 import Data.Text.Read (decimal)
 import Control.Monad (liftM)
@@ -24,43 +25,45 @@ import Data.Traversable (sequenceA)
 import qualified Data.Map as Map
 import Data.Maybe (listToMaybe)
 
-down :: Monad m => Int -> MForm m ()
+down :: Int -> MForm site ()
 down 0 = return ()
 down i | i < 0 = error "called down with a negative number"
 down i = do
-    is <- get
+    ref <- view $ to mfdInts
-    put $ IntCons 0 is
+    is <- readIORef ref
+    writeIORef ref $ IntCons 0 is
     down $ i - 1
 
-up :: Monad m => Int -> MForm m ()
+up :: Int -> MForm site ()
 up 0 = return ()
 up i | i < 0 = error "called down with a negative number"
 up i = do
-    is <- get
+    ref <- view $ to mfdInts
+    is <- readIORef ref
     case is of
         IntSingle _ -> error "up on IntSingle"
-        IntCons _ is' -> put is' >> newFormIdent >> return ()
+        IntCons _ is' -> writeIORef ref is' >> newFormIdent >> return ()
     up $ i - 1
 
 -- | Generate a form that accepts 0 or more values from the user, allowing the
 -- user to specify that a new row is necessary.
-inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
+inputList :: RenderMessage site FormMessage
           => Html
           -- ^ label for the form
-          -> ([[FieldView site]] -> xml)
+          -> ([[FieldView site]] -> WidgetFor site ())
           -- ^ how to display the rows, usually either 'massDivs' or 'massTable'
-          -> (Maybe a -> AForm (HandlerFor site) a)
+          -> (Maybe a -> AForm site a)
           -- ^ display a single row of the form, where @Maybe a@ gives the
           -- previously submitted value
           -> Maybe [a]
           -- ^ default initial values for the form
-          -> AForm (HandlerFor site) [a]
+          -> AForm site [a]
 inputList label fixXml single mdef = formToAForm $ do
-    theId <- lift newIdent
+    theId <- newIdent
     down 1
     countName <- newFormIdent
     addName <- newFormIdent
-    (menv, _, _) <- ask
+    menv <- view $ to mfdParams
     let readInt t =
             case decimal t of
                 Right (i, "") -> Just i
@@ -94,13 +97,13 @@ $newline never
         , fvRequired = False
         }])
 
-withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
+withDelete :: RenderMessage site FormMessage
-           => AForm (HandlerFor site) a
+           => AForm site a
-           -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
+           -> MForm site (Either (WidgetFor site ())(FormResult a, [FieldView site]))
 withDelete af = do
     down 1
     deleteName <- newFormIdent
-    (menv, _, _) <- ask
+    menv <- view $ to mfdParams
     res <- case menv >>= Map.lookup deleteName . fst of
         Just ("yes":_) -> return $ Left [whamlet|
 $newline never

yesod-form/Yesod/Form/Nic.hs

@@ -29,7 +29,7 @@ class Yesod a => YesodNic a where
     urlNicEdit :: a -> Either (Route a) Text
     urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
 
-nicHtmlField :: YesodNic site => Field (HandlerFor site) Html
+nicHtmlField :: YesodNic site => Field site Html
 nicHtmlField = Field
     { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
     , fieldView = \theId name attrs val _isReq -> do
@@ -52,9 +52,9 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
   where
     showVal = either id (pack . renderHtml)
 
-addScript' :: (MonadWidget m, HandlerSite m ~ site)
+addScript' :: (HasWidgetData env, HandlerSite env ~ site)
            => (site -> Either (Route site) Text)
-           -> m ()
+           -> RIO env ()
 addScript' f = do
     y <- getYesod
     addScriptEither $ f y

yesod-form/Yesod/Form/Types.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ExistentialQuantification #-}
@@ -15,6 +17,8 @@ module Yesod.Form.Types
     , WForm
     , MForm
     , AForm (..)
+    , WFormData (..)
+    , MFormData (..)
       -- * Build forms
     , Field (..)
     , FieldSettings (..)
@@ -22,8 +26,8 @@ module Yesod.Form.Types
     , FieldViewFunc
     ) where
 
-import Control.Monad.Trans.RWS (RWST)
+import RIO
-import Control.Monad.Trans.Writer (WriterT)
+import RIO.Orphans
 import Data.Text (Text)
 import Data.Monoid (Monoid (..))
 import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
@@ -31,10 +35,9 @@ import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
 #define ToHtml ToMarkup
 #define toHtml toMarkup
 import Control.Applicative ((<$>), Alternative (..), Applicative (..))
-import Control.Monad (liftM)
-import Control.Monad.Trans.Class
 import Data.String (IsString (..))
 import Yesod.Core
+import Yesod.Core.Types
 import qualified Data.Map as Map
 import Data.Semigroup (Semigroup, (<>))
 import Data.Traversable
@@ -140,46 +143,53 @@ type FileEnv = Map.Map Text [FileInfo]
 -- >   return $ MyForm <$> field1F <*> field2F <*> field3F
 --
 -- @since 1.4.14
-type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a
+type WForm site = RIO (WFormData site)
+data WFormData site = WFormData
+  { wfdViews :: !(BDeque (PrimState IO) (FieldView site))
+  , wfdMfd :: !(MFormData site)
+  }
+instance HasHandlerData (WFormData site) where
+  type HandlerSite (WFormData site) = site
+  type SubHandlerSite (WFormData site) = site
+  subHandlerDataL = (lens wfdMfd (\x y -> x { wfdMfd = y })).subHandlerDataL
+instance HasResourceMap (WFormData site) where
+  resourceMapL = subHandlerDataL.resourceMapL
+instance HasLogFunc (WFormData site) where
+  logFuncL = subHandlerDataL.logFuncL
 
-type MForm m a = RWST
+type MForm site = RIO (MFormData site)
-    (Maybe (Env, FileEnv), HandlerSite m, [Lang])
+data MFormData site = MFormData
-    Enctype
+  { mfdHandlerData :: !(SubHandlerData site site)
-    Ints
+  , mfdEnctype :: !(IORef Enctype)
-    m
+  , mfdParams :: !(Maybe (Env, FileEnv))
-    a
+  , mfdInts :: !(IORef Ints)
+  }
+instance HasHandlerData (MFormData site) where
+  type HandlerSite (MFormData site) = site
+  type SubHandlerSite (MFormData site) = site
+  subHandlerDataL = lens mfdHandlerData (\x y -> x { mfdHandlerData = y})
+instance HasResourceMap (MFormData site) where
+  resourceMapL = subHandlerDataL.resourceMapL
+instance HasLogFunc (MFormData site) where
+  logFuncL = subHandlerDataL.logFuncL
 
-newtype AForm m a = AForm
+newtype AForm site a = AForm (WForm site (FormResult a))
-    { unAForm :: (HandlerSite m, [Text])
+  deriving Functor
-              -> Maybe (Env, FileEnv)
+instance Applicative (AForm site) where
-              -> Ints
+    pure = AForm . pure . pure
-              -> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype)
+    (AForm f) <*> (AForm g) = AForm $ do
-    }
+        f' <- f
-instance Monad m => Functor (AForm m) where
+        g' <- g
-    fmap f (AForm a) =
+        pure $ f' <*> g'
-        AForm $ \x y z -> liftM go $ a x y z
+instance Monoid a => Monoid (AForm site a) where
-      where
-        go (w, x, y, z) = (fmap f w, x, y, z)
-instance Monad m => Applicative (AForm m) where
-    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty)
-    (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
-        (a, b, ints', c) <- f mr env ints
-        (x, y, ints'', z) <- g mr env ints'
-        return (a <*> x, b . y, ints'', c `mappend` z)
-instance (Monad m, Monoid a) => Monoid (AForm m a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b
-instance (Monad m, Semigroup a) => Semigroup (AForm m a) where
+instance Semigroup a => Semigroup (AForm site a) where
     a <> b = (<>) <$> a <*> b
 
-instance MonadTrans AForm where
+data FieldSettings site = FieldSettings
-    lift f = AForm $ \_ _ ints -> do
+    { fsLabel :: SomeMessage site
-        x <- f
+    , fsTooltip :: Maybe (SomeMessage site)
-        return (FormSuccess x, id, ints, mempty)
-
-data FieldSettings master = FieldSettings
-    { fsLabel :: SomeMessage master
-    , fsTooltip :: Maybe (SomeMessage master)
     , fsId :: Maybe Text
     , fsName :: Maybe Text
     , fsAttrs :: [(Text, Text)]
@@ -197,17 +207,17 @@ data FieldView site = FieldView
     , fvRequired :: Bool
     }
 
-type FieldViewFunc m a
+type FieldViewFunc site a
     = Text -- ^ ID
    -> Text -- ^ Name
    -> [(Text, Text)] -- ^ Attributes
    -> Either Text a -- ^ Either (invalid text) or (legitimate result)
    -> Bool -- ^ Required?
-   -> WidgetFor (HandlerSite m) ()
+   -> WidgetFor site ()
 
-data Field m a = Field
+data Field site a = Field
-    { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
+    { fieldParse :: [Text] -> [FileInfo] -> HandlerFor site (Either (SomeMessage site) (Maybe a))
-    , fieldView :: FieldViewFunc m a
+    , fieldView :: FieldViewFunc site a
     , fieldEnctype :: Enctype
     }
 

yesod-form/yesod-form.cabal

@@ -30,7 +30,7 @@ library
                    , containers            >= 0.2
                    , data-default
                    , email-validate        >= 1.0
-                   , persistent
+                   , persistent            >= 2.5
                    , resourcet
                    , semigroups
                    , shakespeare           >= 2.0
@@ -41,6 +41,8 @@ library
                    , xss-sanitize          >= 0.3.0.1
                    , yesod-core            >= 1.6      && < 1.7
                    , yesod-persistent      >= 1.6      && < 1.7
+                   , rio
+                   , rio-orphans
 
     if flag(network-uri)
       build-depends: network-uri >= 2.6

yesod-newsfeed/Yesod/AtomFeed.hs

@@ -42,14 +42,14 @@ instance HasContentType RepAtom where
 instance ToTypedContent RepAtom where
     toTypedContent = TypedContent typeAtom . toContent
 
-atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
+atomFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env RepAtom
 atomFeed feed = do
     render <- getUrlRender
     return $ RepAtom $ toContent $ renderLBS def $ template feed render
 
 -- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
 --   generating a feed of external links.
-atomFeedText :: MonadHandler m => Feed Text -> m RepAtom
+atomFeedText :: HasHandlerData env => Feed Text -> RIO env RepAtom
 atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id
 
 template :: Feed url -> (url -> Text) -> Document
@@ -90,10 +90,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
                                           ,("href", render enclosedUrl)]) []]
 
 -- | Generates a link tag in the head of a widget.
-atomLink :: MonadWidget m
+atomLink :: HasWidgetData env
-         => Route (HandlerSite m)
+         => Route (HandlerSite env)
          -> Text -- ^ title
-         -> m ()
+         -> RIO env ()
 atomLink r title = toWidgetHead [hamlet|
     <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
     |]

yesod-newsfeed/Yesod/Feed.hs

@@ -28,14 +28,14 @@ import Yesod.Core
 
 import Data.Text
 
-newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
+newsFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env TypedContent
 newsFeed f = selectRep $ do
     provideRep $ atomFeed f
     provideRep $ rssFeed f
 
 -- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
 --   generating a feed of external links.
-newsFeedText :: MonadHandler m => Feed Text -> m TypedContent
+newsFeedText :: HasHandlerData env => Feed Text -> RIO env TypedContent
 newsFeedText f = selectRep $ do
     provideRep $ atomFeedText f
     provideRep $ rssFeedText f

yesod-newsfeed/Yesod/RssFeed.hs

@@ -39,14 +39,14 @@ instance ToTypedContent RepRss where
     toTypedContent = TypedContent typeRss . toContent
 
 -- | Generate the feed
-rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss
+rssFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env RepRss
 rssFeed feed = do
     render <- getUrlRender
     return $ RepRss $ toContent $ renderLBS def $ template feed render
 
 -- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
 --   generating a feed of external links.
-rssFeedText :: MonadHandler m => Feed Text -> m RepRss
+rssFeedText :: HasHandlerData env => Feed Text -> RIO env RepRss
 rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
 
 template :: Feed url -> (url -> Text) -> Document
@@ -93,10 +93,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
                                   ,("url", render enclosedUrl)]) []]
 
 -- | Generates a link tag in the head of a widget.
-rssLink :: MonadWidget m
+rssLink :: HasWidgetData env
-        => Route (HandlerSite m)
+        => Route (HandlerSite env)
         -> Text -- ^ title
-        -> m ()
+        -> RIO env ()
 rssLink r title = toWidgetHead [hamlet|
     <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
     |]

yesod-sitemap/Yesod/Sitemap.hs

@@ -61,9 +61,9 @@ data SitemapUrl url = SitemapUrl
     }
 
 -- | A basic robots file which just lists the "Sitemap: " line.
-robots :: MonadHandler m
+robots :: HasHandlerData env
-       => Route (HandlerSite m) -- ^ sitemap url
+       => Route (HandlerSite env) -- ^ sitemap url
-       -> m Text
+       -> RIO env Text
 robots smurl = do
     ur <- getUrlRender
     return $ T.unlines

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

yesod-websockets/Yesod/WebSockets.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Yesod.WebSockets
     ( -- * Core API
-      WebSocketsT
+      webSockets
-    , webSockets
     , webSocketsWith
     , webSocketsOptions
     , webSocketsOptionsWith
@@ -39,12 +39,16 @@ import           Conduit
 import qualified Network.Wai.Handler.WebSockets as WaiWS
 import qualified Network.WebSockets             as WS
 import qualified Yesod.Core                     as Y
-import           UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_)
+import           RIO
 
--- | A transformer for a WebSockets handler.
+-- FIXME document
---
+class Y.HasHandlerData env => HasWebsockets env where
--- Since 0.1.0
+  websocketsL :: Lens' env WS.Connection
-type WebSocketsT = ReaderT WS.Connection
+
+data WithWebsockets env = WithWebsockets
+  { wwConnection :: !WS.Connection
+  , wwEnv :: !env
+  }
 
 -- | Attempt to run a WebSockets handler. This function first checks if the
 -- client initiated a WebSockets connection and, if so, runs the provided
@@ -54,9 +58,9 @@ type WebSocketsT = ReaderT WS.Connection
 --
 -- Since 0.1.0
 webSockets
-  :: (MonadUnliftIO m, Y.MonadHandler m)
+  :: Y.HasHandlerData env
-  => WebSocketsT m ()
+  => RIO (WithWebsockets env) ()
-  -> m ()
+  -> RIO env ()
 webSockets = webSocketsOptions WS.defaultConnectionOptions
 
 -- | Varient of 'webSockets' which allows you to specify
@@ -64,26 +68,26 @@ webSockets = webSocketsOptions WS.defaultConnectionOptions
 --
 -- Since 0.2.5
 webSocketsOptions
-  :: (MonadUnliftIO m, Y.MonadHandler m)
+  :: Y.HasHandlerData env
   => WS.ConnectionOptions
-  -> WebSocketsT m ()
+  -> RIO (WithWebsockets env) ()
-  -> m ()
+  -> RIO env ()
 webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
 
 -- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
 -- setttings when upgrading to a websocket connection.
 --
 -- Since 0.2.4
-webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
+webSocketsWith :: Y.HasHandlerData env
-               => (WS.RequestHead -> m (Maybe WS.AcceptRequest))
+               => (WS.RequestHead -> RIO env (Maybe WS.AcceptRequest))
                -- ^ A Nothing indicates that the websocket upgrade request should not happen
                -- and instead the rest of the handler will be called instead.  This allows
                -- you to use 'WS.getRequestSubprotocols' and only accept the request if
                -- a compatible subprotocol is given.  Also, the action runs before upgrading
                -- the request to websockets, so you can also use short-circuiting handler
                -- actions such as 'Y.invalidArgs'.
-               -> WebSocketsT m ()
+               -> RIO (WithWebsockets env) ()
-               -> m ()
+               -> RIO env ()
 webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
 
 -- | Varient of 'webSockets' which allows you to specify both
@@ -91,18 +95,18 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
 -- setttings when upgrading to a websocket connection.
 --
 -- Since 0.2.5
-webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
+webSocketsOptionsWith :: Y.HasHandlerData env
                => WS.ConnectionOptions
                -- ^ Custom websockets options
-               -> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
+               -> (WS.RequestHead -> RIO env (Maybe WS.AcceptRequest))
                -- ^ A Nothing indicates that the websocket upgrade request should not happen
                -- and instead the rest of the handler will be called instead.  This allows
                -- you to use 'WS.getRequestSubprotocols' and only accept the request if
                -- a compatible subprotocol is given.  Also, the action runs before upgrading
                -- the request to websockets, so you can also use short-circuiting handler
                -- actions such as 'Y.invalidArgs'.
-               -> WebSocketsT m ()
+               -> RIO (WithWebsockets env) ()
-               -> m ()
+               -> RIO env ()
 webSocketsOptionsWith wsConnOpts buildAr inner = do
     req <- Y.waiRequest
     when (WaiWS.isWebSocketsReq req) $ do
@@ -110,43 +114,45 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
         mar <- buildAr rhead
         case mar of
             Nothing -> return ()
-            Just ar ->
+            Just ar -> do
+                env <- ask
                 Y.sendRawResponseNoConduit
-                  $ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets
+                  $ \src sink -> liftIO $ WaiWS.runWebSockets
                     wsConnOpts
                     rhead
                     (\pconn -> do
                         conn <- WS.acceptRequestWith pconn ar
                         WS.forkPingThread conn 30
-                        runInIO $ runReaderT inner conn)
+                        let ww = WithWebsockets conn env
+                        runRIO ww inner)
                     src
                     sink
 
 -- | Wrapper for capturing exceptions
-wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
+wrapWSE :: HasWebsockets env
         => (WS.Connection -> a -> IO ())
         -> a
-        -> m (Either SomeException ())
+        -> RIO env (Either SomeException ())
 wrapWSE ws x = do
-  conn <- ask
+  conn <- view websocketsL
   liftIO $ tryAny $ ws conn x
 
-wrapWS :: (MonadIO m, MonadReader WS.Connection m)
+wrapWS :: HasWebsockets env
        => (WS.Connection -> a -> IO ())
        -> a
-       -> m ()
+       -> RIO env ()
 wrapWS ws x = do
-  conn <- ask
+  conn <- view websocketsL
   liftIO $ ws conn x
 
 -- | Receive a piece of data from the client.
 --
 -- Since 0.1.0
 receiveData
-  :: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
+  :: (WS.WebSocketsData a, HasWebsockets env)
-  => m a
+  => RIO env a
 receiveData = do
-  conn <- ask
+  conn <- view websocketsL
   liftIO $ WS.receiveData conn
 
 -- | Receive a piece of data from the client.
@@ -173,9 +179,9 @@ receiveDataMessageE = do
 --
 -- Since 0.1.0
 sendTextData
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m ()
+  -> RIO env ()
 sendTextData = wrapWS WS.sendTextData
 
 -- | Send a textual message to the client.
@@ -184,45 +190,45 @@ sendTextData = wrapWS WS.sendTextData
 -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
 -- Since 0.2.2
 sendTextDataE
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m (Either SomeException ())
+  -> RIO env (Either SomeException ())
 sendTextDataE = wrapWSE WS.sendTextData
 
 -- | Send a binary message to the client.
 --
 -- Since 0.1.0
 sendBinaryData
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m ()
+  -> RIO env ()
 sendBinaryData = wrapWS WS.sendBinaryData
 
 -- | Send a binary message to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
 sendBinaryDataE
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m (Either SomeException ())
+  -> RIO env (Either SomeException ())
 sendBinaryDataE = wrapWSE WS.sendBinaryData
 
 -- | Send a ping message to the client.
 --
 -- Since 0.2.2
 sendPing
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> WebSocketsT m ()
+  -> RIO env ()
 sendPing = wrapWS WS.sendPing
 
 -- | Send a ping message to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
 sendPingE
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m (Either SomeException ())
+  -> RIO env (Either SomeException ())
 sendPingE = wrapWSE WS.sendPing
 
 -- | Send a DataMessage to the client.
@@ -240,40 +246,40 @@ sendDataMessageE x = do
 --
 -- Since 0.2.2
 sendClose
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> WebSocketsT m ()
+  -> RIO env ()
 sendClose = wrapWS WS.sendClose
 
 -- | Send a close request to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
 sendCloseE
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
   => a
-  -> m (Either SomeException ())
+  -> RIO env (Either SomeException ())
 sendCloseE = wrapWSE WS.sendClose
 
 -- | A @Source@ of WebSockets data from the user.
 --
 -- Since 0.1.0
 sourceWS
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
-  => ConduitT i a m ()
+  => ConduitT i a (RIO env) ()
 sourceWS = forever $ lift receiveData >>= yield
 
 -- | A @Sink@ for sending textual data to the user.
 --
 -- Since 0.1.0
 sinkWSText
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
-  => ConduitT a o m ()
+  => ConduitT a o (RIO env) ()
 sinkWSText = mapM_C sendTextData
 
 -- | A @Sink@ for sending binary data to the user.
 --
 -- Since 0.1.0
 sinkWSBinary
-  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  :: (WS.WebSocketsData a, HasWebsockets env)
-  => ConduitT a o m ()
+  => ConduitT a o (RIO env) ()
 sinkWSBinary = mapM_C sendBinaryData

yesod-websockets/yesod-websockets.cabal

@@ -22,6 +22,7 @@ library
                      , wai-websockets    >= 2.1
                      , websockets        >= 0.10
                      , yesod-core        >= 1.6
+                     , rio
 
 source-repository head
   type:     git

yesod/src/Yesod/Default/Config.hs

@@ -180,7 +180,7 @@ loadConfig :: ConfigSettings environment extra
            -> IO (AppConfig environment extra)
 loadConfig (ConfigSettings env parseExtra getFile getObject) = do
     fp <- getFile env
-    mtopObj <- decodeFile fp
+    mtopObj <- decodeFileThrow fp
     topObj <- maybe (fail "Invalid YAML file") return mtopObj
     obj <- getObject env topObj
     m <-
@@ -233,7 +233,7 @@ withYamlEnvironment :: Show e
                     -> (Value -> Parser a) -- ^ what to do with the mapping
                     -> IO a
 withYamlEnvironment fp env f = do
-    mval <- decodeFile fp
+    mval <- decodeFileThrow fp
     case mval of
         Nothing -> fail $ "Invalid YAML file: " ++ show fp
         Just (Object obj)

yesod/src/Yesod/Default/Config2.hs

@@ -6,7 +6,6 @@ module Yesod.Default.Config2
       configSettingsYml
     , getDevSettings
     , develMainHelper
-    , makeYesodLogger
       -- * Re-exports from Data.Yaml.Config
     , applyCurrentEnv
     , getCurrentEnv
@@ -28,7 +27,6 @@ module Yesod.Default.Config2
 
 import Data.Yaml.Config
 
-import Data.Semigroup
 import Data.Aeson
 import qualified Data.HashMap.Strict as H
 import System.Environment (getEnvironment)
@@ -39,9 +37,6 @@ import Data.Maybe (fromMaybe)
 import Control.Concurrent (forkIO, threadDelay)
 import System.Exit (exitSuccess)
 import System.Directory (doesFileExist)
-import Network.Wai.Logger (clockDateCacher)
-import Yesod.Core.Types (Logger (Logger))
-import System.Log.FastLogger (LoggerSet)
 
 #ifndef mingw32_HOST_OS
 import System.Posix.Signals (installHandler, sigINT, Handler(Catch))
@@ -117,10 +112,3 @@ develMainHelper getSettingsApp = do
 
     terminateDevel :: IO ()
     terminateDevel = exitSuccess
-
--- | Create a 'Logger' value (from yesod-core) out of a 'LoggerSet' (from
--- fast-logger).
-makeYesodLogger :: LoggerSet -> IO Logger
-makeYesodLogger loggerSet' = do
-    (getter, _) <- clockDateCacher
-    return $! Yesod.Core.Types.Logger loggerSet' getter

yesod/src/Yesod/Default/Handlers.hs

@@ -6,8 +6,8 @@ module Yesod.Default.Handlers
 
 import Yesod.Core
 
-getFaviconR :: MonadHandler m => m ()
+getFaviconR :: HasHandlerData env => RIO env ()
 getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
 
-getRobotsR :: MonadHandler m => m ()
+getRobotsR :: HasHandlerData env => RIO env ()
 getRobotsR = sendFile "text/plain" "config/robots.txt"

yesod/yesod.cabal

@@ -14,6 +14,7 @@ homepage:        http://www.yesodweb.com/
 extra-source-files: README.md ChangeLog.md
 
 library
+    hs-source-dirs:  src
     if os(windows)
         cpp-options: -DWINDOWS