312 lines
12 KiB
Haskell
312 lines
12 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Yesod.Core.Internal.Run where
|
|
|
|
import Yesod.Core.Internal.Response
|
|
import Yesod.Core.Class.Handler
|
|
import Blaze.ByteString.Builder (toByteString)
|
|
import Control.Applicative ((<$>))
|
|
import Control.Exception (fromException)
|
|
import Control.Exception.Lifted (catch, finally)
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Base (liftBase)
|
|
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
|
|
liftLoc)
|
|
import Control.Monad.Trans.Resource (runResourceT)
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
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)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Monoid (appEndo, mempty)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Text.Encoding (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 Prelude hiding (catch)
|
|
import System.Log.FastLogger (Logger)
|
|
import System.Log.FastLogger (LogStr, toLogStr)
|
|
import System.Random (newStdGen)
|
|
import Yesod.Core.Content
|
|
import Yesod.Core.Class.Yesod
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Internal.Request (parseWaiRequest,
|
|
tooLargeResponse)
|
|
import Yesod.Routes.Class (Route, renderRoute)
|
|
|
|
-- | Function used internally by Yesod in the process of converting a
|
|
-- 'GHandler' into an 'Application'. Should not be needed by users.
|
|
runHandler :: ToTypedContent c
|
|
=> RunHandlerEnv sub master
|
|
-> GHandler sub master c
|
|
-> YesodApp
|
|
runHandler rhe@RunHandlerEnv {..} handler yreq = do
|
|
let toErrorHandler e =
|
|
case fromException e of
|
|
Just (HCError x) -> x
|
|
_ -> InternalError $ T.pack $ show e
|
|
istate <- liftIO $ I.newIORef GHState
|
|
{ ghsSession = reqSession yreq
|
|
, ghsRBC = Nothing
|
|
, ghsIdent = 1
|
|
, ghsCache = mempty
|
|
, ghsHeaders = mempty
|
|
}
|
|
let hd = HandlerData
|
|
{ handlerRequest = yreq
|
|
, handlerEnv = rhe
|
|
, handlerState = istate
|
|
}
|
|
contents' <- catch (fmap Right $ unGHandler handler hd)
|
|
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
|
$ fromException e)
|
|
state <- liftIO $ I.readIORef istate
|
|
let finalSession = ghsSession state
|
|
let headers = ghsHeaders state
|
|
let contents = either id (HCContent H.status200 . toTypedContent) contents'
|
|
let handleError e = do
|
|
yar <- rheOnError e yreq
|
|
{ reqSession = finalSession
|
|
}
|
|
case yar of
|
|
YRPlain _ hs ct c sess ->
|
|
let hs' = appEndo headers hs
|
|
in return $ YRPlain (getStatus e) hs' ct c sess
|
|
YRWai _ -> return yar
|
|
let sendFile' ct fp p =
|
|
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
|
|
case contents of
|
|
HCContent status (TypedContent ct c) -> do
|
|
ec' <- liftIO $ evaluateContent c
|
|
case ec' of
|
|
Left e -> handleError e
|
|
Right c' -> return $ YRPlain status (appEndo 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) : appEndo headers []
|
|
return $ YRPlain
|
|
status hs typePlain emptyContent
|
|
finalSession
|
|
HCSendFile ct fp p -> catch
|
|
(sendFile' ct fp p)
|
|
(handleError . toErrorHandler)
|
|
HCCreated loc -> do
|
|
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
|
|
return $ YRPlain
|
|
H.status201
|
|
hs
|
|
typePlain
|
|
emptyContent
|
|
finalSession
|
|
HCWai r -> return $ YRWai r
|
|
|
|
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)
|
|
|
|
-- | Run a 'GHandler' 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 'GHandler'
|
|
-- 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
|
|
-- @GHandler@. The only useful information the @GHandler@ 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
|
|
-- @GHandler@ is completely ignored, including changes to the
|
|
-- session, cookies or headers. We only return you the
|
|
-- @GHandler@'s return value.
|
|
runFakeHandler :: (Yesod master, MonadIO m) =>
|
|
SessionMap
|
|
-> (master -> Logger)
|
|
-> master
|
|
-> GHandler master master a
|
|
-> m (Either ErrorResponse a)
|
|
runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
|
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
|
|
let handler' = do liftIO . I.writeIORef ret . Right =<< handler
|
|
return ()
|
|
let yapp = runHandler
|
|
RunHandlerEnv
|
|
{ rheRender = yesodRender master $ resolveApproot master fakeWaiRequest
|
|
, rheRoute = Nothing
|
|
, rheToMaster = id
|
|
, rheMaster = master
|
|
, rheSub = master
|
|
, rheUpload = fileUpload master
|
|
, rheLog = messageLoggerSource master $ logger master
|
|
, rheOnError = errHandler
|
|
}
|
|
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 = ""
|
|
, serverName = "runFakeHandler-serverName"
|
|
, serverPort = 80
|
|
, requestHeaders = []
|
|
, isSecure = False
|
|
, remoteHost = error "runFakeHandler-remoteHost"
|
|
, pathInfo = ["runFakeHandler", "pathInfo"]
|
|
, queryString = []
|
|
, requestBody = mempty
|
|
, vault = mempty
|
|
, requestBodyLength = KnownLength 0
|
|
}
|
|
fakeRequest =
|
|
YesodRequest
|
|
{ reqGetParams = []
|
|
, reqCookies = []
|
|
, reqWaiRequest = fakeWaiRequest
|
|
, reqLangs = []
|
|
, reqToken = Just "NaN" -- not a nonce =)
|
|
, reqAccept = []
|
|
, reqSession = fakeSessionMap
|
|
}
|
|
_ <- runResourceT $ yapp fakeRequest
|
|
I.readIORef ret
|
|
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
|
|
|
|
yesodRunner :: (ToTypedContent res, Yesod master)
|
|
=> GHandler sub master res
|
|
-> YesodRunnerEnv sub master
|
|
-> Maybe (Route sub)
|
|
-> Application
|
|
yesodRunner handler' YesodRunnerEnv {..} route req
|
|
| KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
|
|
| otherwise = do
|
|
let dontSaveSession _ = return []
|
|
(session, saveSession) <- liftIO $ do
|
|
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
|
|
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) maxLen
|
|
yreq <-
|
|
case mkYesodReq of
|
|
Left yreq -> return yreq
|
|
Right needGen -> liftIO $ needGen <$> newStdGen
|
|
let ra = resolveApproot yreMaster req
|
|
let log' = messageLoggerSource yreMaster 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
|
|
{ rheRender = yesodRender yreMaster ra
|
|
, rheRoute = route
|
|
, rheToMaster = yreToMaster
|
|
, rheMaster = yreMaster
|
|
, rheSub = yreSub
|
|
, rheUpload = fileUpload yreMaster
|
|
, rheLog = log'
|
|
, rheOnError = safeEh log'
|
|
}
|
|
rhe = rheSafe
|
|
{ rheOnError = runHandler rheSafe . errorHandler
|
|
}
|
|
yar <- runHandler rhe handler yreq
|
|
liftIO $ yarToResponse yar saveSession yreq
|
|
where
|
|
maxLen = maximumContentLength yreMaster $ fmap yreToMaster route
|
|
handler = yesodMiddleware handler'
|
|
|
|
yesodRender :: Yesod y
|
|
=> y
|
|
-> ResolvedApproot
|
|
-> Route y
|
|
-> [(Text, Text)] -- ^ url query string
|
|
-> 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
|
|
|
|
fixEnv :: (oldSub -> newSub)
|
|
-> (Route newSub -> Route oldSub)
|
|
-> YesodRunnerEnv oldSub master
|
|
-> YesodRunnerEnv newSub master
|
|
fixEnv toNewSub toOldRoute envOld =
|
|
envOld
|
|
{ yreSub = toNewSub $ yreSub envOld
|
|
, yreToMaster = yreToMaster envOld . toOldRoute
|
|
}
|
|
|
|
stripHandlerT :: (HandlerState m, MonadBaseControl IO m)
|
|
=> HandlerT sub m a
|
|
-> (HandlerMaster m -> sub)
|
|
-> (Route sub -> Route (HandlerMaster m))
|
|
-> Maybe (Route sub)
|
|
-> m a
|
|
stripHandlerT (HandlerT f) getSub toMaster newRoute = do
|
|
yreq <- askYesodRequest
|
|
env <- askHandlerEnv
|
|
ghs <- getGHState
|
|
ighs <- liftBase $ I.newIORef ghs
|
|
|
|
let sub = getSub $ rheMaster env
|
|
hd = HandlerData
|
|
{ handlerRequest = yreq
|
|
, handlerEnv = env
|
|
{ rheMaster = sub
|
|
, rheSub = sub
|
|
, rheToMaster = id
|
|
, rheRoute = newRoute
|
|
, rheRender = \url params -> rheRender env (toMaster url) params
|
|
}
|
|
, handlerState = ighs
|
|
}
|
|
f hd `finally` (liftBase (I.readIORef ighs) >>= putGHState)
|