diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 1006d11e..84f814d0 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 2.0.0.0 + +* Switch over to using `rio` + ## 1.6.12 * Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581) diff --git a/yesod-core/src/Yesod/Core.hs b/yesod-core/src/Yesod/Core.hs index 13ed2136..4ca279f3 100644 --- a/yesod-core/src/Yesod/Core.hs +++ b/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 (..) - , MonadWidget (..) + , HasHandlerData (..) + , 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 diff --git a/yesod-core/src/Yesod/Core/Class/Dispatch.hs b/yesod-core/src/Yesod/Core/Class/Dispatch.hs index 4abe179c..0451f519 100644 --- a/yesod-core/src/Yesod/Core/Class/Dispatch.hs +++ b/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 - handlert = sendWaiApplication set + WaiSubsiteWithAuth set' = ysreGetSub $ yreSite $ ysreParentEnv + 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 diff --git a/yesod-core/src/Yesod/Core/Class/Handler.hs b/yesod-core/src/Yesod/Core/Class/Handler.hs deleted file mode 100644 index 8d8ca448..00000000 --- a/yesod-core/src/Yesod/Core/Class/Handler.hs +++ /dev/null @@ -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 diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index df7f079b..f3122e57 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/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 Data.Word (Word64) +import qualified Data.Text.Lazy.Encoding as TLE (encodeUtf8) 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. @@ -202,29 +196,15 @@ class RenderRoute site => Yesod site where maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64 maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes - -- | 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 - -- a @Logger@ value and place it in your foundation datatype, and have this - -- method return that already created value. That way, you can use that - -- same @Logger@ for printing messages during app initialization. - -- - -- Default: the 'defaultMakeLogger' function. - makeLogger :: site -> IO Logger - 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 + -- If this function returns a @Nothing@ (the default), the Yesod + -- codebase itself will create a log function for you with some + -- default settings. Overriding this allows you to have more + -- control, and also to share your log function with code outside + -- of your handlers. + getLogFunc :: site -> Maybe LogFunc + getLogFunc _ = Nothing -- | Where to Load sripts from. We recommend the default value, -- 'BottomOfBody'. @@ -255,14 +235,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. -- @@ -299,44 +271,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. @@ -405,12 +339,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=" - , show $ timeout * 60 - , "; includeSubDomains" - ] + $ utf8BuilderToText -- FIXME should we store headers as Utf8Builders? + $ "max-age=" <> display (timeout' * 60) <> "; includeSubDomains" handler -- | Check if a given request is authorized via 'isAuthorized' and @@ -436,7 +368,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. -- @@ -507,19 +439,17 @@ defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddlew widgetToPageContent :: Yesod site => WidgetFor site () -> HandlerFor site (PageContent (Route site)) -widgetToPageContent w = HandlerFor $ \hd -> do - master <- unHandlerFor getYesod hd +widgetToPageContent w = do + master <- getYesod ref <- newIORef mempty - unWidgetFor w WidgetData - { wdRef = ref - , wdHandler = hd - } + hd <- ask + runRIO WidgetData { wdRef = ref, wdHandler = hd } w 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 @@ -529,7 +459,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 @@ -539,7 +469,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 http://www.modernizr.com/docs/#installing @@ -660,7 +590,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" @@ -698,43 +628,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 \"\\". 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 == "" 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'. -- diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index 60779532..c5a0b0a8 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/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 - toWaiAppLogger logger site + (logFunc, cleanup) <- makeLogFunc site + toWaiAppLogger logFunc cleanup site -toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application -toWaiAppLogger logger site = do +toWaiAppLogger + :: 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 - site - logger - $(qLocation >>= liftLoc) - "yesod-core" - LevelInfo - (toLogStr ("Application launched" :: S.ByteString)) - middleware <- mkDefaultMiddlewares logger + runRIO logFunc $ logInfoS "yesod-core" "Application launched" + middleware <- mkDefaultMiddlewares logFunc 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 - toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings ( + (logFunc, cleanup) <- makeLogFunc site + 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 - site - logger - $(qLocation >>= liftLoc) - "yesod-core" - LevelError - (toLogStr $ "Exception from Warp: " ++ show e)) + runRIO logFunc $ + logErrorS "yesod-core" $ + "Exception from Warp: " <> displayShow 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 logger = do +mkDefaultMiddlewares :: LogFunc -> IO W.Middleware +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 diff --git a/yesod-core/src/Yesod/Core/Handler.hs b/yesod-core/src/Yesod/Core/Handler.hs index ddf4861c..e0fb5acb 100644 --- a/yesod-core/src/Yesod/Core/Handler.hs +++ b/yesod-core/src/Yesod/Core/Handler.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -10,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuantifiedConstraints #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -201,13 +203,12 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, import Control.Applicative ((<|>)) import qualified Data.CaseInsensitive as CI -import Control.Exception (evaluate, SomeException, throwIO) -import Control.Exception (handle) import Control.Monad (void, liftM, unless) import qualified Control.Monad.Trans.Writer as Writer -import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO) +import RIO +import RIO.Orphans import qualified Network.HTTP.Types as H import qualified Network.Wai as W @@ -241,55 +242,52 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToHtml, toHtml) -import qualified Data.IORef as I import Data.Maybe (listToMaybe, mapMaybe) import Data.Typeable (Typeable) import Web.PathPieces (PathPiece(..)) -import Yesod.Core.Class.Handler import Yesod.Core.Types import Yesod.Routes.Class (Route) import Data.ByteString.Builder (Builder) import Data.CaseInsensitive (CI, original) import qualified Data.Conduit.List as CL -import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) +import Control.Monad.Trans.Resource (MonadResource, InternalState, getInternalState, liftResourceT, resourceForkIO) import qualified System.PosixCompat.Files as PC import Conduit ((.|), runConduit, sinkLazy) import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void) import qualified Yesod.Core.TypeCache as Cache import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold -import Control.Monad.Logger (MonadLogger, logWarnS) type HandlerT site (m :: * -> *) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-} -get :: MonadHandler m => m GHState -get = liftHandler $ HandlerFor $ I.readIORef . handlerState +get :: HasHandlerData env => RIO env GHState +get = view (subHandlerDataL.to handlerState) >>= readIORef -put :: MonadHandler m => GHState -> m () -put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState +put :: HasHandlerData env => GHState -> RIO env () +put x = view (subHandlerDataL.to handlerState) >>= flip writeIORef x -modify :: MonadHandler m => (GHState -> GHState) -> m () -modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState +modify :: HasHandlerData env => (GHState -> GHState) -> RIO env () +modify f = view (subHandlerDataL.to handlerState) >>= flip modifyIORef f -tell :: MonadHandler m => Endo [Header] -> m () +tell :: HasHandlerData env => Endo [Header] -> RIO env () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } -handlerError :: MonadHandler m => HandlerContents -> m a +handlerError :: HasHandlerData env => HandlerContents -> RIO env a handlerError = liftIO . throwIO -hcError :: MonadHandler m => ErrorResponse -> m a +hcError :: HasHandlerData env => ErrorResponse -> RIO env a hcError = handlerError . HCError -getRequest :: MonadHandler m => m YesodRequest -getRequest = liftHandler $ HandlerFor $ return . handlerRequest +getRequest :: HasHandlerData env => RIO env YesodRequest +getRequest = view $ subHandlerDataL.to handlerRequest -runRequestBody :: MonadHandler m => m RequestBodyContents +runRequestBody :: HasHandlerData env => RIO env RequestBodyContents runRequestBody = do - HandlerData + SubHandlerData { handlerEnv = RunHandlerEnv {..} , handlerRequest = req - } <- liftHandler $ HandlerFor return + } <- view subHandlerDataL let len = W.requestBodyLength $ reqWaiRequest req upload = rheUpload len x <- get @@ -328,28 +326,28 @@ rbHelper' backend mkFI req = | otherwise = a' go = decodeUtf8With lenientDecode -askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m)) -askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv +askHandlerEnv :: HasHandlerData env => RIO env (RunHandlerEnv (SubHandlerSite env) (HandlerSite env)) +askHandlerEnv = view $ subHandlerDataL.to handlerEnv -- | Get the master site application argument. -getYesod :: MonadHandler m => m (HandlerSite m) +getYesod :: HasHandlerData env => RIO env (HandlerSite env) getYesod = rheSite <$> askHandlerEnv -- | Get a specific component of the master site application argument. -- Analogous to the 'gets' function for operating on 'StateT'. -getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a +getsYesod :: HasHandlerData env => (HandlerSite env -> a) -> RIO env a getsYesod f = (f . rheSite) <$> askHandlerEnv -- | Get the URL rendering function. -getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text) +getUrlRender :: HasHandlerData env => RIO env (Route (HandlerSite env) -> Text) getUrlRender = do x <- rheRender <$> askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams - :: MonadHandler m - => m (Route (HandlerSite m) -> [(Text, Text)] -> Text) + :: HasHandlerData env + => RIO env (Route (HandlerSite env) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender <$> askHandlerEnv -- | Get all the post parameters passed to the handler. To also get @@ -358,16 +356,18 @@ getUrlRenderParams = rheRender <$> askHandlerEnv -- -- @since 1.4.33 getPostParams - :: MonadHandler m - => m [(Text, Text)] + :: HasHandlerData env + => RIO env [(Text, Text)] getPostParams = do reqBodyContent <- runRequestBody return $ fst reqBodyContent -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. -getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) -getCurrentRoute = rheRoute <$> askHandlerEnv +getCurrentRoute :: HasHandlerData env => RIO env (Maybe (Route (HandlerSite env))) +getCurrentRoute = do + rhe <- askHandlerEnv + pure $ rheRouteToMaster rhe <$> rheRoute rhe -- | Returns a function that runs 'HandlerT' actions inside @IO@. -- @@ -406,8 +406,8 @@ getCurrentRoute = rheRoute <$> askHandlerEnv -- 'GHandler' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread). handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a) -handlerToIO = - HandlerFor $ \oldHandlerData -> do +handlerToIO = do + oldHandlerData <- view subHandlerDataL -- Take just the bits we need from oldHandlerData. let newReq = oldReq { reqWaiRequest = newWaiReq } where @@ -418,7 +418,7 @@ handlerToIO = } oldEnv = handlerEnv oldHandlerData newState <- liftIO $ do - oldState <- I.readIORef (handlerState oldHandlerData) + oldState <- readIORef (handlerState oldHandlerData) return $ oldState { ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty @@ -429,20 +429,20 @@ handlerToIO = liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) -- Return GHandler running function. - return $ \(HandlerFor f) -> + return $ \action -> liftIO $ - runResourceT $ withInternalState $ \resState -> do + withResourceMap $ \resourceMap -> do -- The state IORef needs to be created here, otherwise it -- will be shared by different invocations of this function. - newStateIORef <- liftIO (I.newIORef newState) + newStateIORef <- liftIO (newIORef newState) let newHandlerData = - HandlerData + HandlerData $ SubHandlerData { handlerRequest = newReq , handlerEnv = oldEnv , handlerState = newStateIORef - , handlerResource = resState + , handlerResource = resourceMap } - liftIO (f newHandlerData) + runRIO newHandlerData action -- | forkIO for a Handler (run an action in the background) -- @@ -465,8 +465,8 @@ forkHandler onErr handler = do -- -- If you want direct control of the final status code, or need a different -- status code, please use 'redirectWith'. -redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url) - => url -> m a +redirect :: (HasHandlerData env, RedirectUrl (HandlerSite env) url) + => url -> RIO env a redirect url = do req <- waiRequest let status = @@ -476,10 +476,10 @@ redirect url = do redirectWith status url -- | Redirect to the given URL with the specified status code. -redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url) +redirectWith :: (HasHandlerData env, RedirectUrl (HandlerSite env) url) => H.Status -> url - -> m a + -> RIO env a redirectWith status url = do urlText <- toTextUrl url handlerError $ HCRedirect status urlText @@ -491,9 +491,9 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url) +setUltDest :: (HasHandlerData env, RedirectUrl (HandlerSite env) url) => url - -> m () + -> RIO env () setUltDest url = do urlText <- toTextUrl url setSession ultDestKey urlText @@ -502,7 +502,7 @@ setUltDest url = do -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. -setUltDestCurrent :: MonadHandler m => m () +setUltDestCurrent :: HasHandlerData env => RIO env () setUltDestCurrent = do route <- getCurrentRoute case route of @@ -514,7 +514,7 @@ setUltDestCurrent = do -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest. -setUltDestReferer :: MonadHandler m => m () +setUltDestReferer :: HasHandlerData env => RIO env () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe @@ -531,16 +531,16 @@ setUltDestReferer = do -- -- This function uses 'redirect', and thus will perform a temporary redirect to -- a GET request. -redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m) +redirectUltDest :: (RedirectUrl (HandlerSite env) url, HasHandlerData env) => url -- ^ default destination if nothing in session - -> m a + -> RIO env a redirectUltDest defaultDestination = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect defaultDestination) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. -clearUltDest :: MonadHandler m => m () +clearUltDest :: HasHandlerData env => RIO env () clearUltDest = deleteSession ultDestKey msgKey :: Text @@ -551,10 +551,10 @@ msgKey = "_MSG" -- See 'getMessages'. -- -- @since 1.4.20 -addMessage :: MonadHandler m +addMessage :: HasHandlerData env => Text -- ^ status -> Html -- ^ message - -> m () + -> RIO env () addMessage status msg = do val <- lookupSessionBS msgKey setSessionBS msgKey $ addMsg val @@ -569,8 +569,8 @@ addMessage status msg = do -- See 'getMessages'. -- -- @since 1.4.20 -addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) - => Text -> msg -> m () +addMessageI :: (HasHandlerData env, RenderMessage (HandlerSite env) msg) + => Text -> msg -> RIO env () addMessageI status msg = do mr <- getMessageRender addMessage status $ toHtml $ mr msg @@ -580,7 +580,7 @@ addMessageI status msg = do -- See 'addMessage'. -- -- @since 1.4.20 -getMessages :: MonadHandler m => m [(Text, Html)] +getMessages :: HasHandlerData env => RIO env [(Text, Html)] getMessages = do bs <- lookupSessionBS msgKey let ms = maybe [] enlist bs @@ -594,33 +594,34 @@ getMessages = do decode = decodeUtf8With lenientDecode -- | Calls 'addMessage' with an empty status -setMessage :: MonadHandler m => Html -> m () +setMessage :: HasHandlerData env => Html -> RIO env () setMessage = addMessage "" -- | Calls 'addMessageI' with an empty status -setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) - => msg -> m () +setMessageI :: (HasHandlerData env, RenderMessage (HandlerSite env) msg) + => msg + -> RIO env () setMessageI = addMessageI "" -- | Gets just the last message in the user's session, -- discards the rest and the status -getMessage :: MonadHandler m => m (Maybe Html) +getMessage :: HasHandlerData env => RIO env (Maybe Html) getMessage = fmap (fmap snd . listToMaybe) getMessages -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. -sendFile :: MonadHandler m => ContentType -> FilePath -> m a +sendFile :: HasHandlerData env => ContentType -> FilePath -> RIO env a sendFile ct fp = handlerError $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. -sendFilePart :: MonadHandler m +sendFilePart :: HasHandlerData env => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count - -> m a + -> RIO env a sendFilePart ct fp off count = do fs <- liftIO $ PC.getFileStatus fp handlerError $ HCSendFile ct fp $ Just W.FilePart @@ -631,24 +632,24 @@ sendFilePart ct fp off count = do -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a +sendResponse :: (HasHandlerData env, ToTypedContent c) => c -> RIO env a sendResponse = handlerError . HCContent H.status200 . toTypedContent -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a +sendResponseStatus :: (HasHandlerData env, ToTypedContent c) => H.Status -> c -> RIO env a sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Bypass remaining handler code and output the given JSON with the given -- status code. -- -- @since 1.4.18 -sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a +sendStatusJSON :: (HasHandlerData env, ToJSON c) => H.Status -> c -> RIO env a sendStatusJSON s v = sendResponseStatus s (toEncoding v) -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a +sendResponseCreated :: HasHandlerData env => Route (HandlerSite env) -> RIO env a sendResponseCreated url = do r <- getUrlRender handlerError $ HCCreated $ r url @@ -656,7 +657,7 @@ sendResponseCreated url = do -- | Bypass remaining handler code and output no content with a 204 status code. -- -- @since 1.6.9 -sendResponseNoContent :: MonadHandler m => m a +sendResponseNoContent :: HasHandlerData env => RIO env a sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty -- | Send a 'W.Response'. Please note: this function is rarely @@ -664,13 +665,13 @@ sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempt -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't. -sendWaiResponse :: MonadHandler m => W.Response -> m b +sendWaiResponse :: HasHandlerData env => W.Response -> RIO env b sendWaiResponse = handlerError . HCWai -- | Switch over to handling the current request with a WAI @Application@. -- -- @since 1.2.17 -sendWaiApplication :: MonadHandler m => W.Application -> m b +sendWaiApplication :: HasHandlerData env => W.Application -> RIO env b sendWaiApplication = handlerError . HCWaiApp -- | Send a raw response without conduit. This is used for cases such as @@ -679,9 +680,9 @@ sendWaiApplication = handlerError . HCWaiApp -- -- @since 1.2.16 sendRawResponseNoConduit - :: (MonadHandler m, MonadUnliftIO m) - => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) - -> m a + :: HasHandlerData env + => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> RIO env ()) + -> RIO env a sendRawResponseNoConduit raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO (raw src sink) @@ -695,9 +696,9 @@ sendRawResponseNoConduit raw = withRunInIO $ \runInIO -> -- -- @since 1.2.7 sendRawResponse - :: (MonadHandler m, MonadUnliftIO m) - => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ()) - -> m a + :: HasHandlerData env + => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> RIO env ()) + -> RIO env a sendRawResponse raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink) @@ -714,41 +715,41 @@ sendRawResponse raw = withRunInIO $ \runInIO -> -- action. -- -- @since 1.4.4 -notModified :: MonadHandler m => m a +notModified :: HasHandlerData env => RIO env a notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty -- | Return a 404 not found page. Also denotes no handler available. -notFound :: MonadHandler m => m a +notFound :: HasHandlerData env => RIO env a notFound = hcError NotFound -- | Return a 405 method not supported page. -badMethod :: MonadHandler m => m a +badMethod :: HasHandlerData env => RIO env a badMethod = do w <- waiRequest hcError $ BadMethod $ W.requestMethod w -- | Return a 401 status code -notAuthenticated :: MonadHandler m => m a +notAuthenticated :: HasHandlerData env => RIO env a notAuthenticated = hcError NotAuthenticated -- | Return a 403 permission denied page. -permissionDenied :: MonadHandler m => Text -> m a -permissionDenied = hcError . PermissionDenied +permissionDenied :: HasHandlerData env => Utf8Builder -> RIO env a +permissionDenied = hcError . PermissionDenied . utf8BuilderToText -- FIXME inefficient -- | Return a 403 permission denied page. -permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m) +permissionDeniedI :: (RenderMessage (HandlerSite env) msg, HasHandlerData env) => msg - -> m a + -> RIO env a permissionDeniedI msg = do mr <- getMessageRender - permissionDenied $ mr msg + permissionDenied $ display $ mr msg -- | Return a 400 invalid arguments page. -invalidArgs :: MonadHandler m => [Text] -> m a +invalidArgs :: HasHandlerData env => [Text] -> RIO env a invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page. -invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a +invalidArgsI :: (HasHandlerData env, RenderMessage (HandlerSite env) msg) => [msg] -> RIO env a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg @@ -756,7 +757,7 @@ invalidArgsI msg = do ------- Headers -- | Set the cookie on the client. -setCookie :: MonadHandler m => SetCookie -> m () +setCookie :: HasHandlerData env => SetCookie -> RIO env () setCookie sc = do addHeaderInternal (DeleteCookie name path) addHeaderInternal (AddCookie sc) @@ -776,16 +777,16 @@ getExpires m = do -- -- Note: although the value used for key and path is 'Text', you should only -- use ASCII values to be HTTP compliant. -deleteCookie :: MonadHandler m +deleteCookie :: HasHandlerData env => Text -- ^ key -> Text -- ^ path - -> m () + -> RIO env () deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8 -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: MonadHandler m => Text -> m () +setLanguage :: HasHandlerData env => Text -> RIO env () setLanguage = setSession langKey -- | Set attachment file name. @@ -797,7 +798,7 @@ setLanguage = setSession langKey -- () -- -- @since 1.6.4 -addContentDispositionFileName :: MonadHandler m => T.Text -> m () +addContentDispositionFileName :: HasHandlerData env => T.Text -> RIO env () addContentDispositionFileName fileName = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName @@ -814,11 +815,11 @@ rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeU -- ASCII value to be HTTP compliant. -- -- @since 1.2.0 -addHeader :: MonadHandler m => Text -> Text -> m () +addHeader :: HasHandlerData env => Text -> Text -> RIO env () addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. -setHeader :: MonadHandler m => Text -> Text -> m () +setHeader :: HasHandlerData env => Text -> Text -> RIO env () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} @@ -829,7 +830,7 @@ setHeader = addHeader -- ASCII value to be HTTP compliant. -- -- @since 1.4.36 -replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () +replaceOrAddHeader :: HasHandlerData env => Text -> Text -> RIO env () replaceOrAddHeader a b = modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where @@ -858,7 +859,7 @@ replaceOrAddHeader a b = -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. -cacheSeconds :: MonadHandler m => Int -> m () +cacheSeconds :: HasHandlerData env => Int -> RIO env () cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age=" , T.pack $ show i @@ -867,7 +868,7 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. -neverExpires :: MonadHandler m => m () +neverExpires :: HasHandlerData env => RIO env () neverExpires = do setHeader "Expires" . rheMaxExpires =<< askHandlerEnv cacheSeconds oneYear @@ -877,11 +878,11 @@ neverExpires = do -- | Set an Expires header in the past, meaning this content should not be -- cached. -alreadyExpired :: MonadHandler m => m () +alreadyExpired :: HasHandlerData env => RIO env () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. -expiresAt :: MonadHandler m => UTCTime -> m () +expiresAt :: HasHandlerData env => UTCTime -> RIO env () expiresAt = setHeader "Expires" . formatRFC1123 data Etag @@ -905,7 +906,7 @@ data Etag -- function. -- -- @since 1.4.4 -setEtag :: MonadHandler m => Text -> m () +setEtag :: HasHandlerData env => Text -> RIO env () setEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch @@ -949,7 +950,7 @@ parseMatch = -- function. -- -- @since 1.4.37 -setWeakEtag :: MonadHandler m => Text -> m () +setWeakEtag :: HasHandlerData env => Text -> RIO env () setWeakEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch @@ -962,40 +963,40 @@ setWeakEtag etag = do -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. -setSession :: MonadHandler m +setSession :: HasHandlerData env => Text -- ^ key -> Text -- ^ value - -> m () + -> RIO env () setSession k = setSessionBS k . encodeUtf8 -- | Same as 'setSession', but uses binary data for the value. -setSessionBS :: MonadHandler m +setSessionBS :: HasHandlerData env => Text -> S.ByteString - -> m () + -> RIO env () setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: MonadHandler m => Text -> m () +deleteSession :: HasHandlerData env => Text -> RIO env () deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- -- @since: 1.0.1 -clearSession :: MonadHandler m => m () +clearSession :: HasHandlerData env => RIO env () clearSession = modify $ \x -> x { ghsSession = Map.empty } modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'. -addHeaderInternal :: MonadHandler m => Header -> m () +addHeaderInternal :: HasHandlerData env => Header -> RIO env () addHeaderInternal = tell . Endo . (:) -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. - toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text + toTextUrl :: (HandlerSite env ~ master, HasHandlerData env) => a -> RIO env Text instance RedirectUrl master Text where toTextUrl = return @@ -1029,21 +1030,21 @@ instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b -- | Lookup for session data. -lookupSession :: MonadHandler m => Text -> m (Maybe Text) +lookupSession :: HasHandlerData env => Text -> RIO env (Maybe Text) lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. -lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) +lookupSessionBS :: HasHandlerData env => Text -> RIO env (Maybe S.ByteString) lookupSessionBS n = do m <- fmap ghsSession get return $ Map.lookup n m -- | Get all session variables. -getSession :: MonadHandler m => m SessionMap +getSession :: HasHandlerData env => RIO env SessionMap getSession = fmap ghsSession get -- | Get a unique identifier. -newIdent :: MonadHandler m => m Text +newIdent :: HasHandlerData env => RIO env Text newIdent = do x <- get let i' = ghsIdent x + 1 @@ -1056,9 +1057,9 @@ newIdent = do -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. -redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) +redirectToPost :: (HasHandlerData env, RedirectUrl (HandlerSite env) url) => url - -> m a + -> RIO env a redirectToPost url = do urlText <- toTextUrl url req <- getRequest @@ -1079,16 +1080,16 @@ $doctype 5 |] >>= sendResponse -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html +hamletToRepHtml :: HasHandlerData env => HtmlUrl (Route (HandlerSite env)) -> RIO env Html hamletToRepHtml = withUrlRenderer {-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-} -- | Deprecated synonym for 'withUrlRenderer'. -- -- @since 1.2.0 -giveUrlRenderer :: MonadHandler m - => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) - -> m output +giveUrlRenderer :: HasHandlerData env + => ((Route (HandlerSite env) -> [(Text, Text)] -> Text) -> output) + -> RIO env output giveUrlRenderer = withUrlRenderer {-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-} @@ -1096,19 +1097,19 @@ giveUrlRenderer = withUrlRenderer -- result. Useful for processing Shakespearean templates. -- -- @since 1.2.20 -withUrlRenderer :: MonadHandler m - => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) - -> m output +withUrlRenderer :: HasHandlerData env + => ((Route (HandlerSite env) -> [(Text, Text)] -> Text) -> output) + -> RIO env output withUrlRenderer f = do render <- getUrlRenderParams return $ f render -- | Get the request\'s 'W.Request' value. -waiRequest :: MonadHandler m => m W.Request +waiRequest :: HasHandlerData env => RIO env W.Request waiRequest = reqWaiRequest <$> getRequest -getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) - => m (message -> Text) +getMessageRender :: (HasHandlerData env, RenderMessage (HandlerSite env) message) + => RIO env (message -> Text) getMessageRender = do env <- askHandlerEnv l <- languages @@ -1124,9 +1125,9 @@ getMessageRender = do -- See the original announcement: -- -- @since 1.2.0 -cached :: (MonadHandler m, Typeable a) - => m a - -> m a +cached :: (HasHandlerData env, Typeable a) + => RIO env a + -> RIO env a cached action = do cache <- ghsCache <$> get eres <- Cache.cached cache action @@ -1141,8 +1142,8 @@ cached action = do -- | Retrieves a value from the cache used by 'cached'. -- -- @since 1.6.10 -cacheGet :: (MonadHandler m, Typeable a) - => m (Maybe a) +cacheGet :: (HasHandlerData env, Typeable a) + => RIO env (Maybe a) cacheGet = do cache <- ghsCache <$> get pure $ Cache.cacheGet cache @@ -1150,9 +1151,9 @@ cacheGet = do -- | Sets a value in the cache used by 'cached'. -- -- @since 1.6.10 -cacheSet :: (MonadHandler m, Typeable a) +cacheSet :: (HasHandlerData env, Typeable a) => a - -> m () + -> RIO env () cacheSet value = do gs <- get let cache = ghsCache gs @@ -1169,7 +1170,7 @@ cacheSet value = do -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. -- -- @since 1.4.0 -cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a +cachedBy :: (HasHandlerData env, Typeable a) => S.ByteString -> RIO env a -> RIO env a cachedBy k action = do cache <- ghsCacheBy <$> get eres <- Cache.cachedBy cache k action @@ -1184,9 +1185,9 @@ cachedBy k action = do -- | Retrieves a value from the cache used by 'cachedBy'. -- -- @since 1.6.10 -cacheByGet :: (MonadHandler m, Typeable a) +cacheByGet :: (HasHandlerData env, Typeable a) => S.ByteString - -> m (Maybe a) + -> RIO env (Maybe a) cacheByGet key = do cache <- ghsCacheBy <$> get pure $ Cache.cacheByGet key cache @@ -1194,10 +1195,10 @@ cacheByGet key = do -- | Sets a value in the cache used by 'cachedBy'. -- -- @since 1.6.10 -cacheBySet :: (MonadHandler m, Typeable a) +cacheBySet :: (HasHandlerData env, Typeable a) => S.ByteString -> a - -> m () + -> RIO env () cacheBySet key value = do gs <- get let cache = ghsCacheBy gs @@ -1221,7 +1222,7 @@ cacheBySet key value = do -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). -languages :: MonadHandler m => m [Text] +languages :: HasHandlerData env => RIO env [Text] languages = do mlang <- lookupSession langKey langs <- reqLangs <$> getRequest @@ -1233,13 +1234,13 @@ lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup a request header. -- -- @since 1.2.2 -lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString) +lookupHeader :: HasHandlerData env => CI S8.ByteString -> RIO env (Maybe S8.ByteString) lookupHeader = fmap listToMaybe . lookupHeaders -- | Lookup a request header. -- -- @since 1.2.2 -lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString] +lookupHeaders :: HasHandlerData env => CI S8.ByteString -> RIO env [S8.ByteString] lookupHeaders key = do req <- waiRequest return $ lookup' key $ W.requestHeaders req @@ -1248,7 +1249,7 @@ lookupHeaders key = do -- request. Returns user name and password -- -- @since 1.4.9 -lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) +lookupBasicAuth :: (HasHandlerData env) => RIO env (Maybe (Text, Text)) lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") where getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode) @@ -1258,7 +1259,7 @@ lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") -- request. Returns bearer token value -- -- @since 1.4.9 -lookupBearerAuth :: (MonadHandler m) => m (Maybe Text) +lookupBearerAuth :: (HasHandlerData env) => RIO env (Maybe Text) lookupBearerAuth = fmap (>>= getBR) (lookupHeader "Authorization") where @@ -1267,46 +1268,46 @@ lookupBearerAuth = fmap (>>= getBR) -- | Lookup for GET parameters. -lookupGetParams :: MonadHandler m => Text -> m [Text] +lookupGetParams :: HasHandlerData env => Text -> RIO env [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: MonadHandler m => Text -> m (Maybe Text) +lookupGetParam :: HasHandlerData env => Text -> RIO env (Maybe Text) lookupGetParam = fmap listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text] +lookupPostParams :: HasHandlerData env => Text -> RIO env [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: (MonadResource m, MonadHandler m) +lookupPostParam :: HasHandlerData env => Text - -> m (Maybe Text) + -> RIO env (Maybe Text) lookupPostParam = fmap listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: MonadHandler m +lookupFile :: HasHandlerData env => Text - -> m (Maybe FileInfo) + -> RIO env (Maybe FileInfo) lookupFile = fmap listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: MonadHandler m +lookupFiles :: HasHandlerData env => Text - -> m [FileInfo] + -> RIO env [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: MonadHandler m => Text -> m (Maybe Text) +lookupCookie :: HasHandlerData env => Text -> RIO env (Maybe Text) lookupCookie = fmap listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: MonadHandler m => Text -> m [Text] +lookupCookies :: HasHandlerData env => Text -> RIO env [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr @@ -1332,9 +1333,9 @@ lookupCookies pn = do -- provided inside this do-block. Should be used together with 'provideRep'. -- -- @since 1.2.0 -selectRep :: MonadHandler m - => Writer.Writer (Endo [ProvidedRep m]) () - -> m TypedContent +selectRep :: HasHandlerData env + => Writer.Writer (Endo [ProvidedRep (RIO env)]) () + -> RIO env TypedContent selectRep w = do -- the content types are already sorted by q values -- which have been stripped @@ -1411,7 +1412,7 @@ provideRepType ct handler = -- | Stream in the raw request body without any parsing. -- -- @since 1.2.0 -rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m () +rawRequestBody :: HasHandlerData env => ConduitT i S.ByteString (RIO env) () rawRequestBody = do req <- lift waiRequest let loop = do @@ -1457,12 +1458,13 @@ respond ct = return . TypedContent ct . toContent respondSource :: ContentType -> ConduitT () (Flush Builder) (HandlerFor site) () -> HandlerFor site TypedContent -respondSource ctype src = HandlerFor $ \hd -> +respondSource ctype src = do + hd <- ask -- Note that this implementation relies on the fact that the ResourceT -- environment provided by the server is the same one used in HandlerT. -- This is a safe assumption assuming the HandlerT is run correctly. return $ TypedContent ctype $ ContentSource - $ transPipe (lift . flip unHandlerFor hd) src + $ transPipe (runRIO hd) src -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. @@ -1547,7 +1549,7 @@ sendChunkHtml = sendChunk -- | The default cookie name for the CSRF token ("XSRF-TOKEN"). -- -- @since 1.4.14 -defaultCsrfCookieName :: S8.ByteString +defaultCsrfCookieName :: IsString s => s defaultCsrfCookieName = "XSRF-TOKEN" -- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name. @@ -1555,7 +1557,7 @@ defaultCsrfCookieName = "XSRF-TOKEN" -- The cookie's path is set to @/@, making it valid for your whole website. -- -- @since 1.4.14 -setCsrfCookie :: MonadHandler m => m () +setCsrfCookie :: HasHandlerData env => RIO env () setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie { setCookieName = defaultCsrfCookieName , setCookiePath = Just "/" @@ -1566,7 +1568,7 @@ setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- -- @since 1.4.14 -setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m () +setCsrfCookieWithCookie :: HasHandlerData env => SetCookie -> RIO env () setCsrfCookieWithCookie cookie = do mCsrfToken <- reqToken <$> getRequest Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token }) @@ -1581,7 +1583,7 @@ defaultCsrfHeaderName = "X-XSRF-TOKEN" -- this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 -checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () +checkCsrfHeaderNamed :: HasHandlerData env => CI S8.ByteString -> RIO env () checkCsrfHeaderNamed headerName = do (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader]) @@ -1589,11 +1591,11 @@ checkCsrfHeaderNamed headerName = do -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 -hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool +hasValidCsrfHeaderNamed :: HasHandlerData env => CI S8.ByteString -> RIO env Bool hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName -- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages. -hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text) +hasValidCsrfHeaderNamed' :: HasHandlerData env => CI S8.ByteString -> RIO env (Bool, Maybe Text) hasValidCsrfHeaderNamed' headerName = do mCsrfToken <- reqToken <$> getRequest mXsrfHeader <- lookupHeader headerName @@ -1612,7 +1614,7 @@ defaultCsrfParamName = "_token" -- this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 -checkCsrfParamNamed :: MonadHandler m => Text -> m () +checkCsrfParamNamed :: HasHandlerData env => Text -> RIO env () checkCsrfParamNamed paramName = do (valid, mParam) <- hasValidCsrfParamNamed' paramName unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam]) @@ -1620,11 +1622,11 @@ checkCsrfParamNamed paramName = do -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 -hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool +hasValidCsrfParamNamed :: HasHandlerData env => Text -> RIO env Bool hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName -- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages. -hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text) +hasValidCsrfParamNamed' :: HasHandlerData env => Text -> RIO env (Bool, Maybe Text) hasValidCsrfParamNamed' paramName = do mCsrfToken <- reqToken <$> getRequest mCsrfParam <- lookupPostParam paramName @@ -1635,16 +1637,16 @@ hasValidCsrfParamNamed' paramName = do -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 -checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m) +checkCsrfHeaderOrParam :: HasHandlerData env => CI S8.ByteString -- ^ The header name to lookup the CSRF token -> Text -- ^ The POST parameter name to lookup the CSRF token - -> m () + -> RIO env () checkCsrfHeaderOrParam headerName paramName = do (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName (validParam, mParam) <- hasValidCsrfParamNamed' paramName unless (validHeader || validParam) $ do let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam] - $logWarnS "yesod-core" errorMessage + logWarnS "yesod-core" errorMessage permissionDenied errorMessage validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool @@ -1657,30 +1659,30 @@ data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value | CSRFParam Text (Maybe Text) -- Key/Value csrfErrorMessage :: [CSRFExpectation] - -> Text -- ^ Error message -csrfErrorMessage expectedLocations = T.intercalate "\n" - [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether." - , "If you're a developer of this site, these tips will help you debug the issue:" - , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection." - , "- Check that your HTTP client is persisting cookies between requests, like a browser does." - , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "." - , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations) - ] + -> Utf8Builder -- ^ Error message +csrfErrorMessage expectedLocations = + "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether.\n" <> + "If you're a developer of this site, these tips will help you debug the issue:\n" <> + "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection.\n" <> + "- Check that your HTTP client is persisting cookies between requests, like a browser does.\n" <> + "- By default, the CSRF token is sent to the client in a cookie named " <> defaultCsrfCookieName <> ".\n" <> + "- The server is looking for the token in the following locations:\n" <> + foldMap (\x -> csrfLocation x <> "\n") expectedLocations where csrfLocation expected = case expected of - CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)] - CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)] + CSRFHeader k v -> " - An HTTP header named " <> display k <> " " <> formatValue v + CSRFParam k v -> " - A POST parameter named " <> display k <> " " <> formatValue v - formatValue :: Maybe Text -> Text + formatValue :: Maybe Text -> Utf8Builder formatValue maybeText = case maybeText of Nothing -> "(which is not currently set)" - Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"] + Just t -> "(which has the current, incorrect value: '" <> display t <> "')" -getSubYesod :: MonadHandler m => m (SubHandlerSite m) -getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv +getSubYesod :: HasHandlerData env => RIO env (SubHandlerSite env) +getSubYesod = view $ subHandlerDataL.to (rheChild . handlerEnv) -getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m)) -getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv +getRouteToParent :: HasHandlerData env => RIO env (Route (SubHandlerSite env) -> Route (HandlerSite env)) +getRouteToParent = view $ subHandlerDataL.to (rheRouteToMaster . handlerEnv) -getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m))) -getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv +getSubCurrentRoute :: HasHandlerData env => RIO env (Maybe (Route (SubHandlerSite env))) +getSubCurrentRoute = view $ subHandlerDataL.to (rheRoute . handlerEnv) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 0b00286c..6dc6bab6 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/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 ()) - -> ErrorResponse - -> YesodApp -safeEh log' er req = do - liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError - $ toLogStr $ "Error handler errored out: " ++ show er +safeEh :: LogFunc -> ErrorResponse -> YesodApp +safeEh logFunc er req = do + runRIO logFunc $ + logErrorS "yesod-core" $ + "Error handler errored out: " <> displayShow 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 - ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") +runFakeHandler fakeSessionMap logFunc site handler = liftIO $ do + 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 @@ -316,8 +310,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse Left yreq' -> yreq' Right needGen -> needGen yreGen let ra = resolveApproot yreSite req - let log' = messageLoggerSource yreSite yreLogger - -- We set up two environments: the first one has a "safe" error handler + let -- 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. @@ -328,8 +321,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse , rheChild = yreSite , rheSite = yreSite , rheUpload = fileUpload yreSite - , rheLog = log' - , rheOnError = safeEh log' + , rheLogFunc = yreLogFunc + , rheOnError = safeEh yreLogFunc , rheMaxExpires = maxExpires } rhe = rheSafe diff --git a/yesod-core/src/Yesod/Core/Json.hs b/yesod-core/src/Yesod/Core/Json.hs index 3ced0c56..e4afce05 100644 --- a/yesod-core/src/Yesod/Core/Json.hs +++ b/yesod-core/src/Yesod/Core/Json.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE NoImplicitPrelude #-} 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) - => Route (HandlerSite m) -- ^ Redirect target +jsonOrRedirect :: (HasHandlerData env, J.ToJSON a) + => 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) - => Route (HandlerSite m) -- ^ Redirect target +jsonEncodingOrRedirect :: (HasHandlerData env, J.ToJSON a) + => 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) diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 1d13e99a..00c3a42e 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/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.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 Control.Monad.Trans.Resource (ResourceT) import qualified Data.ByteString.Lazy as L import Data.CaseInsensitive (CI) -import Data.Conduit (Flush, ConduitT) -import Data.IORef (IORef, modifyIORef') -import Data.Map (Map, unionWith) -import qualified Data.Map as Map +import Conduit (Flush, ConduitT) +import RIO.Map (unionWith) +import qualified RIO.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 - { unHandlerFor :: HandlerData site site -> IO a - } - deriving Functor +type HandlerFor site = RIO (HandlerData site) 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 - { unWidgetFor :: WidgetData site -> IO a - } - deriving Functor +type WidgetFor site = RIO (WidgetData site) 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 d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d) +tellWidget :: HasWidgetData env => GWData (Route (HandlerSite env)) -> RIO env () +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. - | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ()) +data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length. + | 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 - { unSubHandlerFor :: HandlerData sub master -> IO a - } - deriving Functor +type SubHandlerFor sub master = RIO (SubHandlerData sub master) -instance Applicative (SubHandlerFor child master) where - pure = SubHandlerFor . const . return - (<*>) = ap -instance Monad (SubHandlerFor child master) where - return = pure - SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r -instance MonadIO (SubHandlerFor child master) where - liftIO = SubHandlerFor . const -instance MonadReader (HandlerData child master) (SubHandlerFor child master) where - ask = SubHandlerFor return - local f (SubHandlerFor g) = SubHandlerFor $ g . f +-- | Convert a concrete 'HandlerFor' action into an arbitrary other monad. +liftHandler + :: (MonadIO m, MonadReader env m, HasHandlerData env) + => HandlerFor (HandlerSite env) a + -> m a +liftHandler action = do + shd <- view subHandlerDataL + let hd = HandlerData $ shd + { handlerEnv = + let rhe = handlerEnv shd + in rhe + { rheRoute = rheRouteToMaster rhe <$> rheRoute rhe + , rheChild = rheSite rhe + , rheRouteToMaster = id + } + } + runRIO hd action --- | @since 1.4.38 -instance MonadUnliftIO (SubHandlerFor child master) where - {-# INLINE askUnliftIO #-} - askUnliftIO = SubHandlerFor $ \r -> - return (UnliftIO (flip unSubHandlerFor r)) - -instance MonadThrow (SubHandlerFor child master) where - throwM = liftIO . throwM - -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 +-- | Convert a concrete 'WidgetFor' action into an arbitrary other monad. +liftWidget + :: (MonadIO m, MonadReader env m, HasWidgetData env) + => WidgetFor (HandlerSite env) a + -> m a +liftWidget action = do + hd <- view widgetDataL + runRIO hd action diff --git a/yesod-core/src/Yesod/Core/Unsafe.hs b/yesod-core/src/Yesod/Core/Unsafe.hs index 3683ba91..9019ddd1 100644 --- a/yesod-core/src/Yesod/Core/Unsafe.hs +++ b/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 = - runFakeHandler mempty getLogger app f +fakeHandlerGetLogger logFunc app f = + runFakeHandler mempty logFunc app f >>= either (error . ("runFakeHandler issue: " `mappend`) . show) return diff --git a/yesod-core/src/Yesod/Core/Widget.hs b/yesod-core/src/Yesod/Core/Widget.hs index 4c37289c..7d274849 100644 --- a/yesod-core/src/Yesod/Core/Widget.hs +++ b/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 Data.Map as Map +import qualified RIO.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 - => Route (HandlerSite m) +addStylesheetAttrs :: HasWidgetData env + => 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 - => Either (Route (HandlerSite m)) Text - -> m () +addStylesheetEither :: HasWidgetData env + => Either (Route (HandlerSite env)) Text + -> RIO env () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: MonadWidget m - => Either (Route (HandlerSite m)) Text - -> m () +addScriptEither :: HasWidgetData env + => Either (Route (HandlerSite env)) Text + -> 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) - => HtmlUrlI18n message (Route (HandlerSite m)) - -> m Html +ihamletToRepHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message) + => HtmlUrlI18n message (Route (HandlerSite env)) + -> 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) - => HtmlUrlI18n message (Route (HandlerSite m)) - -> m Html +ihamletToHtml :: (HasHandlerData env, RenderMessage (HandlerSite env) message) + => HtmlUrlI18n message (Route (HandlerSite env)) + -> 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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 048342ce..3f79dcb2 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 0a980c87..0fafcf45 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/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| diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 404a35fd..8c7ff35d 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -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-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