yesod-core moved over to rio
This commit is contained in:
Michael Snoyman
parent
c67c89007c
commit
950c8e5a77
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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 <head> 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 \"\<unknown\>\". This is a hack,
|
||||
-- but it removes some of the visual clutter from non-TH logs.
|
||||
--
|
||||
-- Since 1.4.10
|
||||
formatLogMessage :: IO ZonedDate
|
||||
-> Loc
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO LogStr
|
||||
formatLogMessage getdate loc src level msg = do
|
||||
now <- getdate
|
||||
return $ mempty
|
||||
`mappend` toLogStr now
|
||||
`mappend` " ["
|
||||
`mappend` (case level of
|
||||
LevelOther t -> toLogStr t
|
||||
_ -> toLogStr $ drop 5 $ show level)
|
||||
`mappend` (if T.null src
|
||||
then mempty
|
||||
else "#" `mappend` toLogStr src)
|
||||
`mappend` "] "
|
||||
`mappend` msg
|
||||
`mappend` sourceSuffix
|
||||
`mappend` "\n"
|
||||
where
|
||||
sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty
|
||||
`mappend` " @("
|
||||
`mappend` toLogStr (fileLocationToString loc)
|
||||
`mappend` ")"
|
||||
|
||||
-- | Customize the cookies used by the session backend. You may
|
||||
-- use this function on your definition of 'makeSessionBackend'.
|
||||
--
|
||||
|
||||
@ -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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -56,7 +56,7 @@ instance Yesod App where
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
$logDebug "Testing logging"
|
||||
logDebug "Testing logging"
|
||||
defaultLayout $ toWidget [hamlet|
|
||||
$doctype 5
|
||||
|
||||
|
||||
@ -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|
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user