haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-core moved over to rio

Browse Source
This commit is contained in:
Michael Snoyman 2019-02-19 13:03:29 +02:00
parent c67c89007c
commit 950c8e5a77
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
15 changed files with 468 additions and 775 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-core/ChangeLog.md
View File

@ -1,5 +1,9 @@
# ChangeLog for yesod-core # ChangeLog for yesod-core
## 2.0.0.0
* Switch over to using `rio`
## 1.6.12 ## 1.6.12
* Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581) * Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)

45
yesod-core/src/Yesod/Core.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Yesod.Core module Yesod.Core
( -- * Type classes ( -- * Type classes
@ -29,10 +30,6 @@ module Yesod.Core
, AuthResult (..) , AuthResult (..)
, unauthorizedI , unauthorizedI
-- * Logging -- * Logging
, defaultMakeLogger
, defaultMessageLoggerSource
, defaultShouldLogIO
, formatLogMessage
, LogLevel (..) , LogLevel (..)
, logDebug , logDebug
, logInfo , logInfo
@ -67,8 +64,10 @@ module Yesod.Core
, ScriptLoadPosition (..) , ScriptLoadPosition (..)
, BottomOfHeadAsync , BottomOfHeadAsync
-- * Generalizing type classes -- * Generalizing type classes
, MonadHandler (..) , HasHandlerData (..)
, MonadWidget (..) , HasWidgetData (..)
, liftHandler
, liftWidget
-- * Approot -- * Approot
, guessApproot , guessApproot
, guessApprootOr , guessApprootOr
@ -76,7 +75,6 @@ module Yesod.Core
-- * Misc -- * Misc
, yesodVersion , yesodVersion
, yesodRender , yesodRender
, Yesod.Core.runFakeHandler
-- * LiteApp -- * LiteApp
, module Yesod.Core.Internal.LiteApp , module Yesod.Core.Internal.LiteApp
-- * Low-level -- * Low-level
@ -94,12 +92,9 @@ module Yesod.Core
, MonadIO (..) , MonadIO (..)
, MonadUnliftIO (..) , MonadUnliftIO (..)
, MonadResource (..) , MonadResource (..)
, MonadLogger , RIO
-- * Commonly referenced functions/datatypes -- * Commonly referenced functions/datatypes
, Application , Application
-- * Utilities
, showIntegral
, readIntegral
-- * Shakespeare -- * Shakespeare
-- ** Hamlet -- ** Hamlet
, hamlet , hamlet
@ -120,7 +115,6 @@ module Yesod.Core
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Core.Dispatch import Yesod.Core.Dispatch
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Core.Class.Handler
import Yesod.Core.Widget import Yesod.Core.Widget
import Yesod.Core.Json import Yesod.Core.Json
import Yesod.Core.Types import Yesod.Core.Types
@ -128,18 +122,16 @@ import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup) import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
import Control.Monad.Logger
import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Internal.Run (yesodRunner, yesodRender) import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
import Yesod.Core.Class.Yesod import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Dispatch
import Yesod.Core.Class.Breadcrumbs import Yesod.Core.Class.Breadcrumbs
import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)
import Yesod.Routes.Class import Yesod.Routes.Class
import UnliftIO (MonadIO (..), MonadUnliftIO (..)) import RIO
import Control.Monad.Trans.Resource (MonadResource (..)) import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp import Yesod.Core.Internal.LiteApp
@ -149,17 +141,11 @@ import Text.Lucius
import Text.Julius import Text.Julius
import Network.Wai (Application) 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. -- | 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 unauthorizedI msg = do
mr <- getMessageRender mr <- getMessageRender
return $ Unauthorized $ mr msg return $ Unauthorized $ mr msg
@ -178,12 +164,3 @@ maybeAuthorized :: Yesod site
maybeAuthorized r isWrite = do maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing 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

13
yesod-core/src/Yesod/Core/Class/Dispatch.hs
View File

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

120
yesod-core/src/Yesod/Core/Class/Handler.hs
View File

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

155
yesod-core/src/Yesod/Core/Class/Yesod.hs
View File

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

75
yesod-core/src/Yesod/Core/Dispatch.hs
View File

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

384
yesod-core/src/Yesod/Core/Handler.hs
View File

File diff suppressed because it is too large Load Diff

49
yesod-core/src/Yesod/Core/Internal/Run.hs
View File

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

41
yesod-core/src/Yesod/Core/Json.hs
View File

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

266
yesod-core/src/Yesod/Core/Types.hs
View File

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

9
yesod-core/src/Yesod/Core/Unsafe.hs
View File

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

68
yesod-core/src/Yesod/Core/Widget.hs
View File

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

2
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

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

6
yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
View File

@ -21,13 +21,13 @@ import qualified Data.ByteString.Lazy.Char8 as L8
getSubsite :: a -> Subsite getSubsite :: a -> Subsite
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
getBarR :: MonadHandler m => m T.Text getBarR :: Monad m => m T.Text
getBarR = return $ T.pack "BarR" 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|] 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 getBinR = do
routeToParent <- getRouteToParent routeToParent <- getRouteToParent
liftHandler $ defaultLayout [whamlet| liftHandler $ defaultLayout [whamlet|

6
yesod-core/yesod-core.cabal
View File

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