{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE FlexibleContexts  #-}
module Yesod.Core.Internal.Run where


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

-- | Convert a synchronous exception into an ErrorResponse
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

-- | Generate an @ErrorResponse@ based on the shown version of the exception
errFromShow :: SomeException -> IO ErrorResponse
errFromShow :: SomeException -> IO ErrorResponse
errFromShow SomeException
x = do
  Text
text <- Text -> IO Text
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
x) IO Text -> (SomeException -> IO Text) -> IO Text
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ ->
          Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack String
"Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
  ErrorResponse -> IO ErrorResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorResponse -> IO ErrorResponse)
-> ErrorResponse -> IO ErrorResponse
forall a b. (a -> b) -> a -> b
$ Text -> ErrorResponse
InternalError Text
text

-- | Do a basic run of a handler, getting some contents and the final
-- @GHState@. The @GHState@ unfortunately may contain some impure
-- exceptions, but all other synchronous exceptions will be caught and
-- represented by the @HandlerContents@.
basicRunHandler :: ToTypedContent c
                => RunHandlerEnv site site
                -> HandlerFor site c
                -> YesodRequest
                -> InternalState
                -> IO (GHState, HandlerContents)
basicRunHandler :: 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
    -- Create a mutable ref to hold the state. We use mutable refs so
    -- that the updates will survive runtime exceptions.
    IORef GHState
istate <- GHState -> IO (IORef GHState)
forall a. a -> IO (IORef a)
I.newIORef GHState
defState

    -- Run the handler itself, capturing any runtime exceptions and
    -- converting them into a @HandlerContents@
    HandlerContents
contents' <- IO HandlerContents
-> (SomeException -> IO HandlerContents) -> IO HandlerContents
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
        (do
            c
res <- HandlerFor site c -> HandlerData site site -> IO c
forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor HandlerFor site c
handler (IORef GHState -> HandlerData site site
hd IORef GHState
istate)
            TypedContent
tc <- TypedContent -> IO TypedContent
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (c -> TypedContent
forall a. ToTypedContent a => a -> TypedContent
toTypedContent c
res)
            -- Success! Wrap it up in an @HCContent@
            HandlerContents -> IO HandlerContents
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> TypedContent -> HandlerContents
HCContent Status
defaultStatus TypedContent
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 (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)

    -- Get the raw state and return
    GHState
state <- IORef GHState -> IO GHState
forall a. IORef a -> IO a
I.readIORef IORef GHState
istate
    (GHState, HandlerContents) -> IO (GHState, HandlerContents)
forall (m :: * -> *) a. Monad m => a -> m a
return (GHState
state, HandlerContents
contents')
  where
    defState :: GHState
defState = GHState :: SessionMap
-> Maybe RequestBodyContents
-> Int
-> TypeMap
-> KeyedTypeMap
-> Endo [Header]
-> GHState
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 :: forall child site.
YesodRequest
-> RunHandlerEnv child site
-> IORef GHState
-> InternalState
-> HandlerData child site
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
        }

-- | Convert an @ErrorResponse@ into a @YesodResponse@
handleError :: RunHandlerEnv sub site
            -> YesodRequest
            -> InternalState
            -> Map.Map Text S8.ByteString
            -> [Header]
            -> ErrorResponse
            -> IO YesodResponse
handleError :: 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
    -- Find any evil hidden impure exceptions
    ErrorResponse
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

    -- Generate a response, leveraging the updated session and
    -- response headers
    (ResourceT IO YesodResponse -> InternalState -> IO YesodResponse)
-> InternalState -> ResourceT IO YesodResponse -> IO YesodResponse
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT IO YesodResponse -> InternalState -> IO YesodResponse
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
resState (ResourceT IO YesodResponse -> IO YesodResponse)
-> ResourceT IO YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ do
        YesodResponse
yar <- RunHandlerEnv sub site -> ErrorResponse -> YesodApp
forall child site.
RunHandlerEnv child site -> ErrorResponse -> YesodApp
rheOnError RunHandlerEnv sub site
rhe ErrorResponse
e YesodRequest
yreq
            { reqSession :: SessionMap
reqSession = SessionMap
finalSession
            }
        case YesodResponse
yar of
            YRPlain Status
status' [Header]
hs ContentType
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 (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]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain Status
status [Header]
hs' ContentType
ct Content
c SessionMap
sess
            YRWai Response
_ -> YesodResponse -> ResourceT IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return YesodResponse
yar
            YRWaiApp Application
_ -> YesodResponse -> ResourceT IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return YesodResponse
yar

-- | Convert a @HandlerContents@ into a @YesodResponse@
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 ContentType
ct Content
c) -> do
            -- Check for impure exceptions hiding in the contents
            Either ErrorResponse Content
ec' <- Content -> IO (Either ErrorResponse Content)
evaluateContent Content
c
            case Either ErrorResponse Content
ec' of
                Left ErrorResponse
e -> ErrorResponse -> IO YesodResponse
handleError' ErrorResponse
e
                Right Content
c' -> YesodResponse -> IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain Status
status [Header]
headers ContentType
ct Content
c' SessionMap
finalSession
        HCError ErrorResponse
e -> ErrorResponse -> IO YesodResponse
handleError' ErrorResponse
e
        HCRedirect Status
status Text
loc -> do
            let disable_caching :: [Header] -> [Header]
disable_caching [Header]
x =
                      CI ContentType -> ContentType -> Header
Header CI ContentType
"Cache-Control" ContentType
"no-cache, must-revalidate"
                    Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: CI ContentType -> ContentType -> Header
Header CI ContentType
"Expires" ContentType
"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 ContentType -> ContentType -> Header
Header CI ContentType
"Location" (Text -> ContentType
encodeUtf8 Text
loc) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers
            YesodResponse -> IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain
                Status
status [Header]
hs ContentType
typePlain Content
emptyContent
                SessionMap
finalSession
        HCSendFile ContentType
ct String
fp Maybe FilePart
p -> YesodResponse -> IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain
            Status
H.status200
            [Header]
headers
            ContentType
ct
            (String -> Maybe FilePart -> Content
ContentFile String
fp Maybe FilePart
p)
            SessionMap
finalSession
        HCCreated Text
loc -> YesodResponse -> IO YesodResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> IO YesodResponse)
-> YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain
            Status
H.status201
            (CI ContentType -> ContentType -> Header
Header CI ContentType
"Location" (Text -> ContentType
encodeUtf8 Text
loc) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers)
            ContentType
typePlain
            Content
emptyContent
            SessionMap
finalSession
        HCWai Response
r -> YesodResponse -> IO YesodResponse
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 (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

-- | Evaluate the given value. If an exception is thrown, use it to
-- replace the provided contents and then return @mempty@ in place of the
-- evaluated value.
evalFallback :: (Monoid w, NFData w)
             => HandlerContents
             -> w
             -> IO (w, HandlerContents)
evalFallback :: HandlerContents -> w -> IO (w, HandlerContents)
evalFallback HandlerContents
contents w
val = IO (w, HandlerContents)
-> (SomeException -> IO (w, HandlerContents))
-> IO (w, HandlerContents)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
    ((w -> (w, HandlerContents)) -> IO w -> IO (w, HandlerContents)
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 (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)

-- | Function used internally by Yesod in the process of converting a
-- 'HandlerFor' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c
           => RunHandlerEnv site site
           -> HandlerFor site c
           -> YesodApp
runHandler :: RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler rhe :: RunHandlerEnv site site
rhe@RunHandlerEnv {site
Maybe (Route site)
Text
Loc -> Text -> LogLevel -> LogStr -> IO ()
RequestBodyLength -> FileUpload
Route site -> Route site
Route site -> [(Text, Text)] -> Text
ErrorResponse -> YesodApp
rheMaxExpires :: forall child site. RunHandlerEnv child site -> Text
rheLog :: forall child site.
RunHandlerEnv child site
-> Loc -> Text -> 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 -> [(Text, Text)] -> Text
rheMaxExpires :: Text
rheOnError :: ErrorResponse -> YesodApp
rheLog :: Loc -> Text -> LogLevel -> LogStr -> IO ()
rheUpload :: RequestBodyLength -> FileUpload
rheChild :: site
rheSite :: site
rheRouteToMaster :: Route site -> Route site
rheRoute :: Maybe (Route site)
rheRender :: Route site -> [(Text, Text)] -> Text
rheOnError :: forall child site.
RunHandlerEnv child site -> ErrorResponse -> YesodApp
..} 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
    -- Get the raw state and original contents
    (GHState
state, HandlerContents
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

    -- Evaluate the unfortunately-lazy session and headers,
    -- propagating exceptions into the contents
    (SessionMap
finalSession, HandlerContents
contents1) <- HandlerContents -> SessionMap -> IO (SessionMap, HandlerContents)
forall w.
(Monoid w, NFData w) =>
HandlerContents -> w -> IO (w, HandlerContents)
evalFallback HandlerContents
contents0 (GHState -> SessionMap
ghsSession GHState
state)
    ([Header]
headers, HandlerContents
contents2) <- HandlerContents -> [Header] -> IO ([Header], HandlerContents)
forall w.
(Monoid w, NFData w) =>
HandlerContents -> w -> IO (w, HandlerContents)
evalFallback HandlerContents
contents1 (Endo [Header] -> [Header] -> [Header]
forall a. Endo a -> a -> a
appEndo (GHState -> Endo [Header]
ghsHeaders GHState
state) [])
    HandlerContents
contents3 <- (HandlerContents -> IO HandlerContents
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate HandlerContents
contents2) IO HandlerContents
-> (SomeException -> IO HandlerContents) -> IO HandlerContents
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` ((ErrorResponse -> HandlerContents)
-> IO ErrorResponse -> IO HandlerContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorResponse -> HandlerContents
HCError (IO ErrorResponse -> IO HandlerContents)
-> (SomeException -> IO ErrorResponse)
-> SomeException
-> IO HandlerContents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO ErrorResponse
toErrorHandler)

    -- Convert the HandlerContents into the final YesodResponse
    (ErrorResponse -> IO YesodResponse)
-> SessionMap -> [Header] -> HandlerContents -> IO YesodResponse
handleContents
        (RunHandlerEnv site site
-> YesodRequest
-> InternalState
-> SessionMap
-> [Header]
-> ErrorResponse
-> IO YesodResponse
forall sub site.
RunHandlerEnv sub site
-> YesodRequest
-> InternalState
-> SessionMap
-> [Header]
-> ErrorResponse
-> IO YesodResponse
handleError RunHandlerEnv site site
rhe YesodRequest
yreq InternalState
resState SessionMap
finalSession [Header]
headers)
        SessionMap
finalSession
        [Header]
headers
        HandlerContents
contents3

safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
       -> ErrorResponse
       -> YesodApp
safeEh :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> YesodApp
safeEh Loc -> Text -> LogLevel -> LogStr -> IO ()
log' ErrorResponse
er YesodRequest
req = do
    IO () -> ResourceT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ Loc -> Text -> LogLevel -> LogStr -> IO ()
log' $(qLocation >>= liftLoc) Text
"yesod-core" LogLevel
LevelError
           (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ String
"Error handler errored out: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ErrorResponse -> String
forall a. Show a => a -> String
show ErrorResponse
er
    YesodResponse -> ResourceT IO YesodResponse
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]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain
        Status
H.status500
        []
        ContentType
typePlain
        (ContentType -> Content
forall a. ToContent a => a -> Content
toContent (ContentType
"Internal Server Error" :: S.ByteString))
        (YesodRequest -> SessionMap
reqSession YesodRequest
req)

-- | Run a 'HandlerFor' completely outside of Yesod.  This
-- function comes with many caveats and you shouldn't use it
-- unless you fully understand what it's doing and how it works.
--
-- As of now, there's only one reason to use this function at
-- all: in order to run unit tests of functions inside 'HandlerFor'
-- but that aren't easily testable with a full HTTP request.
-- Even so, it's better to use @wai-test@ or @yesod-test@ instead
-- of using this function.
--
-- This function will create a fake HTTP request (both @wai@'s
-- 'Request' and @yesod@'s 'Request') and feed it to the
-- @HandlerFor@.  The only useful information the @HandlerFor@ may
-- get from the request is the session map, which you must supply
-- as argument to @runFakeHandler@.  All other fields contain
-- fake information, which means that they can be accessed but
-- won't have any useful information.  The response of the
-- @HandlerFor@ is completely ignored, including changes to the
-- session, cookies or headers.  We only return you the
-- @HandlerFor@'s return value.
runFakeHandler :: (Yesod site, MonadIO m) =>
                  SessionMap
               -> (site -> Logger)
               -> site
               -> HandlerFor site a
               -> m (Either ErrorResponse a)
runFakeHandler :: 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 (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
  IORef (Either ErrorResponse a)
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
$ Text -> ErrorResponse
InternalError Text
"runFakeHandler: no result")
  Text
maxExpires <- IO Text
getCurrentMaxExpiresRFC1123
  let handler' :: HandlerFor site ()
handler' = IO () -> HandlerFor site ()
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 :: YesodApp
yapp = RunHandlerEnv site site -> HandlerFor site () -> YesodApp
forall c site.
ToTypedContent c =>
RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler
         RunHandlerEnv :: forall child site.
(Route site -> [(Text, Text)] -> Text)
-> Maybe (Route child)
-> (Route child -> Route site)
-> site
-> child
-> (RequestBodyLength -> FileUpload)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (ErrorResponse -> YesodApp)
-> Text
-> RunHandlerEnv child site
RunHandlerEnv
            { rheRender :: Route site -> [(Text, Text)] -> Text
rheRender = site -> Text -> Route site -> [(Text, Text)] -> Text
forall y. Yesod y => y -> Text -> Route y -> [(Text, Text)] -> Text
yesodRender site
site (Text -> Route site -> [(Text, Text)] -> Text)
-> Text -> Route site -> [(Text, Text)] -> Text
forall a b. (a -> b) -> a -> b
$ site -> Request -> Text
forall master. Yesod master => master -> Request -> Text
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 -> Text -> LogLevel -> LogStr -> IO ()
rheLog = site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource site
site (Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Logger -> Loc -> Text -> 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 :: Text
rheMaxExpires = Text
maxExpires
            }
        HandlerFor site ()
handler'
      errHandler :: ErrorResponse -> YesodRequest -> m YesodResponse
errHandler ErrorResponse
err YesodRequest
req = do
          IO () -> m ()
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 (m :: * -> *) a. Monad m => a -> m a
return (YesodResponse -> m YesodResponse)
-> YesodResponse -> m YesodResponse
forall a b. (a -> b) -> a -> b
$ Status
-> [Header]
-> ContentType
-> Content
-> SessionMap
-> YesodResponse
YRPlain
                     Status
H.status500
                     []
                     ContentType
typePlain
                     (ContentType -> Content
forall a. ToContent a => a -> Content
toContent (ContentType
"runFakeHandler: errHandler" :: S8.ByteString))
                     (YesodRequest -> SessionMap
reqSession YesodRequest
req)
      fakeWaiRequest :: Request
fakeWaiRequest = Request :: ContentType
-> HttpVersion
-> ContentType
-> ContentType
-> RequestHeaders
-> Bool
-> SockAddr
-> [Text]
-> Query
-> IO ContentType
-> Vault
-> RequestBodyLength
-> Maybe ContentType
-> Maybe ContentType
-> Maybe ContentType
-> Maybe ContentType
-> Request
Request
          { requestMethod :: ContentType
requestMethod  = ContentType
"POST"
          , httpVersion :: HttpVersion
httpVersion    = HttpVersion
H.http11
          , rawPathInfo :: ContentType
rawPathInfo    = ContentType
"/runFakeHandler/pathInfo"
          , rawQueryString :: ContentType
rawQueryString = ContentType
""
          , requestHeaderHost :: Maybe ContentType
requestHeaderHost = Maybe ContentType
forall a. Maybe a
Nothing
          , requestHeaders :: RequestHeaders
requestHeaders = []
          , isSecure :: Bool
isSecure       = Bool
False
          , remoteHost :: SockAddr
remoteHost     = String -> SockAddr
forall a. HasCallStack => String -> a
error String
"runFakeHandler-remoteHost"
          , pathInfo :: [Text]
pathInfo       = [Text
"runFakeHandler", Text
"pathInfo"]
          , queryString :: Query
queryString    = []
          , requestBody :: IO ContentType
requestBody    = ContentType -> IO ContentType
forall (m :: * -> *) a. Monad m => a -> m a
return ContentType
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 ContentType
requestHeaderRange = Maybe ContentType
forall a. Maybe a
Nothing
          , requestHeaderReferer :: Maybe ContentType
requestHeaderReferer = Maybe ContentType
forall a. Maybe a
Nothing
          , requestHeaderUserAgent :: Maybe ContentType
requestHeaderUserAgent = Maybe ContentType
forall a. Maybe a
Nothing
          }
      fakeRequest :: YesodRequest
fakeRequest =
        YesodRequest :: [(Text, Text)]
-> [(Text, Text)]
-> Request
-> [Text]
-> Maybe Text
-> SessionMap
-> [ContentType]
-> YesodRequest
YesodRequest
          { reqGetParams :: [(Text, Text)]
reqGetParams  = []
          , reqCookies :: [(Text, Text)]
reqCookies    = []
          , reqWaiRequest :: Request
reqWaiRequest = Request
fakeWaiRequest
          , reqLangs :: [Text]
reqLangs      = []
          , reqToken :: Maybe Text
reqToken      = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NaN" -- not a nonce =)
          , reqAccept :: [ContentType]
reqAccept     = []
          , reqSession :: SessionMap
reqSession    = SessionMap
fakeSessionMap
          }
  YesodResponse
_ <- ResourceT IO YesodResponse -> IO YesodResponse
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO YesodResponse -> IO YesodResponse)
-> ResourceT IO YesodResponse -> IO YesodResponse
forall a b. (a -> b) -> a -> b
$ YesodApp
yapp YesodRequest
fakeRequest
  IORef (Either ErrorResponse a) -> IO (Either ErrorResponse a)
forall a. IORef a -> IO a
I.readIORef IORef (Either ErrorResponse a)
ret

yesodRunner :: (ToTypedContent res, Yesod site)
            => HandlerFor site res
            -> YesodRunnerEnv site
            -> Maybe (Route site)
            -> Application
yesodRunner :: HandlerFor site res
-> YesodRunnerEnv site -> Maybe (Route site) -> Application
yesodRunner HandlerFor site res
handler' YesodRunnerEnv {site
Maybe SessionBackend
IO Int
IO Text
Logger
yreGetMaxExpires :: forall site. YesodRunnerEnv site -> IO Text
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
yreGetMaxExpires :: IO Text
yreGen :: IO Int
yreSessionBackend :: Maybe SessionBackend
yreSite :: site
yreLogger :: Logger
..} Maybe (Route site)
route Request
req Response -> IO ResponseReceived
sendResponse = do
  Maybe Word64
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 (Maybe Word64
mmaxLen, Request -> RequestBodyLength
requestBodyLength Request
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 (m :: * -> *) a. Monad m => a -> m a
return []
      (SessionMap
session, SessionMap -> IO [Header]
saveSession) <- IO (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
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 (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
      Text
maxExpires <- IO Text
yreGetMaxExpires
      let mkYesodReq :: Either (IO YesodRequest) (IO Int -> IO YesodRequest)
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 :: IO YesodRequest
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 :: Text
ra = site -> Request -> Text
forall master. Yesod master => master -> Request -> Text
resolveApproot site
yreSite Request
req
      let log' :: Loc -> Text -> LogLevel -> LogStr -> IO ()
log' = site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource site
yreSite Logger
yreLogger
          -- 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.
          rheSafe :: RunHandlerEnv site site
rheSafe = RunHandlerEnv :: forall child site.
(Route site -> [(Text, Text)] -> Text)
-> Maybe (Route child)
-> (Route child -> Route site)
-> site
-> child
-> (RequestBodyLength -> FileUpload)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (ErrorResponse -> YesodApp)
-> Text
-> RunHandlerEnv child site
RunHandlerEnv
              { rheRender :: Route site -> [(Text, Text)] -> Text
rheRender = site -> Text -> Route site -> [(Text, Text)] -> Text
forall y. Yesod y => y -> Text -> Route y -> [(Text, Text)] -> Text
yesodRender site
yreSite Text
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 -> Text -> LogLevel -> LogStr -> IO ()
rheLog = Loc -> Text -> LogLevel -> LogStr -> IO ()
log'
              , rheOnError :: ErrorResponse -> YesodApp
rheOnError = (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> YesodApp
safeEh Loc -> Text -> LogLevel -> LogStr -> IO ()
log'
              , rheMaxExpires :: Text
rheMaxExpires = Text
maxExpires
              }
          rhe :: RunHandlerEnv site site
rhe = RunHandlerEnv site site
rheSafe
              { rheOnError :: ErrorResponse -> YesodApp
rheOnError = RunHandlerEnv site site -> HandlerFor site TypedContent -> YesodApp
forall c site.
ToTypedContent c =>
RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler RunHandlerEnv site site
rheSafe (HandlerFor site TypedContent -> YesodApp)
-> (ErrorResponse -> HandlerFor site TypedContent)
-> ErrorResponse
-> YesodApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> HandlerFor site TypedContent
forall site.
Yesod site =>
ErrorResponse -> HandlerFor site TypedContent
errorHandler
              }

      site
-> Maybe (Route site)
-> (InternalState -> IO ResponseReceived)
-> IO ResponseReceived
forall site a.
Yesod site =>
site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a
yesodWithInternalState site
yreSite Maybe (Route site)
route ((InternalState -> IO ResponseReceived) -> IO ResponseReceived)
-> (InternalState -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \InternalState
is -> do
          YesodRequest
yreq' <- IO YesodRequest
yreq
          YesodResponse
yar <- ResourceT IO YesodResponse -> InternalState -> IO YesodResponse
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (RunHandlerEnv site site -> HandlerFor site res -> YesodApp
forall c site.
ToTypedContent c =>
RunHandlerEnv site site -> HandlerFor site c -> YesodApp
runHandler RunHandlerEnv site site
rhe HandlerFor site res
handler YesodRequest
yreq') InternalState
is
          YesodResponse
-> (SessionMap -> IO [Header])
-> YesodRequest
-> Request
-> InternalState
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
yarToResponse YesodResponse
yar SessionMap -> IO [Header]
saveSession YesodRequest
yreq' Request
req InternalState
is Response -> IO ResponseReceived
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 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)] -- ^ url query string
            -> Text
yesodRender :: y -> Text -> Route y -> [(Text, Text)] -> Text
yesodRender y
y Text
ar Route y
url [(Text, Text)]
params =
    OnDecodeError -> ContentType -> Text
decodeUtf8With OnDecodeError
lenientDecode (ContentType -> Text) -> ContentType -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ContentType
BL.toStrict (ByteString -> ContentType) -> ByteString -> ContentType
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe
        (y -> Text -> [Text] -> [(Text, Text)] -> Builder
forall site.
Yesod site =>
site -> Text -> [Text] -> [(Text, Text)] -> Builder
joinPath y
y Text
ar [Text]
ps
          ([(Text, Text)] -> Builder) -> [(Text, Text)] -> Builder
forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
params [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
params')
        (y -> Route y -> [(Text, Text)] -> Maybe Builder
forall site.
Yesod site =>
site -> Route site -> [(Text, Text)] -> Maybe Builder
urlParamRenderOverride y
y Route y
url [(Text, Text)]
params)
  where
    ([Text]
ps, [(Text, Text)]
params') = Route y -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
renderRoute Route y
url

resolveApproot :: Yesod master => master -> Request -> ResolvedApproot
resolveApproot :: master -> Request -> Text
resolveApproot master
master Request
req =
    case Approot master
forall site. Yesod site => Approot site
approot of
        Approot master
ApprootRelative -> Text
""
        ApprootStatic Text
t -> Text
t
        ApprootMaster master -> Text
f -> master -> Text
f master
master
        ApprootRequest master -> Request -> Text
f -> master -> Request -> Text
f master
master Request
req