haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

House cleaning

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 18:32:35 +02:00
parent 15bbd54e12
commit 326c13d8b4
3 changed files with 123 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

183
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -13,7 +13,7 @@ import Yesod.Routes.Class
import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (forM) import Control.Monad (forM, when)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
LogSource) LogSource)
@ -35,7 +35,7 @@ import Data.Word (Word64)
import Language.Haskell.TH.Syntax (Loc (..)) import Language.Haskell.TH.Syntax (Loc (..))
import Network.HTTP.Types (encodePath) import Network.HTTP.Types (encodePath)
import qualified Network.Wai as W import qualified Network.Wai as W
import Network.Wai.Middleware.Gzip (GzipSettings, def) import Data.Default (def)
import Network.Wai.Parse (lbsBackEnd, import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd) tempFileBackEnd)
import System.IO (stdout) import System.IO (stdout)
@ -77,6 +77,8 @@ class RenderRoute site => Yesod site where
approot = ApprootRelative approot = ApprootRelative
-- | Output error response pages. -- | Output error response pages.
--
-- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler = defaultErrorHandler errorHandler = defaultErrorHandler
@ -190,30 +192,27 @@ class RenderRoute site => Yesod site where
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing 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
-}
-- | Maximum allowed length of the request body, in bytes. -- | Maximum allowed length of the request body, in bytes.
-- --
-- Default: 2 megabytes. -- Default: 2 megabytes.
maximumContentLength :: site -> Maybe (Route site) -> Word64 maximumContentLength :: site -> Maybe (Route site) -> Word64
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
-- | Returns a @Logger@ to use for log messages. -- | Creates a @Logger@ to use for log messages.
--
-- Note that a common technique (endorsed by the scaffolding) is to create
-- a @Logger@ value and place it in your foundation datatype, and have this
-- method return that already created value. That way, you can use that
-- same @Logger@ for printing messages during app initialization.
-- --
-- Default: Sends to stdout and automatically flushes on each write. -- Default: Sends to stdout and automatically flushes on each write.
getLogger :: site -> IO Logger makeLogger :: site -> IO Logger
getLogger _ = mkLogger True stdout makeLogger _ = mkLogger True stdout
-- | Send a message to the @Logger@ provided by @getLogger@. -- | Send a message to the @Logger@ provided by @getLogger@.
--
-- Default implementation: checks if the message should be logged using
-- 'shouldLog' and, if so, formats using 'formatLogMessage'.
messageLoggerSource :: site messageLoggerSource :: site
-> Logger -> Logger
-> Loc -- ^ position in source code -> Loc -- ^ position in source code
@ -222,25 +221,15 @@ class RenderRoute site => Yesod site where
-> LogStr -- ^ message -> LogStr -- ^ message
-> IO () -> IO ()
messageLoggerSource a logger loc source level msg = messageLoggerSource a logger loc source level msg =
if shouldLog a source level when (shouldLog a source level) $
then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger 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 :: site -> LogLevel
logLevel _ = LevelInfo
-- | GZIP settings.
gzipSettings :: site -> GzipSettings
gzipSettings _ = def
-- | Where to Load sripts from. We recommend the default value, -- | Where to Load sripts from. We recommend the default value,
-- 'BottomOfBody'. Alternatively use the built in async yepnope loader: -- 'BottomOfBody'. Alternatively use the built in async yepnope loader:
-- --
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
-- --
-- Or write your own async js loader: see 'loadJsYepnope' -- Or write your own async js loader.
jsLoader :: site -> ScriptLoadPosition site jsLoader :: site -> ScriptLoadPosition site
jsLoader _ = BottomOfBody jsLoader _ = BottomOfBody
@ -264,36 +253,49 @@ class RenderRoute site => Yesod site where
-- --
-- Default: Logs everything at or above 'logLevel' -- Default: Logs everything at or above 'logLevel'
shouldLog :: site -> LogSource -> LogLevel -> Bool shouldLog :: site -> LogSource -> LogLevel -> Bool
shouldLog site _ level = level >= logLevel site shouldLog _ _ level = level >= LevelInfo
-- | A Yesod middleware, which will wrap every handler function. This -- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler. -- allows you to run code before and after a normal handler.
-- --
-- Default: Adds the response header \"Vary: Accept, Accept-Language\" and -- Default: the 'defaultYesodMiddleware' function.
-- performs authorization checks.
-- --
-- Since: 1.1.6 -- Since: 1.1.6
yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res
yesodMiddleware handler = do yesodMiddleware = defaultYesodMiddleware
setHeader "Vary" "Accept, Accept-Language"
route <- getCurrentRoute -- | Default implementation of 'yesodMiddleware'. Adds the response header
case route of -- \"Vary: Accept, Accept-Language\" and performs authorization checks.
Nothing -> handler --
Just url -> do -- Since 1.2.0
isWrite <- isWriteRequest url defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
ar <- isAuthorized url isWrite defaultYesodMiddleware handler = do
case ar of setHeader "Vary" "Accept, Accept-Language"
Authorized -> return () authorizationCheck
AuthenticationRequired -> do handler
master <- getYesod
case authRoute master of -- | Check if a given request is authorized via 'isAuthorized' and
Nothing -> -- 'isWriteRequest'.
permissionDenied "Authentication required" --
Just url' -> do -- Since 1.2.0
setUltDestCurrent authorizationCheck :: Yesod site => HandlerT site IO ()
redirect url' authorizationCheck = do
Unauthorized s' -> permissionDenied s' getCurrentRoute >>= maybe (return ()) checkUrl
handler where
checkUrl url = do
isWrite <- isWriteRequest url
ar <- isAuthorized url isWrite
case ar of
Authorized -> return ()
AuthenticationRequired -> do
master <- getYesod
case authRoute master of
Nothing ->
permissionDenied "Authentication required"
Just url' -> do
setUltDestCurrent
redirect url'
Unauthorized s' -> permissionDenied s'
-- | Convert a widget to a 'PageContent'. -- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route site), Yesod site) widgetToPageContent :: (Eq (Route site), Yesod site)
@ -333,48 +335,49 @@ widgetToPageContent w = do
-- the asynchronous loader means your page doesn't have to wait for all the js to load -- 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 let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
regularScriptLoad = [hamlet| regularScriptLoad = [hamlet|
$newline never $newline never
$forall s <- scripts $forall s <- scripts
^{mkScriptTag s} ^{mkScriptTag s}
$maybe j <- jscript $maybe j <- jscript
$maybe s <- jsLoc $maybe s <- jsLoc
<script src="#{s}"> <script src="#{s}">
$nothing $nothing
<script>^{jelper j} <script>^{jelper j}
|] |]
headAll = [hamlet| headAll = [hamlet|
$newline never $newline never
\^{head'} \^{head'}
$forall s <- stylesheets $forall s <- stylesheets
^{mkLinkTag s} ^{mkLinkTag s}
$forall s <- css $forall s <- css
$maybe t <- right $ snd s $maybe t <- right $ snd s
$maybe media <- fst s $maybe media <- fst s
<link rel=stylesheet media=#{media} href=#{t}> <link rel=stylesheet media=#{media} href=#{t}>
$nothing $nothing
<link rel=stylesheet href=#{t}> <link rel=stylesheet href=#{t}>
$maybe content <- left $ snd s $maybe content <- left $ snd s
$maybe media <- fst s $maybe media <- fst s
<style media=#{media}>#{content} <style media=#{media}>#{content}
$nothing $nothing
<style>#{content} <style>#{content}
$case jsLoader master $case jsLoader master
$of BottomOfBody $of BottomOfBody
$of BottomOfHeadAsync asyncJsLoader $of BottomOfHeadAsync asyncJsLoader
^{asyncJsLoader asyncScripts mcomplete} ^{asyncJsLoader asyncScripts mcomplete}
$of BottomOfHeadBlocking $of BottomOfHeadBlocking
^{regularScriptLoad} ^{regularScriptLoad}
|] |]
let bodyScript = [hamlet| let bodyScript = [hamlet|
$newline never $newline never
^{body} ^{body}
^{regularScriptLoad} ^{regularScriptLoad}
|] |]
return $ PageContent title headAll (case jsLoader master of return $ PageContent title headAll $
BottomOfBody -> bodyScript case jsLoader master of
_ -> body) BottomOfBody -> bodyScript
_ -> body
where where
renderLoc' render' (Local url) = render' url [] renderLoc' render' (Local url) = render' url []
renderLoc' _ (Remote s) = s renderLoc' _ (Remote s) = s

74
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -23,12 +23,10 @@ module Yesod.Core.Dispatch
, Texts , Texts
-- * Convert to WAI -- * Convert to WAI
, toWaiApp , toWaiApp
, toWaiAppPlain
-- * WAI subsites -- * WAI subsites
, WaiSubsite (..) , WaiSubsite (..)
) where ) where
import Control.Applicative ((<$>), (<*>))
import Prelude hiding (exp) import Prelude hiding (exp)
import Yesod.Core.Handler import Yesod.Core.Handler
@ -37,8 +35,6 @@ import Language.Haskell.TH
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import qualified Network.Wai as W import qualified Network.Wai as W
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Autohead
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
@ -49,7 +45,6 @@ import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Routes.Parse import Yesod.Routes.Parse
import System.Log.FastLogger (Logger)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Core.Class.Yesod import Yesod.Core.Class.Yesod
@ -180,46 +175,35 @@ mkYesodSubDispatch res = do
return $ LetE [fun] (VarE helper) return $ LetE [fun] (VarE helper)
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes two -- handler. Note that, in versions of Yesod prior to 1.2, this would include
-- middlewares: GZIP compression and autohead. This is the -- some default middlewares (GZIP and autohead). This is no longer the case; if
-- recommended approach for most users. -- you want these middlewares, you should provide them yourself.
toWaiApp :: YesodDispatch site => site -> IO W.Application toWaiApp :: YesodDispatch site => site -> IO W.Application
toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y toWaiApp site = do
logger <- makeLogger site
-- | Convert the given argument into a WAI application, executable with any WAI sb <- makeSessionBackend site
-- handler. This differs from 'toWaiApp' in that it uses no middlewares. let yre = YesodRunnerEnv
toWaiAppPlain :: YesodDispatch site => site -> IO W.Application { yreLogger = logger
toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a , yreSite = site
, yreSessionBackend = sb
toWaiApp' :: YesodDispatch site
=> site
-> Logger
-> Maybe SessionBackend
-> W.Application
toWaiApp' site logger sb req =
case cleanPath site $ W.pathInfo req of
Left pieces -> sendRedirect site pieces req
Right pieces -> yesodDispatch yre req
{ W.pathInfo = pieces
} }
return $ \req ->
case cleanPath site $ W.pathInfo req of
Left pieces -> sendRedirect site pieces req
Right pieces -> yesodDispatch yre req
{ W.pathInfo = pieces
}
where where
yre = YesodRunnerEnv sendRedirect :: Yesod master => master -> [Text] -> W.Application
{ yreLogger = logger sendRedirect y segments' env =
, yreSite = site return $ W.responseLBS status301
, yreSessionBackend = sb [ ("Content-Type", "text/plain")
} , ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
sendRedirect :: Yesod master => master -> [Text] -> W.Application where
sendRedirect y segments' env = dest = joinPath y (resolveApproot y env) segments' []
return $ W.responseLBS status301 dest' =
[ ("Content-Type", "text/plain") if S.null (W.rawQueryString env)
, ("Location", Blaze.ByteString.Builder.toByteString dest') then dest
] "Redirecting" else (dest `mappend`
where Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
dest = joinPath y (resolveApproot y env) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else (dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))

1
yesod-core/yesod-core.cabal
View File

@ -87,6 +87,7 @@ library
, attoparsec-conduit , attoparsec-conduit
, blaze-html >= 0.5 , blaze-html >= 0.5
, blaze-markup >= 0.5.1 , blaze-markup >= 0.5.1
, data-default
exposed-modules: Yesod.Core exposed-modules: Yesod.Core
Yesod.Core.Content Yesod.Core.Content