{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Core.Internal.Run
( toErrorHandler
, errFromShow
, basicRunHandler
, handleError
, handleContents
, evalFallback
, runHandler
, safeEh
, runFakeHandler
, yesodRunner
, yesodRender
, resolveApproot
)
where
import qualified Control.Exception as EUnsafe
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)
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
import Yesod.Core.Internal.Request (parseWaiRequest,
tooLargeResponse)
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData)
import UnliftIO.Exception
import UnliftIO(MonadUnliftIO, withRunInIO)
import Data.Proxy(Proxy(..))
toErrorHandler :: SomeException -> IO ErrorResponse
toErrorHandler :: SomeException -> IO ErrorResponse
toErrorHandler SomeException
e0 = (SomeException -> IO ErrorResponse)
-> IO ErrorResponse -> IO ErrorResponse
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny SomeException -> IO ErrorResponse
errFromShow (IO ErrorResponse -> IO ErrorResponse)
-> IO ErrorResponse -> IO ErrorResponse
forall a b. (a -> b) -> a -> b
$
case SomeException -> Maybe HandlerContents
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e0 of
Just (HCError ErrorResponse
x) -> ErrorResponse -> IO ErrorResponse
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (ErrorResponse -> IO ErrorResponse)
-> ErrorResponse -> IO ErrorResponse
forall a b. NFData a => (a -> b) -> a -> b
$!! ErrorResponse
x
Maybe HandlerContents
_ -> SomeException -> IO ErrorResponse
errFromShow SomeException
e0
errFromShow :: SomeException -> IO ErrorResponse
errFromShow :: SomeException -> IO ErrorResponse
errFromShow SomeException
x = do
text <- LogSource -> IO LogSource
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate ([Char] -> LogSource
T.pack ([Char] -> LogSource) -> [Char] -> LogSource
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
x) IO LogSource -> (SomeException -> IO LogSource) -> IO LogSource
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ ->
LogSource -> IO LogSource
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> LogSource
T.pack [Char]
"Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
return $ InternalError text
basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site site
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
basicRunHandler :: forall c site.
ToTypedContent c =>
RunHandlerEnv site site
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
basicRunHandler RunHandlerEnv site site
rhe HandlerFor site c
handler YesodRequest
yreq InternalState
resState = do
istate <- GHState -> IO (IORef GHState)
forall a. a -> IO (IORef a)
I.newIORef GHState
defState
contents' <- rheCatchHandlerExceptions rhe
(do
res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res)
return (HCContent defaultStatus tc))
(\SomeException
e ->
case SomeException -> Maybe HandlerContents
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just HandlerContents
e' -> HandlerContents -> IO HandlerContents
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerContents
e'
Maybe HandlerContents
Nothing -> ErrorResponse -> HandlerContents
HCError (ErrorResponse -> HandlerContents)
-> IO ErrorResponse -> IO HandlerContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> IO ErrorResponse
toErrorHandler SomeException
e)
state <- I.readIORef istate
return (state, contents')
where
defState :: GHState
defState = GHState
{ ghsSession :: SessionMap
ghsSession = YesodRequest -> SessionMap
reqSession YesodRequest
yreq
, ghsRBC :: Maybe RequestBodyContents
ghsRBC = Maybe RequestBodyContents
forall a. Maybe a
Nothing
, ghsIdent :: Int
ghsIdent = Int
1
, ghsCache :: TypeMap
ghsCache = TypeMap
forall a. Monoid a => a
mempty
, ghsCacheBy :: KeyedTypeMap
ghsCacheBy = KeyedTypeMap
forall a. Monoid a => a
mempty
, ghsHeaders :: Endo [Header]
ghsHeaders = Endo [Header]
forall a. Monoid a => a
mempty
}
hd :: IORef GHState -> HandlerData site site
hd IORef GHState
istate = HandlerData
{ handlerRequest :: YesodRequest
handlerRequest = YesodRequest
yreq
, handlerEnv :: RunHandlerEnv site site
handlerEnv = RunHandlerEnv site site
rhe
, handlerState :: IORef GHState
handlerState = IORef GHState
istate
, handlerResource :: InternalState
handlerResource = InternalState
resState
}
handleError :: RunHandlerEnv sub site
-> YesodRequest
-> InternalState
-> Map.Map Text S8.ByteString
-> [Header]
-> ErrorResponse
-> IO YesodResponse
handleError :: forall sub site.
RunHandlerEnv sub site
-> YesodRequest
-> InternalState
-> SessionMap
-> [Header]
-> ErrorResponse
-> IO YesodResponse
handleError RunHandlerEnv sub site
rhe YesodRequest
yreq InternalState
resState SessionMap
finalSession [Header]
headers ErrorResponse
e0 = do
e <- (ErrorResponse -> IO ErrorResponse
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (ErrorResponse -> IO ErrorResponse)
-> ErrorResponse -> IO ErrorResponse
forall a b. NFData a => (a -> b) -> a -> b
$!! ErrorResponse
e0) IO ErrorResponse
-> (SomeException -> IO ErrorResponse) -> IO ErrorResponse
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` SomeException -> IO ErrorResponse
errFromShow
flip runInternalState resState $ do
yar <- rheOnError rhe e yreq
{ reqSession = finalSession
}
case yar of
YRPlain Status
status' [Header]
hs ByteString
ct Content
c SessionMap
sess ->
let hs' :: [Header]
hs' = [Header]
headers [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
hs
status :: Status
status
| Status
status' Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
defaultStatus = ErrorResponse -> Status
getStatus ErrorResponse
e
| Bool
otherwise = Status
status'
in YesodResponse -> ResourceT IO YesodResponse
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> ResourceT IO YesodResponse)
-> YesodResponse -> ResourceT IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain Status
status [Header]
hs' ByteString
ct Content
c SessionMap
sess
YRWai Response
_ -> YesodResponse -> ResourceT IO YesodResponse
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return YesodResponse
yar
YRWaiApp Application
_ -> YesodResponse -> ResourceT IO YesodResponse
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return YesodResponse
yar
handleContents :: (ErrorResponse -> IO YesodResponse)
-> Map.Map Text S8.ByteString
-> [Header]
-> HandlerContents
-> IO YesodResponse
handleContents :: (ErrorResponse -> IO YesodResponse)
-> SessionMap -> [Header] -> HandlerContents -> IO YesodResponse
handleContents ErrorResponse -> IO YesodResponse
handleError' SessionMap
finalSession [Header]
headers HandlerContents
contents =
case HandlerContents
contents of
HCContent Status
status (TypedContent ByteString
ct Content
c) -> do
ec' <- Content -> IO (Either ErrorResponse Content)
evaluateContent Content
c
case ec' of
Left ErrorResponse
e -> ErrorResponse -> IO YesodResponse
handleError' ErrorResponse
e
Right Content
c' -> YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain Status
status [Header]
headers ByteString
ct Content
c' SessionMap
finalSession
HCError ErrorResponse
e -> ErrorResponse -> IO YesodResponse
handleError' ErrorResponse
e
HCRedirect Status
status LogSource
loc -> do
let disable_caching :: [Header] -> [Header]
disable_caching [Header]
x =
CI ByteString -> ByteString -> Header
Header CI ByteString
"Cache-Control" ByteString
"no-cache, must-revalidate"
Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: CI ByteString -> ByteString -> Header
Header CI ByteString
"Expires" ByteString
"Thu, 01 Jan 1970 05:05:05 GMT"
Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
x
hs :: [Header]
hs = (if Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Status
H.movedPermanently301 then [Header] -> [Header]
disable_caching else [Header] -> [Header]
forall a. a -> a
id)
([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Header
Header CI ByteString
"Location" (LogSource -> ByteString
encodeUtf8 LogSource
loc) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers
YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain
Status
status [Header]
hs ByteString
typePlain Content
emptyContent
SessionMap
finalSession
HCSendFile ByteString
ct [Char]
fp Maybe FilePart
p -> YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain
Status
H.status200
[Header]
headers
ByteString
ct
([Char] -> Maybe FilePart -> Content
ContentFile [Char]
fp Maybe FilePart
p)
SessionMap
finalSession
HCCreated LogSource
loc -> YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain
Status
H.status201
(CI ByteString -> ByteString -> Header
Header CI ByteString
"Location" (LogSource -> ByteString
encodeUtf8 LogSource
loc) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers)
ByteString
typePlain
Content
emptyContent
SessionMap
finalSession
HCWai Response
r -> YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Response -> YesodResponse
YRWai Response
r
HCWaiApp Application
a -> YesodResponse -> IO YesodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Application -> YesodResponse
YRWaiApp Application
a
evalFallback :: (Monoid w, NFData w)
=> (forall a. IO a -> (SomeException -> IO a) -> IO a)
-> HandlerContents
-> w
-> IO (w, HandlerContents)
evalFallback :: forall w.
(Monoid w, NFData w) =>
(forall a. IO a -> (SomeException -> IO a) -> IO a)
-> HandlerContents -> w -> IO (w, HandlerContents)
evalFallback forall a. IO a -> (SomeException -> IO a) -> IO a
catcher HandlerContents
contents w
val = IO (w, HandlerContents)
-> (SomeException -> IO (w, HandlerContents))
-> IO (w, HandlerContents)
forall a. IO a -> (SomeException -> IO a) -> IO a
catcher
((w -> (w, HandlerContents)) -> IO w -> IO (w, HandlerContents)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, HandlerContents
contents) (w -> IO w
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (w -> IO w) -> w -> IO w
forall a b. NFData a => (a -> b) -> a -> b
$!! w
val))
((ErrorResponse -> (w, HandlerContents))
-> IO ErrorResponse -> IO (w, HandlerContents)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((w
forall a. Monoid a => a
mempty, ) (HandlerContents -> (w, HandlerContents))
-> (ErrorResponse -> HandlerContents)
-> ErrorResponse
-> (w, HandlerContents)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> HandlerContents
HCError) (IO ErrorResponse -> IO (w, HandlerContents))
-> (SomeException -> IO ErrorResponse)
-> SomeException
-> IO (w, HandlerContents)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO ErrorResponse
toErrorHandler)
runHandler :: ToTypedContent c
=> RunHandlerEnv site site
-> HandlerFor site c
-> YesodApp
runHandler :: forall c site.
ToTypedContent c =>
RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler rhe :: RunHandlerEnv site site
rhe@RunHandlerEnv {site
Maybe (Route site)
LogSource
Route site -> Route site
Route site -> [(LogSource, LogSource)] -> LogSource
Loc -> LogSource -> LogLevel -> LogStr -> IO ()
RequestBodyLength -> FileUpload
ErrorResponse -> YesodApp
forall a (m :: * -> *).
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
rheCatchHandlerExceptions :: forall child site.
RunHandlerEnv child site
-> forall a (m :: * -> *).
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
rheOnError :: forall child site.
RunHandlerEnv child site -> ErrorResponse -> YesodApp
rheRender :: Route site -> [(LogSource, LogSource)] -> LogSource
rheRoute :: Maybe (Route site)
rheRouteToMaster :: Route site -> Route site
rheSite :: site
rheChild :: site
rheUpload :: RequestBodyLength -> FileUpload
rheLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
rheOnError :: ErrorResponse -> YesodApp
rheMaxExpires :: LogSource
rheCatchHandlerExceptions :: forall a (m :: * -> *).
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
rheMaxExpires :: forall child site. RunHandlerEnv child site -> LogSource
rheLog :: forall child site.
RunHandlerEnv child site
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
rheUpload :: forall child site.
RunHandlerEnv child site -> RequestBodyLength -> FileUpload
rheChild :: forall child site. RunHandlerEnv child site -> child
rheSite :: forall child site. RunHandlerEnv child site -> site
rheRouteToMaster :: forall child site.
RunHandlerEnv child site -> Route child -> Route site
rheRoute :: forall child site. RunHandlerEnv child site -> Maybe (Route child)
rheRender :: forall child site.
RunHandlerEnv child site
-> Route site -> [(LogSource, LogSource)] -> LogSource
..} HandlerFor site c
handler YesodRequest
yreq = (InternalState -> IO YesodResponse) -> ResourceT IO YesodResponse
forall (m :: * -> *) a. (InternalState -> m a) -> ResourceT m a
withInternalState ((InternalState -> IO YesodResponse) -> ResourceT IO YesodResponse)
-> (InternalState -> IO YesodResponse)
-> ResourceT IO YesodResponse
forall a b. (a -> b) -> a -> b
$ \InternalState
resState -> do
(state, contents0) <- RunHandlerEnv site site
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
forall c site.
ToTypedContent c =>
RunHandlerEnv site site
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
basicRunHandler RunHandlerEnv site site
rhe HandlerFor site c
handler YesodRequest
yreq InternalState
resState
(finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
(headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
handleContents
(handleError rhe yreq resState finalSession headers)
finalSession
headers
contents3
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
-> YesodApp
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> YesodApp
safeEh Loc -> LogSource -> LogLevel -> LogStr -> IO ()
log' ErrorResponse
er YesodRequest
req = do
IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ Loc -> LogSource -> LogLevel -> LogStr -> IO ()
log' $(qLocation >>= liftLoc) LogSource
"yesod-core" LogLevel
LevelError
(LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ([Char] -> LogStr) -> [Char] -> LogStr
forall a b. (a -> b) -> a -> b
$ [Char]
"Error handler errored out: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ErrorResponse -> [Char]
forall a. Show a => a -> [Char]
show ErrorResponse
er
YesodResponse -> ResourceT IO YesodResponse
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> ResourceT IO YesodResponse)
-> YesodResponse -> ResourceT IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain
Status
H.status500
[]
ByteString
typePlain
(ByteString -> Content
forall a. ToContent a => a -> Content
toContent (ByteString
"Internal Server Error" :: S.ByteString))
(YesodRequest -> SessionMap
reqSession YesodRequest
req)
runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site a
-> m (Either ErrorResponse a)
runFakeHandler :: forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerFor site a
-> m (Either ErrorResponse a)
runFakeHandler SessionMap
fakeSessionMap site -> Logger
logger site
site HandlerFor site a
handler = IO (Either ErrorResponse a) -> m (Either ErrorResponse a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorResponse a) -> m (Either ErrorResponse a))
-> IO (Either ErrorResponse a) -> m (Either ErrorResponse a)
forall a b. (a -> b) -> a -> b
$ do
ret <- Either ErrorResponse a -> IO (IORef (Either ErrorResponse a))
forall a. a -> IO (IORef a)
I.newIORef (ErrorResponse -> Either ErrorResponse a
forall a b. a -> Either a b
Left (ErrorResponse -> Either ErrorResponse a)
-> ErrorResponse -> Either ErrorResponse a
forall a b. (a -> b) -> a -> b
$ LogSource -> ErrorResponse
InternalError LogSource
"runFakeHandler: no result")
maxExpires <- getCurrentMaxExpiresRFC1123
let handler' = IO () -> HandlerFor site ()
forall a. IO a -> HandlerFor site a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerFor site ())
-> (a -> IO ()) -> a -> HandlerFor site ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Either ErrorResponse a) -> Either ErrorResponse a -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef (Either ErrorResponse a)
ret (Either ErrorResponse a -> IO ())
-> (a -> Either ErrorResponse a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either ErrorResponse a
forall a b. b -> Either a b
Right (a -> HandlerFor site ())
-> HandlerFor site a -> HandlerFor site ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HandlerFor site a
handler
let yapp = RunHandlerEnv site site -> HandlerFor site () -> YesodApp
forall c site.
ToTypedContent c =>
RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler
RunHandlerEnv
{ rheRender :: Route site -> [(LogSource, LogSource)] -> LogSource
rheRender = site
-> LogSource -> Route site -> [(LogSource, LogSource)] -> LogSource
forall y.
Yesod y =>
y -> LogSource -> Route y -> [(LogSource, LogSource)] -> LogSource
yesodRender site
site (LogSource -> Route site -> [(LogSource, LogSource)] -> LogSource)
-> LogSource -> Route site -> [(LogSource, LogSource)] -> LogSource
forall a b. (a -> b) -> a -> b
$ site -> Request -> LogSource
forall master. Yesod master => master -> Request -> LogSource
resolveApproot site
site Request
fakeWaiRequest
, rheRoute :: Maybe (Route site)
rheRoute = Maybe (Route site)
forall a. Maybe a
Nothing
, rheRouteToMaster :: Route site -> Route site
rheRouteToMaster = Route site -> Route site
forall a. a -> a
id
, rheChild :: site
rheChild = site
site
, rheSite :: site
rheSite = site
site
, rheUpload :: RequestBodyLength -> FileUpload
rheUpload = site -> RequestBodyLength -> FileUpload
forall site. Yesod site => site -> RequestBodyLength -> FileUpload
fileUpload site
site
, rheLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
rheLog = site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource site
site (Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ site -> Logger
logger site
site
, rheOnError :: ErrorResponse -> YesodApp
rheOnError = ErrorResponse -> YesodApp
forall {m :: * -> *}.
MonadIO m =>
ErrorResponse -> YesodRequest -> m YesodResponse
errHandler
, rheMaxExpires :: LogSource
rheMaxExpires = LogSource
maxExpires
, rheCatchHandlerExceptions :: forall a (m :: * -> *).
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
rheCatchHandlerExceptions = site -> m a -> (SomeException -> m a) -> m a
forall site (m :: * -> *) a.
(Yesod site, MonadUnliftIO m) =>
site -> m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
site -> m a -> (SomeException -> m a) -> m a
catchHandlerExceptions site
site
}
HandlerFor site ()
handler'
errHandler ErrorResponse
err YesodRequest
req = do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either ErrorResponse a) -> Either ErrorResponse a -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef (Either ErrorResponse a)
ret (ErrorResponse -> Either ErrorResponse a
forall a b. a -> Either a b
Left ErrorResponse
err)
YesodResponse -> m YesodResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> m YesodResponse)
-> YesodResponse -> m YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header] -> ByteString -> Content -> SessionMap -> YesodResponse
YRPlain
Status
H.status500
[]
ByteString
typePlain
(ByteString -> Content
forall a. ToContent a => a -> Content
toContent (ByteString
"runFakeHandler: errHandler" :: S8.ByteString))
(YesodRequest -> SessionMap
reqSession YesodRequest
req)
fakeWaiRequest = Request
{ requestMethod :: ByteString
requestMethod = ByteString
"POST"
, httpVersion :: HttpVersion
httpVersion = HttpVersion
H.http11
, rawPathInfo :: ByteString
rawPathInfo = ByteString
"/runFakeHandler/pathInfo"
, rawQueryString :: ByteString
rawQueryString = ByteString
""
, requestHeaderHost :: Maybe ByteString
requestHeaderHost = Maybe ByteString
forall a. Maybe a
Nothing
, requestHeaders :: RequestHeaders
requestHeaders = []
, isSecure :: Bool
isSecure = Bool
False
, remoteHost :: SockAddr
remoteHost = [Char] -> SockAddr
forall a. HasCallStack => [Char] -> a
error [Char]
"runFakeHandler-remoteHost"
, pathInfo :: [LogSource]
pathInfo = [LogSource
"runFakeHandler", LogSource
"pathInfo"]
, queryString :: Query
queryString = []
, requestBody :: IO ByteString
requestBody = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty
, vault :: Vault
vault = Vault
forall a. Monoid a => a
mempty
, requestBodyLength :: RequestBodyLength
requestBodyLength = Word64 -> RequestBodyLength
KnownLength Word64
0
, requestHeaderRange :: Maybe ByteString
requestHeaderRange = Maybe ByteString
forall a. Maybe a
Nothing
, requestHeaderReferer :: Maybe ByteString
requestHeaderReferer = Maybe ByteString
forall a. Maybe a
Nothing
, requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = Maybe ByteString
forall a. Maybe a
Nothing
}
fakeRequest =
YesodRequest
{ reqGetParams :: [(LogSource, LogSource)]
reqGetParams = []
, reqCookies :: [(LogSource, LogSource)]
reqCookies = []
, reqWaiRequest :: Request
reqWaiRequest = Request
fakeWaiRequest
, reqLangs :: [LogSource]
reqLangs = []
, reqToken :: Maybe LogSource
reqToken = LogSource -> Maybe LogSource
forall a. a -> Maybe a
Just LogSource
"NaN"
, reqAccept :: [ByteString]
reqAccept = []
, reqSession :: SessionMap
reqSession = SessionMap
fakeSessionMap
}
_ <- runResourceT $ yapp fakeRequest
I.readIORef ret
yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
=> HandlerFor site res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
yesodRunner :: forall res site.
(ToTypedContent res, Yesod site) =>
HandlerFor site res
-> YesodRunnerEnv site -> Maybe (Route site) -> Application
yesodRunner HandlerFor site res
handler' YesodRunnerEnv {site
Maybe SessionBackend
IO Int
IO LogSource
Logger
yreLogger :: Logger
yreSite :: site
yreSessionBackend :: Maybe SessionBackend
yreGen :: IO Int
yreGetMaxExpires :: IO LogSource
yreGetMaxExpires :: forall site. YesodRunnerEnv site -> IO LogSource
yreGen :: forall site. YesodRunnerEnv site -> IO Int
yreSessionBackend :: forall site. YesodRunnerEnv site -> Maybe SessionBackend
yreSite :: forall site. YesodRunnerEnv site -> site
yreLogger :: forall site. YesodRunnerEnv site -> Logger
..} Maybe (Route site)
route Request
req Response -> IO ResponseReceived
sendResponse = do
mmaxLen <- site -> Maybe (Route site) -> IO (Maybe Word64)
forall site.
Yesod site =>
site -> Maybe (Route site) -> IO (Maybe Word64)
maximumContentLengthIO site
yreSite Maybe (Route site)
route
case (mmaxLen, requestBodyLength req) of
(Just Word64
maxLen, KnownLength Word64
len) | Word64
maxLen Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
len -> Response -> IO ResponseReceived
sendResponse (Word64 -> Word64 -> Response
tooLargeResponse Word64
maxLen Word64
len)
(Maybe Word64, RequestBodyLength)
_ -> do
let dontSaveSession :: p -> m [a]
dontSaveSession p
_ = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
(session, saveSession) <- IO (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header]))
-> IO (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
forall a b. (a -> b) -> a -> b
$
IO (SessionMap, SessionMap -> IO [Header])
-> (SessionBackend -> IO (SessionMap, SessionMap -> IO [Header]))
-> Maybe SessionBackend
-> IO (SessionMap, SessionMap -> IO [Header])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionMap
forall k a. Map k a
Map.empty, SessionMap -> IO [Header]
forall {m :: * -> *} {p} {a}. Monad m => p -> m [a]
dontSaveSession)) (SessionBackend
-> Request -> IO (SessionMap, SessionMap -> IO [Header])
`sbLoadSession` Request
req) Maybe SessionBackend
yreSessionBackend
maxExpires <- yreGetMaxExpires
let mkYesodReq = Request
-> SessionMap
-> Bool
-> Maybe Word64
-> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
parseWaiRequest Request
req SessionMap
session (Maybe SessionBackend -> Bool
forall a. Maybe a -> Bool
isJust Maybe SessionBackend
yreSessionBackend) Maybe Word64
mmaxLen
let yreq =
case Either (IO YesodRequest) (IO Int -> IO YesodRequest)
mkYesodReq of
Left IO YesodRequest
yreq' -> IO YesodRequest
yreq'
Right IO Int -> IO YesodRequest
needGen -> IO Int -> IO YesodRequest
needGen IO Int
yreGen
let ra = site -> Request -> LogSource
forall master. Yesod master => master -> Request -> LogSource
resolveApproot site
yreSite Request
req
let log' = site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource site
yreSite Logger
yreLogger
rheSafe = RunHandlerEnv
{ rheRender :: Route site -> [(LogSource, LogSource)] -> LogSource
rheRender = site
-> LogSource -> Route site -> [(LogSource, LogSource)] -> LogSource
forall y.
Yesod y =>
y -> LogSource -> Route y -> [(LogSource, LogSource)] -> LogSource
yesodRender site
yreSite LogSource
ra
, rheRoute :: Maybe (Route site)
rheRoute = Maybe (Route site)
route
, rheRouteToMaster :: Route site -> Route site
rheRouteToMaster = Route site -> Route site
forall a. a -> a
id
, rheChild :: site
rheChild = site
yreSite
, rheSite :: site
rheSite = site
yreSite
, rheUpload :: RequestBodyLength -> FileUpload
rheUpload = site -> RequestBodyLength -> FileUpload
forall site. Yesod site => site -> RequestBodyLength -> FileUpload
fileUpload site
yreSite
, rheLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
rheLog = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
log'
, rheOnError :: ErrorResponse -> YesodApp
rheOnError = (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> YesodApp
safeEh Loc -> LogSource -> LogLevel -> LogStr -> IO ()
log'
, rheMaxExpires :: LogSource
rheMaxExpires = LogSource
maxExpires
, rheCatchHandlerExceptions :: forall a (m :: * -> *).
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
rheCatchHandlerExceptions = site -> m a -> (SomeException -> m a) -> m a
forall site (m :: * -> *) a.
(Yesod site, MonadUnliftIO m) =>
site -> m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
site -> m a -> (SomeException -> m a) -> m a
catchHandlerExceptions site
yreSite
}
rhe = RunHandlerEnv site site
rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
}
yesodWithInternalState yreSite route $ \InternalState
is -> do
yreq' <- IO YesodRequest
yreq
yar <- runInternalState (runHandler rhe handler yreq') is
yarToResponse yar saveSession yreq' req is sendResponse
where
mmaxLen :: Maybe Word64
mmaxLen = site -> Maybe (Route site) -> Maybe Word64
forall site.
Yesod site =>
site -> Maybe (Route site) -> Maybe Word64
maximumContentLength site
yreSite Maybe (Route site)
route
handler :: HandlerFor site res
handler = HandlerFor site res -> HandlerFor site res
forall res.
ToTypedContent res =>
HandlerFor site res -> HandlerFor site res
forall site res.
(Yesod site, ToTypedContent res) =>
HandlerFor site res -> HandlerFor site res
yesodMiddleware HandlerFor site res
handler'
yesodRender :: Yesod y
=> y
-> ResolvedApproot
-> Route y
-> [(Text, Text)]
-> Text
yesodRender :: forall y.
Yesod y =>
y -> LogSource -> Route y -> [(LogSource, LogSource)] -> LogSource
yesodRender y
y LogSource
ar Route y
url [(LogSource, LogSource)]
params =
OnDecodeError -> ByteString -> LogSource
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> LogSource) -> ByteString -> LogSource
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$
Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe
(y
-> LogSource -> [LogSource] -> [(LogSource, LogSource)] -> Builder
forall site.
Yesod site =>
site
-> LogSource -> [LogSource] -> [(LogSource, LogSource)] -> Builder
joinPath y
y LogSource
ar [LogSource]
ps
([(LogSource, LogSource)] -> Builder)
-> [(LogSource, LogSource)] -> Builder
forall a b. (a -> b) -> a -> b
$ [(LogSource, LogSource)]
params [(LogSource, LogSource)]
-> [(LogSource, LogSource)] -> [(LogSource, LogSource)]
forall a. [a] -> [a] -> [a]
++ [(LogSource, LogSource)]
params')
(y -> Route y -> [(LogSource, LogSource)] -> Maybe Builder
forall site.
Yesod site =>
site -> Route site -> [(LogSource, LogSource)] -> Maybe Builder
urlParamRenderOverride y
y Route y
url [(LogSource, LogSource)]
params)
where
([LogSource]
ps, [(LogSource, LogSource)]
params') = Route y -> ([LogSource], [(LogSource, LogSource)])
forall a.
RenderRoute a =>
Route a -> ([LogSource], [(LogSource, LogSource)])
renderRoute Route y
url
resolveApproot :: Yesod master => master -> Request -> ResolvedApproot
resolveApproot :: forall master. Yesod master => master -> Request -> LogSource
resolveApproot master
master Request
req =
case Approot master
forall site. Yesod site => Approot site
approot of
Approot master
ApprootRelative -> LogSource
""
ApprootStatic LogSource
t -> LogSource
t
ApprootMaster master -> LogSource
f -> master -> LogSource
f master
master
ApprootRequest master -> Request -> LogSource
f -> master -> Request -> LogSource
f master
master Request
req