.Class and .Run modules
This commit is contained in:
Michael Snoyman
parent
1bd193f642
commit
e4683ed001
567
yesod-core/Yesod/Core/Class.hs
Normal file
567
yesod-core/Yesod/Core/Class.hs
Normal file
@ -0,0 +1,567 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Core.Class where
|
||||
|
||||
import Control.Monad.Logger (logErrorS)
|
||||
import Yesod.Content
|
||||
import Yesod.Handler hiding (getExpires, lift)
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Control.Arrow ((***))
|
||||
import Control.Monad (forM)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
|
||||
LogSource)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Encoding.Error as TEE
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Word (Word64)
|
||||
import Language.Haskell.TH.Syntax (Loc (..))
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Network.Wai as W
|
||||
import Network.Wai.Middleware.Gzip (GzipSettings, def)
|
||||
import Network.Wai.Parse (lbsBackEnd,
|
||||
tempFileBackEnd)
|
||||
import System.IO (stdout)
|
||||
import System.Log.FastLogger (LogStr (..), Logger,
|
||||
loggerDate, loggerPutStr,
|
||||
mkLogger)
|
||||
import System.Log.FastLogger.Date (ZonedDate)
|
||||
import Text.Blaze (customAttribute, textTag,
|
||||
toValue, (!))
|
||||
import Text.Blaze (preEscapedToMarkup)
|
||||
import qualified Text.Blaze.Html5 as TBH
|
||||
import Text.Hamlet
|
||||
import Text.Julius
|
||||
import qualified Web.ClientSession as CS
|
||||
import Web.Cookie (parseCookies)
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Internal
|
||||
import Yesod.Internal.Session
|
||||
import Yesod.Widget
|
||||
|
||||
-- | Define settings for a Yesod applications. All methods have intelligent
|
||||
-- defaults, and therefore no implementation is required.
|
||||
class RenderRoute a => Yesod a where
|
||||
-- | An absolute URL to the root of the application. Do not include
|
||||
-- trailing slash.
|
||||
--
|
||||
-- Default value: 'ApprootRelative'. This is valid under the following
|
||||
-- conditions:
|
||||
--
|
||||
-- * Your application is served from the root of the domain.
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
--
|
||||
-- If this is not true, you should override with a different
|
||||
-- implementation.
|
||||
approot :: Approot a
|
||||
approot = ApprootRelative
|
||||
|
||||
-- | Output error response pages.
|
||||
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
|
||||
errorHandler = defaultErrorHandler
|
||||
|
||||
-- | Applies some form of layout to the contents of a page.
|
||||
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
mmsg <- getMessage
|
||||
hamletToRepHtml [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle p}
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$maybe msg <- mmsg
|
||||
<p .message>#{msg}
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
-- sending cookies.
|
||||
urlRenderOverride :: a -> Route a -> Maybe Builder
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- | Determine if a request is authorized or not.
|
||||
--
|
||||
-- Return 'Authorized' if the request is authorized,
|
||||
-- 'Unauthorized' a message if unauthorized.
|
||||
-- If authentication is required, return 'AuthenticationRequired'.
|
||||
isAuthorized :: Route a
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> GHandler s a AuthResult
|
||||
isAuthorized _ _ = return Authorized
|
||||
|
||||
-- | Determines whether the current request is a write request. By default,
|
||||
-- this assumes you are following RESTful principles, and determines this
|
||||
-- from request method. In particular, all except the following request
|
||||
-- methods are considered write: GET HEAD OPTIONS TRACE.
|
||||
--
|
||||
-- This function is used to determine if a request is authorized; see
|
||||
-- 'isAuthorized'.
|
||||
isWriteRequest :: Route a -> GHandler s a Bool
|
||||
isWriteRequest _ = do
|
||||
wai <- waiRequest
|
||||
return $ W.requestMethod wai `notElem`
|
||||
["GET", "HEAD", "OPTIONS", "TRACE"]
|
||||
|
||||
-- | The default route for authentication.
|
||||
--
|
||||
-- Used in particular by 'isAuthorized', but library users can do whatever
|
||||
-- they want with it.
|
||||
authRoute :: a -> Maybe (Route a)
|
||||
authRoute _ = Nothing
|
||||
|
||||
-- | A function used to clean up path segments. It returns 'Right' with a
|
||||
-- clean path or 'Left' with a new set of pieces the user should be
|
||||
-- redirected to. The default implementation enforces:
|
||||
--
|
||||
-- * No double slashes
|
||||
--
|
||||
-- * There is no trailing slash.
|
||||
--
|
||||
-- Note that versions of Yesod prior to 0.7 used a different set of rules
|
||||
-- involing trailing slashes.
|
||||
cleanPath :: a -> [Text] -> Either [Text] [Text]
|
||||
cleanPath _ s =
|
||||
if corrected == s
|
||||
then Right $ map dropDash s
|
||||
else Left corrected
|
||||
where
|
||||
corrected = filter (not . T.null) s
|
||||
dropDash t
|
||||
| T.all (== '-') t = T.drop 1 t
|
||||
| otherwise = t
|
||||
|
||||
-- | Builds an absolute URL by concatenating the application root with the
|
||||
-- pieces of a path and a query string, if any.
|
||||
-- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
|
||||
joinPath :: a
|
||||
-> T.Text -- ^ application root
|
||||
-> [T.Text] -- ^ path pieces
|
||||
-> [(T.Text, T.Text)] -- ^ query string
|
||||
-> Builder
|
||||
joinPath _ ar pieces' qs' =
|
||||
fromText ar `mappend` encodePath pieces qs
|
||||
where
|
||||
pieces = if null pieces' then [""] else map addDash pieces'
|
||||
qs = map (TE.encodeUtf8 *** go) qs'
|
||||
go "" = Nothing
|
||||
go x = Just $ TE.encodeUtf8 x
|
||||
addDash t
|
||||
| T.all (== '-') t = T.cons '-' t
|
||||
| otherwise = t
|
||||
|
||||
-- | This function is used to store some static content to be served as an
|
||||
-- external file. The most common case of this is stashing CSS and
|
||||
-- JavaScript content in an external file; the "Yesod.Widget" module uses
|
||||
-- this feature.
|
||||
--
|
||||
-- The return value is 'Nothing' if no storing was performed; this is the
|
||||
-- default implementation. A 'Just' 'Left' gives the absolute URL of the
|
||||
-- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
|
||||
-- necessary when you are serving the content outside the context of a
|
||||
-- Yesod application, such as via memcached.
|
||||
addStaticContent :: Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
|
||||
addStaticContent _ _ _ = return Nothing
|
||||
|
||||
{- Temporarily disabled until we have a better interface.
|
||||
-- | Whether or not to tie a session to a specific IP address. Defaults to
|
||||
-- 'False'.
|
||||
--
|
||||
-- Note: This setting has two known problems: it does not work correctly
|
||||
-- when behind a reverse proxy (including load balancers), and it may not
|
||||
-- function correctly if the user is behind a proxy.
|
||||
sessionIpAddress :: a -> Bool
|
||||
sessionIpAddress _ = False
|
||||
-}
|
||||
|
||||
-- | The path value to set for cookies. By default, uses \"\/\", meaning
|
||||
-- cookies will be sent to every page on the current domain.
|
||||
cookiePath :: a -> S8.ByteString
|
||||
cookiePath _ = "/"
|
||||
|
||||
-- | The domain value to set for cookies. By default, the
|
||||
-- domain is not set, meaning cookies will be sent only to
|
||||
-- the current domain.
|
||||
cookieDomain :: a -> Maybe S8.ByteString
|
||||
cookieDomain _ = Nothing
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
--
|
||||
-- Default: 2 megabytes.
|
||||
maximumContentLength :: a -> Maybe (Route a) -> Word64
|
||||
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
|
||||
|
||||
-- | Returns a @Logger@ to use for log messages.
|
||||
--
|
||||
-- Default: Sends to stdout and automatically flushes on each write.
|
||||
getLogger :: a -> IO Logger
|
||||
getLogger _ = mkLogger True stdout
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
--
|
||||
-- Note: This method is no longer used. Instead, you should override
|
||||
-- 'messageLoggerSource'.
|
||||
messageLogger :: a
|
||||
-> Logger
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO ()
|
||||
messageLogger a logger loc = messageLoggerSource a logger loc ""
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
messageLoggerSource :: a
|
||||
-> Logger
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO ()
|
||||
messageLoggerSource a logger loc source level msg =
|
||||
if shouldLog a source level
|
||||
then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
|
||||
else return ()
|
||||
|
||||
-- | The logging level in place for this application. Any messages below
|
||||
-- this level will simply be ignored.
|
||||
logLevel :: a -> LogLevel
|
||||
logLevel _ = LevelInfo
|
||||
|
||||
-- | GZIP settings.
|
||||
gzipSettings :: a -> GzipSettings
|
||||
gzipSettings _ = def
|
||||
|
||||
-- | Where to Load sripts from. We recommend the default value,
|
||||
-- 'BottomOfBody'. Alternatively use the built in async yepnope loader:
|
||||
--
|
||||
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
|
||||
--
|
||||
-- Or write your own async js loader: see 'loadJsYepnope'
|
||||
jsLoader :: a -> ScriptLoadPosition a
|
||||
jsLoader _ = BottomOfBody
|
||||
|
||||
-- | Create a session backend. Returning `Nothing' disables sessions.
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
|
||||
makeSessionBackend _ = fmap Just defaultClientSessionBackend
|
||||
|
||||
-- | How to store uploaded files.
|
||||
--
|
||||
-- Default: When the request body is greater than 50kb, store in a temp
|
||||
-- file. For chunked request bodies, store in a temp file. Otherwise, store
|
||||
-- in memory.
|
||||
fileUpload :: a -> W.RequestBodyLength -> FileUpload
|
||||
fileUpload _ (W.KnownLength size)
|
||||
| size <= 50000 = FileUploadMemory lbsBackEnd
|
||||
fileUpload _ _ = FileUploadDisk tempFileBackEnd
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Default: Logs everything at or above 'logLevel'
|
||||
shouldLog :: a -> LogSource -> LogLevel -> Bool
|
||||
shouldLog a _ level = level >= logLevel a
|
||||
|
||||
-- | A Yesod middleware, which will wrap every handler function. This
|
||||
-- allows you to run code before and after a normal handler.
|
||||
--
|
||||
-- Default: Adds the response header \"Vary: Accept, Accept-Language\".
|
||||
--
|
||||
-- Since: 1.1.6
|
||||
yesodMiddleware :: GHandler sub a res -> GHandler sub a res
|
||||
yesodMiddleware handler = do
|
||||
setHeader "Vary" "Accept, Accept-Language"
|
||||
handler
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
widgetToPageContent :: (Eq (Route master), Yesod master)
|
||||
=> GWidget sub master ()
|
||||
-> GHandler sub master (PageContent (Route master))
|
||||
widgetToPageContent w = do
|
||||
master <- getYesod
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
Just (Left s) -> Just s
|
||||
Just (Right (u, p)) -> Just $ render u p
|
||||
css <- forM (Map.toList style) $ \(mmedia, content) -> do
|
||||
let rendered = toLazyText $ content render
|
||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
||||
$ encodeUtf8 rendered
|
||||
return (mmedia,
|
||||
case x of
|
||||
Nothing -> Left $ preEscapedToMarkup rendered
|
||||
Just y -> Right $ either id (uncurry render) y)
|
||||
jsLoc <-
|
||||
case jscript of
|
||||
Nothing -> return Nothing
|
||||
Just s -> do
|
||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
||||
$ encodeUtf8 $ renderJavascriptUrl render s
|
||||
return $ renderLoc x
|
||||
|
||||
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
|
||||
-- the asynchronous loader means your page doesn't have to wait for all the js to load
|
||||
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
|
||||
regularScriptLoad = [hamlet|
|
||||
$newline never
|
||||
$forall s <- scripts
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
|]
|
||||
|
||||
headAll = [hamlet|
|
||||
$newline never
|
||||
\^{head'}
|
||||
$forall s <- stylesheets
|
||||
^{mkLinkTag s}
|
||||
$forall s <- css
|
||||
$maybe t <- right $ snd s
|
||||
$maybe media <- fst s
|
||||
<link rel=stylesheet media=#{media} href=#{t}>
|
||||
$nothing
|
||||
<link rel=stylesheet href=#{t}>
|
||||
$maybe content <- left $ snd s
|
||||
$maybe media <- fst s
|
||||
<style media=#{media}>#{content}
|
||||
$nothing
|
||||
<style>#{content}
|
||||
$case jsLoader master
|
||||
$of BottomOfBody
|
||||
$of BottomOfHeadAsync asyncJsLoader
|
||||
^{asyncJsLoader asyncScripts mcomplete}
|
||||
$of BottomOfHeadBlocking
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
let bodyScript = [hamlet|
|
||||
$newline never
|
||||
^{body}
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title headAll (case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body)
|
||||
where
|
||||
renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
|
||||
addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
|
||||
mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr TBH.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
|
||||
-- | Helper function for 'defaultErrorHandler'.
|
||||
applyLayout' :: Yesod master
|
||||
=> Html -- ^ title
|
||||
-> HtmlUrl (Route master) -- ^ body
|
||||
-> GHandler sub master ChooseRep
|
||||
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
|
||||
setTitle title
|
||||
toWidget body
|
||||
|
||||
-- | The default error handler for 'errorHandler'.
|
||||
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
|
||||
defaultErrorHandler NotFound = do
|
||||
r <- waiRequest
|
||||
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
|
||||
applyLayout' "Not Found"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Not Found
|
||||
<p>#{path'}
|
||||
|]
|
||||
defaultErrorHandler (PermissionDenied msg) =
|
||||
applyLayout' "Permission Denied"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Permission denied
|
||||
<p>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Invalid Arguments
|
||||
<ul>
|
||||
$forall msg <- ia
|
||||
<li>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InternalError e) = do
|
||||
$logErrorS "yesod-core" e
|
||||
applyLayout' "Internal Server Error"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Internal Server Error
|
||||
<pre>#{e}
|
||||
|]
|
||||
defaultErrorHandler (BadMethod m) =
|
||||
applyLayout' "Bad Method"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Method Not Supported
|
||||
<p>Method <code>#{S8.unpack m}</code> not supported
|
||||
|]
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
-> Maybe (JavascriptUrl (url))
|
||||
-> Maybe Text
|
||||
-> (Maybe (HtmlUrl url), [Text])
|
||||
asyncHelper render scripts jscript jsLoc =
|
||||
(mcomplete, scripts'')
|
||||
where
|
||||
scripts' = map goScript scripts
|
||||
scripts'' =
|
||||
case jsLoc of
|
||||
Just s -> scripts' ++ [s]
|
||||
Nothing -> scripts'
|
||||
goScript (Script (Local url) _) = render url []
|
||||
goScript (Script (Remote s) _) = s
|
||||
mcomplete =
|
||||
case jsLoc of
|
||||
Just{} -> Nothing
|
||||
Nothing ->
|
||||
case jscript of
|
||||
Nothing -> Nothing
|
||||
Just j -> Just $ jelper j
|
||||
|
||||
formatLogMessage :: IO ZonedDate
|
||||
-> Loc
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO [LogStr]
|
||||
formatLogMessage getdate loc src level msg = do
|
||||
now <- getdate
|
||||
return
|
||||
[ LB now
|
||||
, LB " ["
|
||||
, LS $
|
||||
case level of
|
||||
LevelOther t -> T.unpack t
|
||||
_ -> drop 5 $ show level
|
||||
, LS $
|
||||
if T.null src
|
||||
then ""
|
||||
else "#" ++ T.unpack src
|
||||
, LB "] "
|
||||
, msg
|
||||
, LB " @("
|
||||
, LS $ fileLocationToString loc
|
||||
, LB ")\n"
|
||||
]
|
||||
|
||||
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
|
||||
defaultClientSessionBackend = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
jsToHtml :: Javascript -> Html
|
||||
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
|
||||
|
||||
jelper :: JavascriptUrl url -> HtmlUrl url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
left :: Either a b -> Maybe a
|
||||
left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
|
||||
right :: Either a b -> Maybe b
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
|
||||
clientSessionBackend :: Yesod master
|
||||
=> CS.Key -- ^ The encryption key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> SessionBackend master
|
||||
clientSessionBackend key getCachedDate =
|
||||
SessionBackend {
|
||||
sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req
|
||||
}
|
||||
|
||||
loadClientSession :: Yesod master
|
||||
=> CS.Key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
-> master
|
||||
-> W.Request
|
||||
-> IO (SessionMap, SaveSession)
|
||||
loadClientSession key getCachedDate sessionName master req = load
|
||||
where
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
return (sess date, save date)
|
||||
sess date = fromMaybe Map.empty $ do
|
||||
raw <- lookup "Cookie" $ W.requestHeaders req
|
||||
val <- lookup sessionName $ parseCookies raw
|
||||
let host = "" -- fixme, properly lock sessions to client address
|
||||
decodeClientSession key date host val
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just (cookiePath master)
|
||||
, setCookieExpires = Just (csdcExpires date)
|
||||
, setCookieDomain = cookieDomain master
|
||||
, setCookieHttpOnly = True
|
||||
}]
|
||||
where
|
||||
host = "" -- fixme, properly lock sessions to client address
|
||||
|
||||
-- taken from file-location package
|
||||
-- turn the TH Loc loaction information into a human readable string
|
||||
-- leaving out the loc_end parameter
|
||||
fileLocationToString :: Loc -> String
|
||||
fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
|
||||
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
|
||||
where
|
||||
line = show . fst . loc_start
|
||||
char = show . snd . loc_start
|
||||
|
||||
{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}
|
||||
431
yesod-core/Yesod/Core/Run.hs
Normal file
431
yesod-core/Yesod/Core/Run.hs
Normal file
@ -0,0 +1,431 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Yesod.Core.Run where
|
||||
|
||||
import Blaze.ByteString.Builder (fromLazyByteString, toByteString,
|
||||
toLazyByteString)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException, fromException,
|
||||
handle)
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger (LogLevel, LogSource)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
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)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Network.Wai
|
||||
import Prelude hiding (catch)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Log.FastLogger (LogStr)
|
||||
import System.Log.FastLogger (Logger)
|
||||
import System.Random (newStdGen)
|
||||
import Web.Cookie (renderSetCookie)
|
||||
import Yesod.Content
|
||||
import Yesod.Core.Class
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Handler
|
||||
import Yesod.Internal (tokenKey)
|
||||
import Yesod.Internal.Request (parseWaiRequest,
|
||||
tooLargeResponse)
|
||||
import Yesod.Routes.Class (Route, renderRoute)
|
||||
|
||||
handlerToYAR :: (HasReps a, HasReps b)
|
||||
=> master -- ^ master site foundation
|
||||
-> sub -- ^ sub site foundation
|
||||
-> (RequestBodyLength -> FileUpload)
|
||||
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> (Route sub -> Route master)
|
||||
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
||||
-> (ErrorResponse -> GHandler sub master a)
|
||||
-> YesodRequest
|
||||
-> Maybe (Route sub)
|
||||
-> SessionMap
|
||||
-> GHandler sub master b
|
||||
-> ResourceT IO YesodResponse
|
||||
handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h =
|
||||
ya rr { reqOnError = eh', reqSession = sessionMap }
|
||||
where
|
||||
ya = runHandler h render murl toMasterRoute y s upload log'
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
|
||||
errorHandler' = localNoCurrent . errorHandler0
|
||||
|
||||
yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response
|
||||
yarToResponse (YRWai a) _ = a
|
||||
yarToResponse (YRPlain s hs _ c _) extraHeaders =
|
||||
go c
|
||||
where
|
||||
finalHeaders = extraHeaders ++ map headerToPair hs
|
||||
finalHeaders' len = ("Content-Length", S8.pack $ show len)
|
||||
: finalHeaders
|
||||
|
||||
go (ContentBuilder b mlen) =
|
||||
ResponseBuilder s hs' b
|
||||
where
|
||||
hs' = maybe finalHeaders finalHeaders' mlen
|
||||
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = ResponseSource s finalHeaders body
|
||||
go (ContentDontEvaluate c') = go c'
|
||||
|
||||
-- | Convert Header to a key/value pair.
|
||||
headerToPair :: Header
|
||||
-> (CI ByteString, ByteString)
|
||||
headerToPair (AddCookie sc) =
|
||||
("Set-Cookie", toByteString $ renderSetCookie $ sc)
|
||||
headerToPair (DeleteCookie key path) =
|
||||
( "Set-Cookie"
|
||||
, S.concat
|
||||
[ key
|
||||
, "=; path="
|
||||
, path
|
||||
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
|
||||
]
|
||||
)
|
||||
headerToPair (Header key value) = (CI.mk key, value)
|
||||
|
||||
localNoCurrent :: GHandler s m a -> GHandler s m a
|
||||
localNoCurrent =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
|
||||
local :: (HandlerData sub' master' -> HandlerData sub master)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master' a
|
||||
local f (GHandler x) = GHandler $ \r -> x $ f r
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'GHandler' into an 'Application'. Should not be needed by users.
|
||||
runHandler :: HasReps c
|
||||
=> GHandler sub master c
|
||||
-> (Route master -> [(Text, Text)] -> Text)
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> master
|
||||
-> sub
|
||||
-> (RequestBodyLength -> FileUpload)
|
||||
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> YesodApp
|
||||
runHandler handler mrender sroute tomr master sub upload log' req = do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just (HCError x) -> x
|
||||
_ -> InternalError $ T.pack $ show e
|
||||
istate <- liftIO $ I.newIORef GHState
|
||||
{ ghsSession = initSession
|
||||
, ghsRBC = Nothing
|
||||
, ghsIdent = 1
|
||||
, ghsCache = mempty
|
||||
, ghsHeaders = mempty
|
||||
}
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = req
|
||||
, handlerSub = sub
|
||||
, handlerMaster = master
|
||||
, handlerRoute = sroute
|
||||
, handlerRender = mrender
|
||||
, handlerToMaster = tomr
|
||||
, handlerState = istate
|
||||
, handlerUpload = upload
|
||||
, handlerLog = log'
|
||||
}
|
||||
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 . chooseRep) contents'
|
||||
let handleError e = do
|
||||
yar <- eh e req
|
||||
{ reqOnError = safeEh
|
||||
, 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 a -> do
|
||||
(ct, c) <- liftIO $ a cts
|
||||
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
|
||||
where
|
||||
eh = reqOnError req
|
||||
cts = reqAccept req
|
||||
initSession = reqSession req
|
||||
|
||||
safeEh :: ErrorResponse -> YesodApp
|
||||
safeEh er req = do
|
||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
||||
return $ YRPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
(reqSession req)
|
||||
|
||||
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
|
||||
let lbs = toLazyByteString b
|
||||
L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
|
||||
where
|
||||
f :: SomeException -> IO (Either ErrorResponse Content)
|
||||
f = return . Left . InternalError . T.pack . show
|
||||
evaluateContent c = return (Right c)
|
||||
|
||||
getStatus :: ErrorResponse -> H.Status
|
||||
getStatus NotFound = H.status404
|
||||
getStatus (InternalError _) = H.status500
|
||||
getStatus (InvalidArgs _) = H.status400
|
||||
getStatus (PermissionDenied _) = H.status403
|
||||
getStatus (BadMethod _) = H.status405
|
||||
|
||||
-- | 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
|
||||
handler'
|
||||
(yesodRender master $ resolveApproot master fakeWaiRequest)
|
||||
Nothing
|
||||
id
|
||||
master
|
||||
master
|
||||
(fileUpload master)
|
||||
(messageLoggerSource master $ logger master)
|
||||
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 =)
|
||||
, reqOnError = errHandler
|
||||
, 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." #-}
|
||||
|
||||
data YesodRunnerEnv sub master = YesodRunnerEnv
|
||||
{ yreLogger :: !Logger
|
||||
, yreMaster :: !master
|
||||
, yreSub :: !sub
|
||||
, yreRoute :: !(Maybe (Route sub))
|
||||
, yreToMaster :: !(Route sub -> Route master)
|
||||
, yreSessionBackend :: !(Maybe (SessionBackend master))
|
||||
}
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> YesodRunnerEnv sub master
|
||||
-> GHandler sub master ChooseRep
|
||||
-> Application
|
||||
defaultYesodRunner YesodRunnerEnv {..} handler' req
|
||||
| KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError"
|
||||
(session, saveSession) <- liftIO $ do
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend
|
||||
rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen
|
||||
let h = {-# SCC "h" #-} do
|
||||
case yreRoute of
|
||||
Nothing -> handler
|
||||
Just url -> do
|
||||
isWrite <- isWriteRequest $ yreToMaster url
|
||||
ar <- isAuthorized (yreToMaster url) isWrite
|
||||
case ar of
|
||||
Authorized -> return ()
|
||||
AuthenticationRequired ->
|
||||
case authRoute yreMaster of
|
||||
Nothing ->
|
||||
permissionDenied "Authentication required"
|
||||
Just url' -> do
|
||||
setUltDestCurrent
|
||||
redirect url'
|
||||
Unauthorized s' -> permissionDenied s'
|
||||
handler
|
||||
let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session
|
||||
let ra = resolveApproot yreMaster req
|
||||
let log' = messageLoggerSource yreMaster yreLogger
|
||||
yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster
|
||||
(yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h
|
||||
extraHeaders <- case yar of
|
||||
(YRPlain _ _ ct _ newSess) -> do
|
||||
let nsToken = maybe
|
||||
newSess
|
||||
(\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
|
||||
(reqToken rr)
|
||||
sessionHeaders <- liftIO (saveSession nsToken)
|
||||
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
|
||||
_ -> return []
|
||||
return $ yarToResponse yar extraHeaders
|
||||
where
|
||||
maxLen = maximumContentLength yreMaster $ fmap yreToMaster yreRoute
|
||||
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
|
||||
|
||||
toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
|
||||
|
||||
-- | FIXME do we need this?
|
||||
toMasterHandlerDyn :: (Route sub -> Route master)
|
||||
-> GHandler sub' master sub
|
||||
-> Route sub
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerDyn tm getSub route h = do
|
||||
sub <- getSub
|
||||
local (handlerSubData tm (const sub) route) h
|
||||
|
||||
-- | Used internally for promoting subsite handler functions to master site
|
||||
-- handler functions. Should not be needed by users.
|
||||
toMasterHandler :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandler tm ts route = local (handlerSubData tm ts route)
|
||||
|
||||
handlerSubData :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
|
||||
|
||||
handlerSubDataMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubDataMaybe tm ts route hd = hd
|
||||
{ handlerSub = ts $ handlerMaster hd
|
||||
, handlerToMaster = tm
|
||||
, handlerRoute = route
|
||||
}
|
||||
|
||||
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
|
||||
@ -105,18 +105,10 @@ module Yesod.Handler
|
||||
, cacheInsert
|
||||
, cacheDelete
|
||||
-- * Internal Yesod
|
||||
, runHandler
|
||||
, YesodApp
|
||||
, runSubsiteGetter
|
||||
, toMasterHandler
|
||||
, toMasterHandlerDyn
|
||||
, toMasterHandlerMaybe
|
||||
, localNoCurrent
|
||||
, HandlerData
|
||||
, ErrorResponse (..)
|
||||
, handlerToYAR
|
||||
, yarToResponse
|
||||
, headerToPair
|
||||
) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
@ -131,7 +123,6 @@ import Control.Monad (liftM)
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import System.IO
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types as H
|
||||
|
||||
@ -144,59 +135,31 @@ import qualified Data.Text.Lazy as TL
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
import Yesod.Content
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Web.Cookie (SetCookie (..), renderSetCookie)
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Control.Arrow ((***))
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import Data.Monoid (mappend, mempty, Endo (..))
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)
|
||||
import Data.Text (Text)
|
||||
import Text.Shakespeare.I18N (RenderMessage (..))
|
||||
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
#define preEscapedText preEscapedToMarkup
|
||||
|
||||
import System.Log.FastLogger
|
||||
import Control.Monad.Logger
|
||||
|
||||
import qualified Yesod.Internal.Cache as Cache
|
||||
import Yesod.Internal.Cache (mkCacheKey)
|
||||
import qualified Data.IORef as I
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.Trans.Resource
|
||||
import Yesod.Routes.Class
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
|
||||
import Yesod.Routes.Class (Route)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Trans.Class
|
||||
|
||||
class YesodSubRoute s y where
|
||||
fromSubRoute :: s -> y -> Route s -> Route y
|
||||
|
||||
handlerSubData :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
|
||||
|
||||
handlerSubDataMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubDataMaybe tm ts route hd = hd
|
||||
{ handlerSub = ts $ handlerMaster hd
|
||||
, handlerToMaster = tm
|
||||
, handlerRoute = route
|
||||
}
|
||||
|
||||
get :: GHandler sub master GHState
|
||||
get = do
|
||||
hd <- ask
|
||||
@ -215,25 +178,6 @@ modify f = do
|
||||
tell :: Endo [Header] -> GHandler sub master ()
|
||||
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
|
||||
|
||||
-- | Used internally for promoting subsite handler functions to master site
|
||||
-- handler functions. Should not be needed by users.
|
||||
toMasterHandler :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandler tm ts route = local (handlerSubData tm ts route)
|
||||
|
||||
-- | FIXME do we need this?
|
||||
toMasterHandlerDyn :: (Route sub -> Route master)
|
||||
-> GHandler sub' master sub
|
||||
-> Route sub
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerDyn tm getSub route h = do
|
||||
sub <- getSub
|
||||
local (handlerSubData tm (const sub) route) h
|
||||
|
||||
class SubsiteGetter g m s | g -> s where
|
||||
runSubsiteGetter :: g -> m s
|
||||
|
||||
@ -246,13 +190,6 @@ instance (anySub ~ anySub'
|
||||
) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
|
||||
runSubsiteGetter = id
|
||||
|
||||
toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
|
||||
|
||||
getRequest :: GHandler s m YesodRequest
|
||||
getRequest = handlerRequest `liftM` ask
|
||||
|
||||
@ -401,114 +338,6 @@ handlerToIO =
|
||||
, handlerState = newStateIORef }
|
||||
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
|
||||
runHandler :: HasReps c
|
||||
=> GHandler sub master c
|
||||
-> (Route master -> [(Text, Text)] -> Text)
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> master
|
||||
-> sub
|
||||
-> (W.RequestBodyLength -> FileUpload)
|
||||
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> YesodApp
|
||||
runHandler handler mrender sroute tomr master sub upload log' req = do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just (HCError x) -> x
|
||||
_ -> InternalError $ T.pack $ show e
|
||||
istate <- liftIO $ I.newIORef GHState
|
||||
{ ghsSession = initSession
|
||||
, ghsRBC = Nothing
|
||||
, ghsIdent = 1
|
||||
, ghsCache = mempty
|
||||
, ghsHeaders = mempty
|
||||
}
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = req
|
||||
, handlerSub = sub
|
||||
, handlerMaster = master
|
||||
, handlerRoute = sroute
|
||||
, handlerRender = mrender
|
||||
, handlerToMaster = tomr
|
||||
, handlerState = istate
|
||||
, handlerUpload = upload
|
||||
, handlerLog = log'
|
||||
}
|
||||
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 . chooseRep) contents'
|
||||
let handleError e = do
|
||||
yar <- eh e req
|
||||
{ reqOnError = safeEh
|
||||
, 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 a -> do
|
||||
(ct, c) <- liftIO $ a cts
|
||||
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
|
||||
where
|
||||
eh = reqOnError req
|
||||
cts = reqAccept req
|
||||
initSession = reqSession req
|
||||
|
||||
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
|
||||
let lbs = toLazyByteString b
|
||||
L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
|
||||
where
|
||||
f :: SomeException -> IO (Either ErrorResponse Content)
|
||||
f = return . Left . InternalError . T.pack . show
|
||||
evaluateContent c = return (Right c)
|
||||
|
||||
safeEh :: ErrorResponse -> YesodApp
|
||||
safeEh er req = do
|
||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
||||
return $ YRPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
(reqSession req)
|
||||
|
||||
-- | Redirect to the given route.
|
||||
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
|
||||
-- This is the appropriate choice for a get-following-post
|
||||
@ -782,13 +611,6 @@ modSession f x = x { ghsSession = f $ ghsSession x }
|
||||
addHeader :: Header -> GHandler sub master ()
|
||||
addHeader = tell . Endo . (:)
|
||||
|
||||
getStatus :: ErrorResponse -> H.Status
|
||||
getStatus NotFound = H.status404
|
||||
getStatus (InternalError _) = H.status500
|
||||
getStatus (InvalidArgs _) = H.status400
|
||||
getStatus (PermissionDenied _) = H.status403
|
||||
getStatus (BadMethod _) = H.status405
|
||||
|
||||
-- | Some value which can be turned into a URL for redirects.
|
||||
class RedirectUrl master a where
|
||||
-- | Converts the value to the URL and a list of query-string parameters.
|
||||
@ -813,10 +635,6 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va
|
||||
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
|
||||
toTextUrl (url, params) = toTextUrl (url, Map.toList params)
|
||||
|
||||
localNoCurrent :: GHandler s m a -> GHandler s m a
|
||||
localNoCurrent =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
|
||||
-- | Lookup for session data.
|
||||
lookupSession :: Text -> GHandler s m (Maybe Text)
|
||||
lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
|
||||
@ -831,59 +649,6 @@ lookupSessionBS n = do
|
||||
getSession :: GHandler sub master SessionMap
|
||||
getSession = liftM ghsSession get
|
||||
|
||||
handlerToYAR :: (HasReps a, HasReps b)
|
||||
=> master -- ^ master site foundation
|
||||
-> sub -- ^ sub site foundation
|
||||
-> (W.RequestBodyLength -> FileUpload)
|
||||
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> (Route sub -> Route master)
|
||||
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
||||
-> (ErrorResponse -> GHandler sub master a)
|
||||
-> YesodRequest
|
||||
-> Maybe (Route sub)
|
||||
-> SessionMap
|
||||
-> GHandler sub master b
|
||||
-> ResourceT IO YesodResponse
|
||||
handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
ya rr { reqOnError = eh', reqSession = sessionMap }
|
||||
where
|
||||
ya = runHandler h render murl toMasterRoute y s upload log'
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
|
||||
errorHandler' = localNoCurrent . errorHandler
|
||||
|
||||
yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> W.Response
|
||||
yarToResponse (YRWai a) _ = a
|
||||
yarToResponse (YRPlain s hs _ c _) extraHeaders =
|
||||
go c
|
||||
where
|
||||
finalHeaders = extraHeaders ++ map headerToPair hs
|
||||
finalHeaders' len = ("Content-Length", S8.pack $ show len)
|
||||
: finalHeaders
|
||||
|
||||
go (ContentBuilder b mlen) =
|
||||
W.ResponseBuilder s hs' b
|
||||
where
|
||||
hs' = maybe finalHeaders finalHeaders' mlen
|
||||
go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = W.ResponseSource s finalHeaders body
|
||||
go (ContentDontEvaluate c') = go c'
|
||||
|
||||
-- | Convert Header to a key/value pair.
|
||||
headerToPair :: Header
|
||||
-> (CI ByteString, ByteString)
|
||||
headerToPair (AddCookie sc) =
|
||||
("Set-Cookie", toByteString $ renderSetCookie $ sc)
|
||||
headerToPair (DeleteCookie key path) =
|
||||
( "Set-Cookie"
|
||||
, S.concat
|
||||
[ key
|
||||
, "=; path="
|
||||
, path
|
||||
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
|
||||
]
|
||||
)
|
||||
headerToPair (Header key value) = (CI.mk key, value)
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newIdent :: GHandler sub master Text
|
||||
newIdent = do
|
||||
@ -951,8 +716,3 @@ cacheDelete k = modify $ \gs ->
|
||||
|
||||
ask :: GHandler sub master (HandlerData sub master)
|
||||
ask = GHandler return
|
||||
|
||||
local :: (HandlerData sub' master' -> HandlerData sub master)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master' a
|
||||
local f (GHandler x) = GHandler $ \r -> x $ f r
|
||||
|
||||
@ -43,427 +43,28 @@ module Yesod.Internal.Core
|
||||
|
||||
import Yesod.Content
|
||||
import Yesod.Handler hiding (lift, getExpires)
|
||||
import Control.Monad.Logger (logErrorS)
|
||||
import Control.Applicative ((<$>))
|
||||
import System.Random (newStdGen)
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
import Data.Word (Word64)
|
||||
import Control.Arrow ((***))
|
||||
import Control.Monad (forM)
|
||||
import Yesod.Widget
|
||||
import Yesod.Request
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Internal
|
||||
import Yesod.Internal.Session
|
||||
import Yesod.Internal.Request
|
||||
import qualified Web.ClientSession as CS
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.IORef as I
|
||||
import Data.Monoid
|
||||
import Text.Hamlet
|
||||
import Text.Julius
|
||||
import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
|
||||
import qualified Text.Blaze.Html5 as TBH
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Web.Cookie (parseCookies)
|
||||
import qualified Data.Map as Map
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Data.Text as T
|
||||
import Text.Blaze (unsafeLazyByteString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Encoding.Error as TEE
|
||||
import Blaze.ByteString.Builder (Builder, toByteString)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Data.List (foldl')
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Language.Haskell.TH.Syntax (Loc (..))
|
||||
import Text.Blaze (preEscapedToMarkup)
|
||||
import Data.Aeson (Value (Array, String))
|
||||
import Data.Aeson.Encode (encode)
|
||||
import qualified Data.Vector as Vector
|
||||
import Network.Wai.Middleware.Gzip (GzipSettings, def)
|
||||
import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)
|
||||
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
|
||||
import System.Log.FastLogger.Date (ZonedDate)
|
||||
import System.IO (stdout)
|
||||
import System.Log.FastLogger (Logger)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Class
|
||||
import Yesod.Core.Run
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class YesodDispatch sub master where
|
||||
yesodDispatch
|
||||
:: Yesod master
|
||||
=> Logger
|
||||
-> master
|
||||
-> sub
|
||||
-> (Route sub -> Route master)
|
||||
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
||||
-> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
|
||||
-> Text -- ^ request method
|
||||
-> [Text] -- ^ pieces
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
|
||||
yesodRunner :: Yesod master
|
||||
=> Logger
|
||||
-> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
yesodRunner = defaultYesodRunner
|
||||
|
||||
-- | Define settings for a Yesod applications. All methods have intelligent
|
||||
-- defaults, and therefore no implementation is required.
|
||||
class RenderRoute a => Yesod a where
|
||||
-- | An absolute URL to the root of the application. Do not include
|
||||
-- trailing slash.
|
||||
--
|
||||
-- Default value: 'ApprootRelative'. This is valid under the following
|
||||
-- conditions:
|
||||
--
|
||||
-- * Your application is served from the root of the domain.
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
--
|
||||
-- If this is not true, you should override with a different
|
||||
-- implementation.
|
||||
approot :: Approot a
|
||||
approot = ApprootRelative
|
||||
|
||||
-- | Output error response pages.
|
||||
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
|
||||
errorHandler = defaultErrorHandler
|
||||
|
||||
-- | Applies some form of layout to the contents of a page.
|
||||
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
mmsg <- getMessage
|
||||
hamletToRepHtml [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle p}
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$maybe msg <- mmsg
|
||||
<p .message>#{msg}
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
-- sending cookies.
|
||||
urlRenderOverride :: a -> Route a -> Maybe Builder
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- | Determine if a request is authorized or not.
|
||||
--
|
||||
-- Return 'Authorized' if the request is authorized,
|
||||
-- 'Unauthorized' a message if unauthorized.
|
||||
-- If authentication is required, return 'AuthenticationRequired'.
|
||||
isAuthorized :: Route a
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> GHandler s a AuthResult
|
||||
isAuthorized _ _ = return Authorized
|
||||
|
||||
-- | Determines whether the current request is a write request. By default,
|
||||
-- this assumes you are following RESTful principles, and determines this
|
||||
-- from request method. In particular, all except the following request
|
||||
-- methods are considered write: GET HEAD OPTIONS TRACE.
|
||||
--
|
||||
-- This function is used to determine if a request is authorized; see
|
||||
-- 'isAuthorized'.
|
||||
isWriteRequest :: Route a -> GHandler s a Bool
|
||||
isWriteRequest _ = do
|
||||
wai <- waiRequest
|
||||
return $ W.requestMethod wai `notElem`
|
||||
["GET", "HEAD", "OPTIONS", "TRACE"]
|
||||
|
||||
-- | The default route for authentication.
|
||||
--
|
||||
-- Used in particular by 'isAuthorized', but library users can do whatever
|
||||
-- they want with it.
|
||||
authRoute :: a -> Maybe (Route a)
|
||||
authRoute _ = Nothing
|
||||
|
||||
-- | A function used to clean up path segments. It returns 'Right' with a
|
||||
-- clean path or 'Left' with a new set of pieces the user should be
|
||||
-- redirected to. The default implementation enforces:
|
||||
--
|
||||
-- * No double slashes
|
||||
--
|
||||
-- * There is no trailing slash.
|
||||
--
|
||||
-- Note that versions of Yesod prior to 0.7 used a different set of rules
|
||||
-- involing trailing slashes.
|
||||
cleanPath :: a -> [Text] -> Either [Text] [Text]
|
||||
cleanPath _ s =
|
||||
if corrected == s
|
||||
then Right $ map dropDash s
|
||||
else Left corrected
|
||||
where
|
||||
corrected = filter (not . T.null) s
|
||||
dropDash t
|
||||
| T.all (== '-') t = T.drop 1 t
|
||||
| otherwise = t
|
||||
|
||||
-- | Builds an absolute URL by concatenating the application root with the
|
||||
-- pieces of a path and a query string, if any.
|
||||
-- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
|
||||
joinPath :: a
|
||||
-> T.Text -- ^ application root
|
||||
-> [T.Text] -- ^ path pieces
|
||||
-> [(T.Text, T.Text)] -- ^ query string
|
||||
-> Builder
|
||||
joinPath _ ar pieces' qs' =
|
||||
fromText ar `mappend` encodePath pieces qs
|
||||
where
|
||||
pieces = if null pieces' then [""] else map addDash pieces'
|
||||
qs = map (TE.encodeUtf8 *** go) qs'
|
||||
go "" = Nothing
|
||||
go x = Just $ TE.encodeUtf8 x
|
||||
addDash t
|
||||
| T.all (== '-') t = T.cons '-' t
|
||||
| otherwise = t
|
||||
|
||||
-- | This function is used to store some static content to be served as an
|
||||
-- external file. The most common case of this is stashing CSS and
|
||||
-- JavaScript content in an external file; the "Yesod.Widget" module uses
|
||||
-- this feature.
|
||||
--
|
||||
-- The return value is 'Nothing' if no storing was performed; this is the
|
||||
-- default implementation. A 'Just' 'Left' gives the absolute URL of the
|
||||
-- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
|
||||
-- necessary when you are serving the content outside the context of a
|
||||
-- Yesod application, such as via memcached.
|
||||
addStaticContent :: Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
|
||||
addStaticContent _ _ _ = return Nothing
|
||||
|
||||
{- Temporarily disabled until we have a better interface.
|
||||
-- | Whether or not to tie a session to a specific IP address. Defaults to
|
||||
-- 'False'.
|
||||
--
|
||||
-- Note: This setting has two known problems: it does not work correctly
|
||||
-- when behind a reverse proxy (including load balancers), and it may not
|
||||
-- function correctly if the user is behind a proxy.
|
||||
sessionIpAddress :: a -> Bool
|
||||
sessionIpAddress _ = False
|
||||
-}
|
||||
|
||||
-- | The path value to set for cookies. By default, uses \"\/\", meaning
|
||||
-- cookies will be sent to every page on the current domain.
|
||||
cookiePath :: a -> S8.ByteString
|
||||
cookiePath _ = "/"
|
||||
|
||||
-- | The domain value to set for cookies. By default, the
|
||||
-- domain is not set, meaning cookies will be sent only to
|
||||
-- the current domain.
|
||||
cookieDomain :: a -> Maybe S8.ByteString
|
||||
cookieDomain _ = Nothing
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
--
|
||||
-- Default: 2 megabytes.
|
||||
maximumContentLength :: a -> Maybe (Route a) -> Word64
|
||||
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
|
||||
|
||||
-- | Returns a @Logger@ to use for log messages.
|
||||
--
|
||||
-- Default: Sends to stdout and automatically flushes on each write.
|
||||
getLogger :: a -> IO Logger
|
||||
getLogger _ = mkLogger True stdout
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
--
|
||||
-- Note: This method is no longer used. Instead, you should override
|
||||
-- 'messageLoggerSource'.
|
||||
messageLogger :: a
|
||||
-> Logger
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO ()
|
||||
messageLogger a logger loc = messageLoggerSource a logger loc ""
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
messageLoggerSource :: a
|
||||
-> Logger
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO ()
|
||||
messageLoggerSource a logger loc source level msg =
|
||||
if shouldLog a source level
|
||||
then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
|
||||
else return ()
|
||||
|
||||
-- | The logging level in place for this application. Any messages below
|
||||
-- this level will simply be ignored.
|
||||
logLevel :: a -> LogLevel
|
||||
logLevel _ = LevelInfo
|
||||
|
||||
-- | GZIP settings.
|
||||
gzipSettings :: a -> GzipSettings
|
||||
gzipSettings _ = def
|
||||
|
||||
-- | Where to Load sripts from. We recommend the default value,
|
||||
-- 'BottomOfBody'. Alternatively use the built in async yepnope loader:
|
||||
--
|
||||
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
|
||||
--
|
||||
-- Or write your own async js loader: see 'loadJsYepnope'
|
||||
jsLoader :: a -> ScriptLoadPosition a
|
||||
jsLoader _ = BottomOfBody
|
||||
|
||||
-- | Create a session backend. Returning `Nothing' disables sessions.
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
|
||||
makeSessionBackend _ = fmap Just defaultClientSessionBackend
|
||||
|
||||
-- | How to store uploaded files.
|
||||
--
|
||||
-- Default: When the request body is greater than 50kb, store in a temp
|
||||
-- file. For chunked request bodies, store in a temp file. Otherwise, store
|
||||
-- in memory.
|
||||
fileUpload :: a -> W.RequestBodyLength -> FileUpload
|
||||
fileUpload _ (W.KnownLength size)
|
||||
| size <= 50000 = FileUploadMemory lbsBackEnd
|
||||
fileUpload _ _ = FileUploadDisk tempFileBackEnd
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Default: Logs everything at or above 'logLevel'
|
||||
shouldLog :: a -> LogSource -> LogLevel -> Bool
|
||||
shouldLog a _ level = level >= logLevel a
|
||||
|
||||
-- | A Yesod middleware, which will wrap every handler function. This
|
||||
-- allows you to run code before and after a normal handler.
|
||||
--
|
||||
-- Default: Adds the response header \"Vary: Accept, Accept-Language\".
|
||||
--
|
||||
-- Since: 1.1.6
|
||||
yesodMiddleware :: GHandler sub a res -> GHandler sub a res
|
||||
yesodMiddleware handler = do
|
||||
setHeader "Vary" "Accept, Accept-Language"
|
||||
handler
|
||||
|
||||
{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}
|
||||
|
||||
formatLogMessage :: IO ZonedDate
|
||||
-> Loc
|
||||
-> LogSource
|
||||
-> LogLevel
|
||||
-> LogStr -- ^ message
|
||||
-> IO [LogStr]
|
||||
formatLogMessage getdate loc src level msg = do
|
||||
now <- getdate
|
||||
return
|
||||
[ LB now
|
||||
, LB " ["
|
||||
, LS $
|
||||
case level of
|
||||
LevelOther t -> T.unpack t
|
||||
_ -> drop 5 $ show level
|
||||
, LS $
|
||||
if T.null src
|
||||
then ""
|
||||
else "#" ++ T.unpack src
|
||||
, LB "] "
|
||||
, msg
|
||||
, LB " @("
|
||||
, LS $ fileLocationToString loc
|
||||
, LB ")\n"
|
||||
]
|
||||
|
||||
-- taken from file-location package
|
||||
-- turn the TH Loc loaction information into a human readable string
|
||||
-- leaving out the loc_end parameter
|
||||
fileLocationToString :: Loc -> String
|
||||
fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
|
||||
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
|
||||
where
|
||||
line = show . fst . loc_start
|
||||
char = show . snd . loc_start
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> Logger
|
||||
-> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
| W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError"
|
||||
(session, saveSession) <- liftIO $ do
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
|
||||
rr <- liftIO $ parseWaiRequest req session onError (isJust msb) maxLen <$> newStdGen
|
||||
let h = {-# SCC "h" #-} do
|
||||
case murl of
|
||||
Nothing -> handler
|
||||
Just url -> do
|
||||
isWrite <- isWriteRequest $ toMasterRoute url
|
||||
ar <- isAuthorized (toMasterRoute url) isWrite
|
||||
case ar of
|
||||
Authorized -> return ()
|
||||
AuthenticationRequired ->
|
||||
case authRoute master of
|
||||
Nothing ->
|
||||
permissionDenied "Authentication required"
|
||||
Just url' -> do
|
||||
setUltDestCurrent
|
||||
redirect url'
|
||||
Unauthorized s' -> permissionDenied s'
|
||||
handler
|
||||
let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session
|
||||
let ra = resolveApproot master req
|
||||
let log' = messageLoggerSource master logger
|
||||
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
|
||||
(yesodRender master ra) errorHandler rr murl sessionMap h
|
||||
extraHeaders <- case yar of
|
||||
(YRPlain _ _ ct _ newSess) -> do
|
||||
let nsToken = maybe
|
||||
newSess
|
||||
(\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
|
||||
(reqToken rr)
|
||||
sessionHeaders <- liftIO (saveSession nsToken)
|
||||
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
|
||||
_ -> return []
|
||||
return $ yarToResponse yar extraHeaders
|
||||
where
|
||||
maxLen = maximumContentLength master $ fmap toMasterRoute murl
|
||||
handler = yesodMiddleware handler'
|
||||
|
||||
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
|
||||
-- resource, you declare the title of the page and the parent resource (if
|
||||
-- present).
|
||||
@ -491,57 +92,6 @@ breadcrumbs = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
|
||||
applyLayout' :: Yesod master
|
||||
=> Html -- ^ title
|
||||
-> HtmlUrl (Route master) -- ^ body
|
||||
-> GHandler sub master ChooseRep
|
||||
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
|
||||
setTitle title
|
||||
toWidget body
|
||||
|
||||
-- | The default error handler for 'errorHandler'.
|
||||
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
|
||||
defaultErrorHandler NotFound = do
|
||||
r <- waiRequest
|
||||
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
|
||||
applyLayout' "Not Found"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Not Found
|
||||
<p>#{path'}
|
||||
|]
|
||||
defaultErrorHandler (PermissionDenied msg) =
|
||||
applyLayout' "Permission Denied"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Permission denied
|
||||
<p>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Invalid Arguments
|
||||
<ul>
|
||||
$forall msg <- ia
|
||||
<li>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InternalError e) = do
|
||||
$logErrorS "yesod-core" e
|
||||
applyLayout' "Internal Server Error"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Internal Server Error
|
||||
<pre>#{e}
|
||||
|]
|
||||
defaultErrorHandler (BadMethod m) =
|
||||
applyLayout' "Bad Method"
|
||||
[hamlet|
|
||||
$newline never
|
||||
<h1>Method Not Supported
|
||||
<p>Method <code>#{S8.unpack m}</code> not supported
|
||||
|]
|
||||
|
||||
-- | Return the same URL if the user is authorized to see it.
|
||||
--
|
||||
-- Built on top of 'isAuthorized'. This is useful for building page that only
|
||||
@ -554,113 +104,6 @@ maybeAuthorized r isWrite = do
|
||||
x <- isAuthorized r isWrite
|
||||
return $ if x == Authorized then Just r else Nothing
|
||||
|
||||
jsToHtml :: Javascript -> Html
|
||||
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
|
||||
|
||||
jelper :: JavascriptUrl url -> HtmlUrl url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
widgetToPageContent :: (Eq (Route master), Yesod master)
|
||||
=> GWidget sub master ()
|
||||
-> GHandler sub master (PageContent (Route master))
|
||||
widgetToPageContent w = do
|
||||
master <- getYesod
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
Just (Left s) -> Just s
|
||||
Just (Right (u, p)) -> Just $ render u p
|
||||
css <- forM (Map.toList style) $ \(mmedia, content) -> do
|
||||
let rendered = toLazyText $ content render
|
||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
||||
$ encodeUtf8 rendered
|
||||
return (mmedia,
|
||||
case x of
|
||||
Nothing -> Left $ preEscapedToMarkup rendered
|
||||
Just y -> Right $ either id (uncurry render) y)
|
||||
jsLoc <-
|
||||
case jscript of
|
||||
Nothing -> return Nothing
|
||||
Just s -> do
|
||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
||||
$ encodeUtf8 $ renderJavascriptUrl render s
|
||||
return $ renderLoc x
|
||||
|
||||
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
|
||||
-- the asynchronous loader means your page doesn't have to wait for all the js to load
|
||||
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
|
||||
regularScriptLoad = [hamlet|
|
||||
$newline never
|
||||
$forall s <- scripts
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
|]
|
||||
|
||||
headAll = [hamlet|
|
||||
$newline never
|
||||
\^{head'}
|
||||
$forall s <- stylesheets
|
||||
^{mkLinkTag s}
|
||||
$forall s <- css
|
||||
$maybe t <- right $ snd s
|
||||
$maybe media <- fst s
|
||||
<link rel=stylesheet media=#{media} href=#{t}>
|
||||
$nothing
|
||||
<link rel=stylesheet href=#{t}>
|
||||
$maybe content <- left $ snd s
|
||||
$maybe media <- fst s
|
||||
<style media=#{media}>#{content}
|
||||
$nothing
|
||||
<style>#{content}
|
||||
$case jsLoader master
|
||||
$of BottomOfBody
|
||||
$of BottomOfHeadAsync asyncJsLoader
|
||||
^{asyncJsLoader asyncScripts mcomplete}
|
||||
$of BottomOfHeadBlocking
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
let bodyScript = [hamlet|
|
||||
$newline never
|
||||
^{body}
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title headAll (case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body)
|
||||
where
|
||||
renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
|
||||
addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
|
||||
mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr TBH.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
|
||||
left :: Either a b -> Maybe a
|
||||
left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
|
||||
right :: Either a b -> Maybe b
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
|
||||
jsonArray :: [Text] -> Html
|
||||
jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
|
||||
|
||||
@ -679,181 +122,39 @@ $newline never
|
||||
<script>yepnope({load:#{jsonArray scripts}});
|
||||
|]
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
-> Maybe (JavascriptUrl (url))
|
||||
-> Maybe Text
|
||||
-> (Maybe (HtmlUrl url), [Text])
|
||||
asyncHelper render scripts jscript jsLoc =
|
||||
(mcomplete, scripts'')
|
||||
where
|
||||
scripts' = map goScript scripts
|
||||
scripts'' =
|
||||
case jsLoc of
|
||||
Just s -> scripts' ++ [s]
|
||||
Nothing -> scripts'
|
||||
goScript (Script (Local url) _) = render url []
|
||||
goScript (Script (Remote s) _) = s
|
||||
mcomplete =
|
||||
case jsLoc of
|
||||
Just{} -> Nothing
|
||||
Nothing ->
|
||||
case jscript of
|
||||
Nothing -> Nothing
|
||||
Just j -> Just $ jelper j
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class YesodDispatch sub master where
|
||||
yesodDispatch
|
||||
:: Yesod master
|
||||
=> Logger
|
||||
-> master
|
||||
-> sub
|
||||
-> (Route sub -> Route master)
|
||||
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
||||
-> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
|
||||
-> Text -- ^ request method
|
||||
-> [Text] -- ^ pieces
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
|
||||
yesodRender :: Yesod y
|
||||
=> y
|
||||
-> ResolvedApproot
|
||||
-> Route y
|
||||
-> [(Text, Text)] -- ^ url query string
|
||||
-> Text
|
||||
yesodRender y ar url params =
|
||||
TE.decodeUtf8 $ toByteString $
|
||||
fromMaybe
|
||||
(joinPath y ar ps
|
||||
$ params ++ params')
|
||||
(urlRenderOverride y url)
|
||||
where
|
||||
(ps, params') = renderRoute url
|
||||
|
||||
resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot
|
||||
resolveApproot master req =
|
||||
case approot of
|
||||
ApprootRelative -> ""
|
||||
ApprootStatic t -> t
|
||||
ApprootMaster f -> f master
|
||||
ApprootRequest f -> f master req
|
||||
|
||||
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
|
||||
defaultClientSessionBackend = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
clientSessionBackend :: Yesod master
|
||||
=> CS.Key -- ^ The encryption key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> SessionBackend master
|
||||
clientSessionBackend key getCachedDate =
|
||||
SessionBackend {
|
||||
sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req
|
||||
}
|
||||
|
||||
loadClientSession :: Yesod master
|
||||
=> CS.Key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
-> master
|
||||
-> W.Request
|
||||
-> IO (SessionMap, SaveSession)
|
||||
loadClientSession key getCachedDate sessionName master req = load
|
||||
where
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
return (sess date, save date)
|
||||
sess date = fromMaybe Map.empty $ do
|
||||
raw <- lookup "Cookie" $ W.requestHeaders req
|
||||
val <- lookup sessionName $ parseCookies raw
|
||||
let host = "" -- fixme, properly lock sessions to client address
|
||||
decodeClientSession key date host val
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just (cookiePath master)
|
||||
, setCookieExpires = Just (csdcExpires date)
|
||||
, setCookieDomain = cookieDomain master
|
||||
, setCookieHttpOnly = True
|
||||
}]
|
||||
where
|
||||
host = "" -- fixme, properly lock sessions to client address
|
||||
|
||||
|
||||
-- | 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
|
||||
-- 'W.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
|
||||
handler'
|
||||
(yesodRender master $ resolveApproot master fakeWaiRequest)
|
||||
Nothing
|
||||
id
|
||||
master
|
||||
master
|
||||
(fileUpload master)
|
||||
(messageLoggerSource master $ logger master)
|
||||
errHandler err req = do
|
||||
liftIO $ I.writeIORef ret (Left err)
|
||||
return $ YRPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
|
||||
(reqSession req)
|
||||
fakeWaiRequest =
|
||||
W.Request
|
||||
{ W.requestMethod = "POST"
|
||||
, W.httpVersion = H.http11
|
||||
, W.rawPathInfo = "/runFakeHandler/pathInfo"
|
||||
, W.rawQueryString = ""
|
||||
, W.serverName = "runFakeHandler-serverName"
|
||||
, W.serverPort = 80
|
||||
, W.requestHeaders = []
|
||||
, W.isSecure = False
|
||||
, W.remoteHost = error "runFakeHandler-remoteHost"
|
||||
, W.pathInfo = ["runFakeHandler", "pathInfo"]
|
||||
, W.queryString = []
|
||||
, W.requestBody = mempty
|
||||
, W.vault = mempty
|
||||
#if MIN_VERSION_wai(1, 4, 0)
|
||||
, W.requestBodyLength = W.KnownLength 0
|
||||
#endif
|
||||
}
|
||||
fakeRequest =
|
||||
YesodRequest
|
||||
{ reqGetParams = []
|
||||
, reqCookies = []
|
||||
, reqWaiRequest = fakeWaiRequest
|
||||
, reqLangs = []
|
||||
, reqToken = Just "NaN" -- not a nonce =)
|
||||
, reqOnError = errHandler
|
||||
, 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 :: Yesod master
|
||||
=> Logger
|
||||
-> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreMaster = master
|
||||
, yreSub = sub
|
||||
, yreRoute = murl
|
||||
, yreToMaster = tomaster
|
||||
, yreSessionBackend = msb
|
||||
} handler
|
||||
|
||||
instance YesodDispatch WaiSubsite master where
|
||||
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|
||||
|
||||
@ -52,7 +52,7 @@ import Text.Cassius
|
||||
import Text.Julius
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Handler
|
||||
( YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
( YesodSubRoute(..), getYesod
|
||||
, getMessageRender, getUrlRenderParams, MonadLift (..)
|
||||
)
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
@ -78,7 +78,7 @@ addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWi
|
||||
addSubWidget sub (GWidget w) = do
|
||||
master <- lift getYesod
|
||||
let sr = fromSubRoute sub master
|
||||
(a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w
|
||||
(a, w') <- lift $ error "FIXME Yesod.Widget.toMasterHandlerMaybe" sr (const sub) Nothing w
|
||||
tell w'
|
||||
return a
|
||||
|
||||
|
||||
@ -104,6 +104,8 @@ library
|
||||
Yesod.Core.Types
|
||||
Yesod.Core.Time
|
||||
Yesod.Core.Trans.Class
|
||||
Yesod.Core.Run
|
||||
Yesod.Core.Class
|
||||
Paths_yesod_core
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user