{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS) import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Control.Arrow ((***), second) import Control.Exception (bracket) import Control.Monad (forM, when, void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Aeson (object, (.=)) import Data.List (foldl') import Data.List (nub) import qualified Data.Map as Map 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 Data.Default (def) import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import Network.Wai.Logger (ZonedDate, clockDateCacher) import System.Log.FastLogger 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.Core.Internal.Session import Yesod.Core.Widget import Control.Monad.Trans.Class (lift) import Data.CaseInsensitive (CI) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute site => Yesod site 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 site approot = ApprootRelative -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. defaultLayout :: WidgetT site IO () -> HandlerT site IO Html defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage withUrlRenderer [hamlet| $newline never $doctype 5
#{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 :: site -> Route site -> 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 site -> Bool -- ^ is this a write request? -> HandlerT site IO 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 site -> HandlerT site IO 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 :: site -> Maybe (Route site) 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 :: site -> [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 :: site -> 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 -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Maximum allowed length of the request body, in bytes. -- -- If @Nothing@, no maximum is applied. -- -- Default: 2 megabytes. maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64 maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes -- | 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: the 'defaultMakeLogger' function. makeLogger :: site -> IO Logger makeLogger _ = defaultMakeLogger -- | Send a message to the @Logger@ provided by @getLogger@. -- -- Default: the 'defaultMessageLoggerSource' function, using -- 'shouldLogIO' to check whether we should log. messageLoggerSource :: site -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site -- | 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. jsLoader :: site -> ScriptLoadPosition site jsLoader _ = BottomOfBody -- | Create a session backend. Returning 'Nothing' disables -- sessions. If you'd like to change the way that the session -- cookies are created, take a look at -- 'customizeSessionCookies'. -- -- Default: Uses clientsession with a 2 hour timeout. makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile -- | 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 :: site -> W.RequestBodyLength -> FileUpload fileUpload _ (W.KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd -- | Should we log the given log source/level combination. -- -- Default: the 'defaultShouldLog' function. shouldLog :: site -> LogSource -> LogLevel -> Bool shouldLog _ = defaultShouldLog -- | Should we log the given log source/level combination. -- -- Note that this is almost identical to @shouldLog@, except the result -- lives in @IO@. This allows you to dynamically alter the logging level of -- your application by having this result depend on, e.g., an @IORef@. -- -- The default implementation simply uses @shouldLog@. Future versions of -- Yesod will remove @shouldLog@ and use this method exclusively. -- -- Since 1.2.4 shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool shouldLogIO a b c = return (shouldLog a b c) -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- -- Default: the 'defaultYesodMiddleware' function. -- -- Since: 1.1.6 yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res yesodMiddleware = defaultYesodMiddleware -- | How to allocate an @InternalState@ for each request. -- -- The default implementation is almost always what you want. However, if -- you know that you are never taking advantage of the @MonadResource@ -- instance in your handler functions, setting this to a dummy -- implementation can provide a small optimization. Only do this if you -- really know what you're doing, otherwise you can turn safe code into a -- runtime error! -- -- Since 1.4.2 yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a yesodWithInternalState _ _ = bracket createInternalState closeInternalState {-# INLINE yesodWithInternalState #-} -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write. -- -- Since 1.4.10 defaultMakeLogger :: IO Logger defaultMakeLogger = do loggerSet' <- newStdoutLoggerSet defaultBufSize (getter, _) <- clockDateCacher return $! Logger loggerSet' getter -- | Default implementation of 'messageLoggerSource'. Checks if the -- message should be logged using the provided function, and if so, -- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO' -- as the provided function. -- -- Since 1.4.10 defaultMessageLoggerSource :: (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should -- log this -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () defaultMessageLoggerSource ckLoggable logger loc source level msg = do loggable <- ckLoggable source level when loggable $ formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger -- | Default implementation of 'shouldLog'. Logs everything at or -- above 'LevelInfo'. -- -- Since 1.4.10 defaultShouldLog :: LogSource -> LogLevel -> Bool defaultShouldLog _ level = level >= LevelInfo -- | A default implementation of 'shouldLogIO' that can be used with -- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'. -- -- Since 1.4.10 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool defaultShouldLogIO a b = return $ defaultShouldLog a b -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- -- Since 1.2.0 defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language" authorizationCheck handler -- | Defends against session hijacking by setting the secure bit on session -- cookies so that browsers will not transmit them over http. With this -- setting on, it follows that the server will regard requests made over -- http as sessionless, because the session cookie will not be included in -- the request. Use this as part of a total security measure which also -- includes disabling HTTP traffic to the site or issuing redirects from -- HTTP urls, and composing 'sslOnlyMiddleware' with the site's -- 'yesodMiddleware'. -- -- Since 1.4.7 sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) sslOnlySessions = (fmap . fmap) secureSessionCookies where setSecureBit cookie = cookie { setCookieSecure = True } secureSessionCookies = customizeSessionCookies setSecureBit -- | Apply a Strict-Transport-Security header with the specified timeout to -- all responses so that browsers will rewrite all http links to https -- until the timeout expires. For security, the max-age of the STS header -- should always equal or exceed the client sessions timeout. This defends -- against hijacking attacks on the sessions of users who attempt to access -- the site using an http url. This middleware makes a site functionally -- inaccessible over vanilla http in all standard browsers. -- -- Since 1.4.7 sslOnlyMiddleware :: Yesod site => Int -- ^ minutes -> HandlerT site IO res -> HandlerT site IO res sslOnlyMiddleware timeout handler = do addHeader "Strict-Transport-Security" $ T.pack $ concat [ "max-age=" , show $ timeout * 60 , "; includeSubDomains" ] handler -- | Check if a given request is authorized via 'isAuthorized' and -- 'isWriteRequest'. -- -- Since 1.2.0 authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck = do getCurrentRoute >>= maybe (return ()) checkUrl 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 -> void $ notAuthenticated Just url' -> do void $ selectRep $ do provideRepType typeHtml $ do setUltDestCurrent void $ redirect url' provideRepType typeJson $ void $ notAuthenticated Unauthorized s' -> permissionDenied s' -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- -- Since 1.4.14 defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfCheckMiddleware handler = do csrfCheckMiddleware handler (getCurrentRoute >>= maybe (return False) isWriteRequest) defaultCsrfHeaderName defaultCsrfParamName -- | Looks up the CSRF token from the request headers or POST parameters. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- -- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. -- -- Since 1.4.14 csrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from. -> HandlerT site IO res csrfCheckMiddleware handler shouldCheckFn headerName paramName = do shouldCheck <- shouldCheckFn when shouldCheck (checkCsrfHeaderOrParam headerName paramName) handler -- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'. -- -- Since 1.4.14 defaultCsrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfSetCookieMiddleware handler = csrfSetCookieMiddleware handler (def { setCookieName = defaultCsrfCookieName }) -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. -- -- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. -- -- Since 1.4.14 csrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> SetCookie -> HandlerT site IO res csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. Use this midle -- -- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. -- -- Since 1.4.14 defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route site), Yesod site) => WidgetT site IO () -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do master <- getYesod hd <- HandlerT return ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd 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
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