module Yesod.Core.Internal.Run where
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid, mempty)
#endif
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString)
import Control.Exception (fromException, evaluate)
import qualified Control.Exception as E
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)
catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
catchSync thing after = thing `E.catch` \e ->
if isAsyncException e
then E.throwIO e
else after e
isAsyncException :: E.SomeException -> Bool
isAsyncException e =
case fromException e of
Just E.SomeAsyncException{} -> True
Nothing -> False
toErrorHandler :: E.SomeException -> IO ErrorResponse
toErrorHandler e0 = flip catchSync errFromShow $
case fromException e0 of
Just (HCError x) -> evaluate $!! x
_
| isAsyncException e0 -> E.throwIO e0
| otherwise -> errFromShow e0
errFromShow :: E.SomeException -> IO ErrorResponse
errFromShow x = evaluate $!! InternalError $! T.pack $! show x
basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
basicRunHandler rhe handler yreq resState = do
istate <- I.newIORef defState
contents' <- catchSync
(do
res <- unHandlerT handler (hd istate)
tc <- evaluate (toTypedContent res)
return (HCContent defaultStatus tc))
(\e ->
case fromException e of
Just e' -> return e'
Nothing -> fmap HCError $ toErrorHandler e)
state <- I.readIORef istate
return (state, contents')
where
defState = GHState
{ ghsSession = reqSession yreq
, ghsRBC = Nothing
, ghsIdent = 1
, ghsCache = mempty
, ghsCacheBy = mempty
, ghsHeaders = mempty
}
hd istate = HandlerData
{ handlerRequest = yreq
, handlerEnv = rhe
, handlerState = istate
, handlerToParent = const ()
, handlerResource = resState
}
handleError :: RunHandlerEnv site
-> YesodRequest
-> InternalState
-> Map.Map Text S8.ByteString
-> [Header]
-> ErrorResponse
-> IO YesodResponse
handleError rhe yreq resState finalSession headers e0 = do
e <- (evaluate $!! e0) `catchSync` errFromShow
flip runInternalState resState $ do
yar <- rheOnError rhe e yreq
{ reqSession = finalSession
}
case yar of
YRPlain status' hs ct c sess ->
let hs' = headers ++ hs
status
| status' == defaultStatus = getStatus e
| otherwise = status'
in return $ YRPlain status hs' ct c sess
YRWai _ -> return yar
YRWaiApp _ -> return yar
handleContents :: (ErrorResponse -> IO YesodResponse)
-> Map.Map Text S8.ByteString
-> [Header]
-> HandlerContents
-> IO YesodResponse
handleContents handleError' finalSession headers contents =
case contents of
HCContent status (TypedContent ct c) -> do
ec' <- evaluateContent c
case ec' of
Left e -> handleError' e
Right c' -> return $ YRPlain status headers ct c' finalSession
HCError e -> handleError' e
HCRedirect status loc -> do
let disable_caching x =
Header "Cache-Control" "no-cache, must-revalidate"
: Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
: x
hs = (if status /= H.movedPermanently301 then disable_caching else id)
$ Header "Location" (encodeUtf8 loc) : headers
return $ YRPlain
status hs typePlain emptyContent
finalSession
HCSendFile ct fp p -> return $ YRPlain
H.status200
headers
ct
(ContentFile fp p)
finalSession
HCCreated loc -> return $ YRPlain
H.status201
(Header "Location" (encodeUtf8 loc) : headers)
typePlain
emptyContent
finalSession
HCWai r -> return $ YRWai r
HCWaiApp a -> return $ YRWaiApp a
evalFallback :: (Monoid w, NFData w)
=> HandlerContents
-> w
-> IO (w, HandlerContents)
evalFallback contents val = catchSync
(fmap (, contents) (evaluate $!! val))
(fmap ((mempty, ) . HCError) . toErrorHandler)
runHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
(state, contents0) <- basicRunHandler rhe handler yreq resState
(finalSession, contents1) <- evalFallback contents0 (ghsSession state)
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
handleContents
(handleError rhe yreq resState finalSession headers)
finalSession
headers
contents2
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
return $ YRPlain
H.status500
[]
typePlain
(toContent ("Internal Server Error" :: S.ByteString))
(reqSession req)
runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerT site IO a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
maxExpires <- getCurrentMaxExpiresRFC1123
let handler' = liftIO . I.writeIORef ret . Right =<< handler
let yapp = runHandler
RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
, rheRoute = Nothing
, rheSite = site
, rheUpload = fileUpload site
, rheLog = messageLoggerSource site $ logger site
, rheOnError = errHandler
, rheMaxExpires = maxExpires
}
handler'
errHandler err req = do
liftIO $ I.writeIORef ret (Left err)
return $ YRPlain
H.status500
[]
typePlain
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
(reqSession req)
fakeWaiRequest = Request
{ requestMethod = "POST"
, httpVersion = H.http11
, rawPathInfo = "/runFakeHandler/pathInfo"
, rawQueryString = ""
, requestHeaderHost = Nothing
, requestHeaders = []
, isSecure = False
, remoteHost = error "runFakeHandler-remoteHost"
, pathInfo = ["runFakeHandler", "pathInfo"]
, queryString = []
, requestBody = return mempty
, vault = mempty
, requestBodyLength = KnownLength 0
, requestHeaderRange = Nothing
#if MIN_VERSION_wai(3,2,0)
, requestHeaderReferer = Nothing
, requestHeaderUserAgent = Nothing
#endif
}
fakeRequest =
YesodRequest
{ reqGetParams = []
, reqCookies = []
, reqWaiRequest = fakeWaiRequest
, reqLangs = []
, reqToken = Just "NaN"
, reqAccept = []
, reqSession = fakeSessionMap
}
_ <- runResourceT $ yapp fakeRequest
I.readIORef ret
yesodRunner :: (ToTypedContent res, Yesod site)
=> HandlerT site IO res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
| otherwise = do
let dontSaveSession _ = return []
(session, saveSession) <- liftIO $
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
maxExpires <- yreGetMaxExpires
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
let yreq =
case mkYesodReq of
Left yreq' -> yreq'
Right needGen -> needGen yreGen
let ra = resolveApproot yreSite req
let log' = messageLoggerSource yreSite yreLogger
rheSafe = RunHandlerEnv
{ rheRender = yesodRender yreSite ra
, rheRoute = route
, rheSite = yreSite
, rheUpload = fileUpload yreSite
, rheLog = log'
, rheOnError = safeEh log'
, rheMaxExpires = maxExpires
}
rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
}
yesodWithInternalState yreSite route $ \is -> do
yreq' <- yreq
yar <- runInternalState (runHandler rhe handler yreq') is
yarToResponse yar saveSession yreq' req is sendResponse
where
mmaxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler'
yesodRender :: Yesod y
=> y
-> ResolvedApproot
-> Route y
-> [(Text, Text)]
-> Text
yesodRender y ar url params =
decodeUtf8With lenientDecode $ toByteString $
fromMaybe
(joinPath y ar ps
$ params ++ params')
(urlRenderOverride y url)
where
(ps, params') = renderRoute url
resolveApproot :: Yesod master => master -> Request -> ResolvedApproot
resolveApproot master req =
case approot of
ApprootRelative -> ""
ApprootStatic t -> t
ApprootMaster f -> f master
ApprootRequest f -> f master req