yesod-core 1.6.12 → 1.6.13
raw patch · 62 files changed
+6835/−6814 lines, 62 filesdep +memorydep −byteable
Dependencies added: memory
Dependencies removed: byteable
Files
- ChangeLog.md +4/−0
- Yesod/Core.hs +0/−189
- Yesod/Core/Class/Breadcrumbs.hs +0/−31
- Yesod/Core/Class/Dispatch.hs +0/−52
- Yesod/Core/Class/Handler.hs +0/−120
- Yesod/Core/Class/Yesod.hs +0/−907
- Yesod/Core/Content.hs +0/−303
- Yesod/Core/Dispatch.hs +0/−254
- Yesod/Core/Handler.hs +0/−1686
- Yesod/Core/Internal.hs +0/−8
- Yesod/Core/Internal/LiteApp.hs +0/−88
- Yesod/Core/Internal/Request.hs +0/−198
- Yesod/Core/Internal/Response.hs +0/−113
- Yesod/Core/Internal/Run.hs +0/−368
- Yesod/Core/Internal/Session.hs +0/−70
- Yesod/Core/Internal/TH.hs +0/−220
- Yesod/Core/Internal/Util.hs +0/−54
- Yesod/Core/Json.hs +0/−220
- Yesod/Core/TypeCache.hs +0/−96
- Yesod/Core/Types.hs +0/−554
- Yesod/Core/Unsafe.hs +0/−25
- Yesod/Core/Widget.hs +0/−274
- Yesod/Routes/Class.hs +0/−24
- Yesod/Routes/Overlap.hs +0/−88
- Yesod/Routes/Parse.hs +0/−296
- Yesod/Routes/TH.hs +0/−15
- Yesod/Routes/TH/Dispatch.hs +0/−202
- Yesod/Routes/TH/ParseRoute.hs +0/−47
- Yesod/Routes/TH/RenderRoute.hs +0/−167
- Yesod/Routes/TH/RouteAttrs.hs +0/−41
- Yesod/Routes/TH/Types.hs +0/−101
- src/Yesod/Core.hs +189/−0
- src/Yesod/Core/Class/Breadcrumbs.hs +31/−0
- src/Yesod/Core/Class/Dispatch.hs +52/−0
- src/Yesod/Core/Class/Handler.hs +120/−0
- src/Yesod/Core/Class/Yesod.hs +920/−0
- src/Yesod/Core/Content.hs +303/−0
- src/Yesod/Core/Dispatch.hs +254/−0
- src/Yesod/Core/Handler.hs +1686/−0
- src/Yesod/Core/Internal.hs +8/−0
- src/Yesod/Core/Internal/LiteApp.hs +88/−0
- src/Yesod/Core/Internal/Request.hs +198/−0
- src/Yesod/Core/Internal/Response.hs +113/−0
- src/Yesod/Core/Internal/Run.hs +370/−0
- src/Yesod/Core/Internal/Session.hs +70/−0
- src/Yesod/Core/Internal/TH.hs +220/−0
- src/Yesod/Core/Internal/Util.hs +54/−0
- src/Yesod/Core/Json.hs +220/−0
- src/Yesod/Core/TypeCache.hs +96/−0
- src/Yesod/Core/Types.hs +554/−0
- src/Yesod/Core/Unsafe.hs +25/−0
- src/Yesod/Core/Widget.hs +274/−0
- src/Yesod/Routes/Class.hs +24/−0
- src/Yesod/Routes/Overlap.hs +88/−0
- src/Yesod/Routes/Parse.hs +296/−0
- src/Yesod/Routes/TH.hs +15/−0
- src/Yesod/Routes/TH/Dispatch.hs +202/−0
- src/Yesod/Routes/TH/ParseRoute.hs +47/−0
- src/Yesod/Routes/TH/RenderRoute.hs +167/−0
- src/Yesod/Routes/TH/RouteAttrs.hs +41/−0
- src/Yesod/Routes/TH/Types.hs +101/−0
- yesod-core.cabal +5/−3
ChangeLog.md view
@@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.13++* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)+ ## 1.6.12 * Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)
− Yesod/Core.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Yesod.Core- ( -- * Type classes- Yesod (..)- , YesodDispatch (..)- , YesodSubDispatch (..)- , RenderRoute (..)- , ParseRoute (..)- , RouteAttrs (..)- -- ** Breadcrumbs- , YesodBreadcrumbs (..)- , breadcrumbs- -- * Types- , Approot (..)- , FileUpload (..)- , ErrorResponse (..)- -- * Utilities- , maybeAuthorized- , widgetToPageContent- -- * Defaults- , defaultErrorHandler- , defaultYesodMiddleware- , authorizationCheck- -- * Data types- , AuthResult (..)- , unauthorizedI- -- * Logging- , defaultMakeLogger- , defaultMessageLoggerSource- , defaultShouldLogIO- , formatLogMessage- , LogLevel (..)- , logDebug- , logInfo- , logWarn- , logError- , logOther- , logDebugS- , logInfoS- , logWarnS- , logErrorS- , logOtherS- -- * Sessions- , SessionBackend (..)- , customizeSessionCookies- , defaultClientSessionBackend- , envClientSessionBackend- , clientSessionBackend- , sslOnlySessions- , laxSameSiteSessions- , strictSameSiteSessions- , sslOnlyMiddleware- , clientSessionDateCacher- , loadClientSession- , Header(..)- -- * CSRF protection- , defaultCsrfMiddleware- , defaultCsrfSetCookieMiddleware- , csrfSetCookieMiddleware- , defaultCsrfCheckMiddleware- , csrfCheckMiddleware- -- * JS loaders- , ScriptLoadPosition (..)- , BottomOfHeadAsync- -- * Generalizing type classes- , MonadHandler (..)- , MonadWidget (..)- -- * Approot- , guessApproot- , guessApprootOr- , getApprootText- -- * Misc- , yesodVersion- , yesodRender- , Yesod.Core.runFakeHandler- -- * LiteApp- , module Yesod.Core.Internal.LiteApp- -- * Low-level- , yesodRunner- -- * Re-exports- , module Yesod.Core.Content- , module Yesod.Core.Dispatch- , module Yesod.Core.Handler- , module Yesod.Core.Widget- , module Yesod.Core.Json- , module Text.Shakespeare.I18N- , module Yesod.Core.Internal.Util- , module Text.Blaze.Html- , MonadTrans (..)- , MonadIO (..)- , MonadUnliftIO (..)- , MonadResource (..)- , MonadLogger- -- * Commonly referenced functions/datatypes- , Application- -- * Utilities- , showIntegral- , readIntegral- -- * Shakespeare- -- ** Hamlet- , hamlet- , shamlet- , xhamlet- , HtmlUrl- -- ** Julius- , julius- , JavascriptUrl- , renderJavascriptUrl- -- ** Cassius/Lucius- , cassius- , lucius- , CssUrl- , renderCssUrl- ) where--import Yesod.Core.Content-import Yesod.Core.Dispatch-import Yesod.Core.Handler-import Yesod.Core.Class.Handler-import Yesod.Core.Widget-import Yesod.Core.Json-import Yesod.Core.Types-import Text.Shakespeare.I18N-import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)-import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)--import Control.Monad.Logger-import Control.Monad.Trans.Class (MonadTrans (..))-import Yesod.Core.Internal.Session-import Yesod.Core.Internal.Run (yesodRunner, yesodRender)-import Yesod.Core.Class.Yesod-import Yesod.Core.Class.Dispatch-import Yesod.Core.Class.Breadcrumbs-import qualified Yesod.Core.Internal.Run-import qualified Paths_yesod_core-import Data.Version (showVersion)-import Yesod.Routes.Class-import UnliftIO (MonadIO (..), MonadUnliftIO (..))--import Control.Monad.Trans.Resource (MonadResource (..))-import Yesod.Core.Internal.LiteApp-import Text.Hamlet-import Text.Cassius-import Text.Lucius-import Text.Julius-import Network.Wai (Application)--runFakeHandler :: (Yesod site, MonadIO m) =>- SessionMap- -> (site -> Logger)- -> site- -> HandlerT site IO a- -> m (Either ErrorResponse a)-runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler-{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}---- | Return an 'Unauthorized' value, with the given i18n message.-unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult-unauthorizedI msg = do- mr <- getMessageRender- return $ Unauthorized $ mr msg--yesodVersion :: String-yesodVersion = showVersion Paths_yesod_core.version---- | 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--- contain links to pages the user is allowed to see.-maybeAuthorized :: Yesod site- => Route site- -> Bool -- ^ is this a write request?- -> HandlerT site IO (Maybe (Route site))-maybeAuthorized r isWrite = do- x <- isAuthorized r isWrite- return $ if x == Authorized then Just r else Nothing--showIntegral :: Integral a => a -> String-showIntegral x = show (fromIntegral x :: Integer)--readIntegral :: Num a => String -> Maybe a-readIntegral s =- case reads s of- (i, _):_ -> Just $ fromInteger i- [] -> Nothing
− Yesod/Core/Class/Breadcrumbs.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Core.Class.Breadcrumbs where--import Yesod.Core.Handler-import Yesod.Routes.Class-import Data.Text (Text)---- | 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).-class YesodBreadcrumbs site where- -- | Returns the title and the parent resource, if available. If you return- -- a 'Nothing', then this is considered a top-level page.- breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))---- | Gets the title of the current page and the hierarchy of parent pages,--- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])-breadcrumbs = do- x <- getCurrentRoute- case x of- Nothing -> return ("Not found", [])- Just y -> do- (title, next) <- breadcrumb y- z <- go [] next- return (title, z)- where- go back Nothing = return back- go back (Just this) = do- (title, next) <- breadcrumb this- go ((this, title) : back) next
− Yesod/Core/Class/Dispatch.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Core.Class.Dispatch where--import qualified Network.Wai as W-import Yesod.Core.Types-import Yesod.Core.Content (ToTypedContent (..))-import Yesod.Core.Handler (sendWaiApplication)-import Yesod.Core.Class.Yesod---- | This class is automatically instantiated when you use the template haskell--- mkYesod function. You should never need to deal with it directly.-class Yesod site => YesodDispatch site where- yesodDispatch :: YesodRunnerEnv site -> W.Application--class YesodSubDispatch sub master where- yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application--instance YesodSubDispatch WaiSubsite master where- yesodSubDispatch YesodSubRunnerEnv {..} = app- where- WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv--instance YesodSubDispatch WaiSubsiteWithAuth master where- yesodSubDispatch YesodSubRunnerEnv {..} req =- ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req- where- route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []- WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv- handlert = sendWaiApplication set--subHelper- :: ToTypedContent content- => SubHandlerFor child master content- -> YesodSubRunnerEnv child master- -> Maybe (Route child)- -> W.Application-subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =- ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)- where- handler = fmap toTypedContent $ HandlerFor $ \hd ->- let rhe = handlerEnv hd- rhe' = rhe- { rheRoute = mroute- , rheChild = ysreGetSub $ yreSite ysreParentEnv- , rheRouteToMaster = ysreToParentRoute- }- in f hd { handlerEnv = rhe' }
− Yesod/Core/Class/Handler.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-module Yesod.Core.Class.Handler- ( MonadHandler (..)- , MonadWidget (..)- , liftHandlerT- , liftWidgetT- ) where--import Yesod.Core.Types-import Control.Monad.Logger (MonadLogger)-import Control.Monad.Trans.Resource (MonadResource)-import Control.Monad.Trans.Class (lift)-import Data.Conduit.Internal (Pipe, ConduitM)--import Control.Monad.Trans.Identity ( IdentityT)-import Control.Monad.Trans.List ( ListT )-import Control.Monad.Trans.Maybe ( MaybeT )-import Control.Monad.Trans.Except ( ExceptT )-import Control.Monad.Trans.Reader ( ReaderT )-import Control.Monad.Trans.State ( StateT )-import Control.Monad.Trans.Writer ( WriterT )-import Control.Monad.Trans.RWS ( RWST )-import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )-import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )-import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )---- FIXME should we just use MonadReader instances instead?-class (MonadResource m, MonadLogger m) => MonadHandler m where- type HandlerSite m- type SubHandlerSite m- liftHandler :: HandlerFor (HandlerSite m) a -> m a- liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a--liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a-liftHandlerT = liftHandler-{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}--instance MonadHandler (HandlerFor site) where- type HandlerSite (HandlerFor site) = site- type SubHandlerSite (HandlerFor site) = site- liftHandler = id- {-# INLINE liftHandler #-}- liftSubHandler (SubHandlerFor f) = HandlerFor f- {-# INLINE liftSubHandler #-}--instance MonadHandler (SubHandlerFor sub master) where- type HandlerSite (SubHandlerFor sub master) = master- type SubHandlerSite (SubHandlerFor sub master) = sub- liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd- { handlerEnv =- let rhe = handlerEnv hd- in rhe- { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)- , rheRouteToMaster = id- , rheChild = rheSite rhe- }- }- {-# INLINE liftHandler #-}- liftSubHandler = id- {-# INLINE liftSubHandler #-}--instance MonadHandler (WidgetFor site) where- type HandlerSite (WidgetFor site) = site- type SubHandlerSite (WidgetFor site) = site- liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler- {-# INLINE liftHandler #-}- liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler- {-# INLINE liftSubHandler #-}--#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler-#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GO(ExceptT e)-GO(ReaderT r)-GO(StateT s)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)-GO(Pipe l i o u)-GO(ConduitM i o)-#undef GO-#undef GOX--class MonadHandler m => MonadWidget m where- liftWidget :: WidgetFor (HandlerSite m) a -> m a-instance MonadWidget (WidgetFor site) where- liftWidget = id- {-# INLINE liftWidget #-}--liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a-liftWidgetT = liftWidget-{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}--#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget-#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget-GO(IdentityT)-GO(ListT)-GO(MaybeT)-GO(ExceptT e)-GO(ReaderT r)-GO(StateT s)-GOX(Monoid w, WriterT w)-GOX(Monoid w, RWST r w s)-GOX(Monoid w, Strict.RWST r w s)-GO(Strict.StateT s)-GOX(Monoid w, Strict.WriterT w)-GO(Pipe l i o u)-GO(ConduitM i o)-#undef GO-#undef GOX
− Yesod/Core/Class/Yesod.hs
@@ -1,907 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-module Yesod.Core.Class.Yesod where--import Yesod.Core.Content-import Yesod.Core.Handler--import Yesod.Routes.Class--import Data.ByteString.Builder (Builder)-import Data.Text.Encoding (encodeUtf8Builder)-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, logErrorS)-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', nub)-import qualified Data.Map as Map-import Data.Maybe (catMaybes)-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.Parse (lbsBackEnd,- tempFileBackEnd)-import Network.Wai.Logger (ZonedDate, clockDateCacher)-import System.Log.FastLogger-import Text.Blaze (customAttribute, textTag,- toValue, (!),- preEscapedToMarkup)-import qualified Text.Blaze.Html5 as TBH-import Text.Hamlet-import Text.Julius-import qualified Web.ClientSession as CS-import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,- sameSiteStrict, SameSiteOption, defaultSetCookie)-import Yesod.Core.Types-import Yesod.Core.Internal.Session-import Yesod.Core.Widget-import Data.CaseInsensitive (CI)-import qualified Network.Wai.Request-import Data.IORef---- | 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: 'guessApproot'. If you know your application root- -- statically, it will be more efficient and more reliable to instead use- -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute- -- URLs, you can use 'ApprootRelative' instead.- --- -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.- approot :: Approot site- approot = guessApproot-- -- | Output error response pages.- --- -- Default value: 'defaultErrorHandler'.- errorHandler :: ErrorResponse -> HandlerFor site TypedContent- errorHandler = defaultErrorHandler-- -- | Applies some form of layout to the contents of a page.- defaultLayout :: WidgetFor site () -> HandlerFor site Html- defaultLayout w = do- p <- widgetToPageContent w- msgs <- getMessages- withUrlRenderer [hamlet|- $newline never- $doctype 5- <html>- <head>- <title>#{pageTitle p}- ^{pageHead p}- <body>- $forall (status, msg) <- msgs- <p class="message #{status}">#{msg}- ^{pageBody p}- |]-- -- | Override the rendering function for a particular URL and query string- -- parameters. One use case for this is to offload static hosting to a- -- different domain name to avoid sending cookies.- --- -- For backward compatibility default implementation is in terms of- -- 'urlRenderOverride', probably ineffective- --- -- Since 1.4.23- urlParamRenderOverride :: site- -> Route site- -> [(T.Text, T.Text)] -- ^ query string- -> Maybe Builder- urlParamRenderOverride _ _ _ = 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?- -> HandlerFor site 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 -> HandlerFor site 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' =- encodeUtf8Builder 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- -> HandlerFor site (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'.- jsLoader :: site -> ScriptLoadPosition site- jsLoader _ = BottomOfBody-- -- | Default attributes to put on the JavaScript <script> tag- -- generated for julius files- jsAttributes :: site -> [(Text, Text)]- jsAttributes _ = []-- -- | 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 _ = 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 'defaultShouldLogIO' function.- --- -- Since 1.2.4- shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool- shouldLogIO _ = defaultShouldLogIO-- -- | 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 => HandlerFor site res -> HandlerFor site 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 #-}-- -- | Convert a title and HTML snippet into a 'Widget'. Used- -- primarily for wrapping up error messages for better display.- --- -- @since 1.4.30- defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()- defaultMessageWidget title body = do- setTitle title- toWidget- [hamlet|- <h1>#{title}- ^{body}- |]---- | 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-defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool-defaultShouldLogIO _ level = return $ level >= LevelInfo---- | Default implementation of 'yesodMiddleware'. Adds the response header--- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and--- performs authorization checks.------ Since 1.2.0-defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res-defaultYesodMiddleware handler = do- addHeader "Vary" "Accept, Accept-Language"- addHeader "X-XSS-Protection" "1; mode=block"- 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---- | Helps defend against CSRF attacks by setting the SameSite attribute on--- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site--- requests, and with cross-site top-level navigations.------ This option is liable to change in future versions of Yesod as the spec evolves.--- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.------ @since 1.4.23-laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)-laxSameSiteSessions = sameSiteSession sameSiteLax---- | Helps defend against CSRF attacks by setting the SameSite attribute on--- session cookies to Strict. With the Strict setting, the cookie will only be--- sent with same-site requests.------ This option is liable to change in future versions of Yesod as the spec evolves.--- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.------ @since 1.4.23-strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)-strictSameSiteSessions = sameSiteSession sameSiteStrict--sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)-sameSiteSession s = (fmap . fmap) secureSessionCookies- where- sameSite cookie = cookie { setCookieSameSite = Just s }- secureSessionCookies = customizeSessionCookies sameSite---- | 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 SSL-stripping man-in-the-middle attacks. It is only effective if--- a secure connection has already been made; Strict-Transport-Security--- headers are ignored over HTTP.------ Since 1.4.7-sslOnlyMiddleware :: Int -- ^ minutes- -> HandlerFor site res- -> HandlerFor site 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 => HandlerFor site ()-authorizationCheck = 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' ->- 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 => HandlerFor site res -> HandlerFor site res-defaultCsrfCheckMiddleware handler =- 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 :: HandlerFor site res- -> HandlerFor site 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.- -> HandlerFor site res-csrfCheckMiddleware handler shouldCheckFn headerName paramName = do- shouldCheck <- shouldCheckFn- when shouldCheck (checkCsrfHeaderOrParam headerName paramName)- handler---- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'.------ The cookie's path is set to @/@, making it valid for your whole website.------ Since 1.4.14-defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res-defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler---- | 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".------ Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.------ Since 1.4.14-csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res-csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler---- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.------ For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".------ You can chain this middleware together with other middleware like so:------ @--- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'--- @------ or:------ @--- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app--- @------ Since 1.4.14-defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res-defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware---- | Convert a widget to a 'PageContent'.-widgetToPageContent :: Yesod site- => WidgetFor site ()- -> HandlerFor site (PageContent (Route site))-widgetToPageContent w = HandlerFor $ \hd -> do- master <- unHandlerFor getYesod hd- ref <- newIORef mempty- unWidgetFor w WidgetData- { wdRef = ref- , wdHandler = hd- }- GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref- let title = maybe mempty unTitle mTitle- scripts = runUniqueList scripts'- stylesheets = runUniqueList stylesheets'-- flip unHandlerFor hd $ do- 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}" *{jsAttributes master}>- $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- )-- runUniqueList :: Eq x => UniqueList x -> [x]- runUniqueList (UniqueList x) = nub $ x []---- | The default error handler for 'errorHandler'.-defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent-defaultErrorHandler NotFound = selectRep $ do- provideRep $ defaultLayout $ do- r <- waiRequest- let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r- defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]- provideRep $ return $ object ["message" .= ("Not Found" :: Text)]- provideRep $ return $ ("Not Found" :: Text)---- For API requests.--- For a user with a browser,--- if you specify an authRoute the user will be redirected there and--- this page will not be shown.-defaultErrorHandler NotAuthenticated = selectRep $ do- provideRep $ defaultLayout $ defaultMessageWidget- "Not logged in"- [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|]-- provideRep $ do- -- 401 *MUST* include a WWW-Authenticate header- -- however, there is no standard to indicate a redirection- --- -- change this to Basic or Digest if you allow those forms of authentications- addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""-- -- The client will just use the authentication_url in the JSON- site <- getYesod- rend <- getUrlRender- let apair u = ["authentication_url" .= rend u]- content = maybe [] apair (authRoute site)- return $ object $ ("message" .= ("Not logged in"::Text)):content- provideRep $ return $ ("Not logged in" :: Text)--defaultErrorHandler (PermissionDenied msg) = selectRep $ do- provideRep $ defaultLayout $ defaultMessageWidget- "Permission Denied"- [hamlet|<p>#{msg}|]- provideRep $- return $ object ["message" .= ("Permission Denied. " <> msg)]- provideRep $ return $ "Permission Denied. " <> msg--defaultErrorHandler (InvalidArgs ia) = selectRep $ do- provideRep $ defaultLayout $ defaultMessageWidget- "Invalid Arguments"- [hamlet|- <ul>- $forall msg <- ia- <li>#{msg}- |]- provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]- provideRep $ return $ ("Invalid Arguments: " <> T.intercalate " " ia)--defaultErrorHandler (InternalError e) = do- $logErrorS "yesod-core" e- selectRep $ do- provideRep $ defaultLayout $ defaultMessageWidget- "Internal Server Error"- [hamlet|<pre>#{e}|]- provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]- provideRep $ return $ "Internal Server Error: " <> e--defaultErrorHandler (BadMethod m) = selectRep $ do- provideRep $ defaultLayout $ defaultMessageWidget- "Method Not Supported"- [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]- provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]- provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m--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---- | Default formatting for log messages. When you use--- the template haskell logging functions for to log with information--- about the source location, that information will be appended to--- the end of the log. When you use the non-TH logging functions,--- like 'logDebugN', this function does not include source--- information. This currently works by checking to see if the--- package name is the string \"\<unknown\>\". This is a hack,--- but it removes some of the visual clutter from non-TH logs.------ Since 1.4.10-formatLogMessage :: IO ZonedDate- -> Loc- -> LogSource- -> LogLevel- -> LogStr -- ^ message- -> IO LogStr-formatLogMessage getdate loc src level msg = do- now <- getdate- return $ mempty- `mappend` toLogStr now- `mappend` " ["- `mappend` (case level of- LevelOther t -> toLogStr t- _ -> toLogStr $ drop 5 $ show level)- `mappend` (if T.null src- then mempty- else "#" `mappend` toLogStr src)- `mappend` "] "- `mappend` msg- `mappend` sourceSuffix- `mappend` "\n"- where- sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty- `mappend` " @("- `mappend` toLogStr (fileLocationToString loc)- `mappend` ")"---- | Customize the cookies used by the session backend. You may--- use this function on your definition of 'makeSessionBackend'.------ For example, you could set the cookie domain so that it--- would work across many subdomains:------ @--- makeSessionBackend site =--- (fmap . fmap) (customizeSessionCookies addDomain) ...--- where--- addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }--- @------ Default: Do not customize anything ('id').-customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)-customizeSessionCookies customizeCookie backend = backend'- where- customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie)- customizeHeader other = other- customizeSaveSession = (fmap . fmap . fmap) customizeHeader- backend' =- backend {- sbLoadSession = \req ->- second customizeSaveSession `fmap` sbLoadSession backend req- }---defaultClientSessionBackend :: Int -- ^ minutes- -> FilePath -- ^ key file- -> IO SessionBackend-defaultClientSessionBackend minutes fp = do- key <- CS.getKey fp- (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)- return $ clientSessionBackend key getCachedDate---- | Create a @SessionBackend@ which reads the session key from the named--- environment variable.------ This can be useful if:------ 1. You can't rely on a persistent file system (e.g. Heroku)--- 2. Your application is open source (e.g. you can't commit the key)------ By keeping a consistent value in the environment variable, your users will--- have consistent sessions without relying on the file system.------ Note: A suitable value should only be obtained in one of two ways:------ 1. Run this code without the variable set, a value will be generated and--- printed on @/dev/stdout/@--- 2. Use @clientsession-generate@------ Since 1.4.5-envClientSessionBackend :: Int -- ^ minutes- -> String -- ^ environment variable name- -> IO SessionBackend-envClientSessionBackend minutes name = do- key <- CS.getKeyEnv name- (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes- return $ clientSessionBackend key getCachedDate--minToSec :: (Integral a, Num b) => a -> b-minToSec minutes = fromIntegral (minutes * 60)--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 :: CS.Key -- ^ The encryption key- -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'- -> SessionBackend-clientSessionBackend key getCachedDate =- SessionBackend {- sbLoadSession = loadClientSession key getCachedDate "_SESSION"- }--justSingleton :: a -> [Maybe a] -> a-justSingleton d = just . catMaybes- where- just [s] = s- just _ = d--loadClientSession :: CS.Key- -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'- -> S8.ByteString -- ^ session name- -> W.Request- -> IO (SessionMap, SaveSession)-loadClientSession key getCachedDate sessionName req = load- where- load = do- date <- getCachedDate- return (sess date, save date)- sess date = justSingleton Map.empty $ do- raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]- val <- [v | (k, v) <- parseCookies raw, k == sessionName]- let host = "" -- fixme, properly lock sessions to client address- return $ decodeClientSession key date host val- save date sess' = do- -- We should never cache the IV! Be careful!- iv <- liftIO CS.randomIV- return [AddCookie defaultSetCookie- { setCookieName = sessionName- , setCookieValue = encodeClientSession key iv date host sess'- , setCookiePath = Just "/"- , setCookieExpires = Just (csdcExpires date)- , setCookieDomain = Nothing- , 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 =- concat- [ loc_package loc- , ':' : loc_module loc- , ' ' : loc_filename loc- , ':' : line loc- , ':' : char loc- ]- where- line = show . fst . loc_start- char = show . snd . loc_start---- | Guess the approot based on request headers. For more information, see--- "Network.Wai.Middleware.Approot"------ In the case of headers being unavailable, it falls back to 'ApprootRelative'------ Since 1.4.16-guessApproot :: Approot site-guessApproot = guessApprootOr ApprootRelative---- | Guess the approot based on request headers, with fall back to the--- specified 'AppRoot'.------ Since 1.4.16-guessApprootOr :: Approot site -> Approot site-guessApprootOr fallback = ApprootRequest $ \master req ->- case W.requestHeaderHost req of- Nothing -> getApprootText fallback master req- Just host ->- (if Network.Wai.Request.appearsSecure req- then "https://"- else "http://")- `T.append` TE.decodeUtf8With TEE.lenientDecode host---- | Get the textual application root from an 'Approot' value.------ Since 1.4.17-getApprootText :: Approot site -> site -> W.Request -> Text-getApprootText ar site req =- case ar of- ApprootRelative -> ""- ApprootStatic t -> t- ApprootMaster f -> f site- ApprootRequest f -> f site req
− Yesod/Core/Content.hs
@@ -1,303 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Core.Content- ( -- * Content- Content (..)- , emptyContent- , ToContent (..)- , ToFlushBuilder (..)- -- * Mime types- -- ** Data type- , ContentType- , typeHtml- , typePlain- , typeJson- , typeXml- , typeAtom- , typeRss- , typeJpeg- , typePng- , typeGif- , typeSvg- , typeJavascript- , typeCss- , typeFlv- , typeOgv- , typeOctet- -- * Utilities- , simpleContentType- , contentTypeTypes- -- * Evaluation strategy- , DontFullyEvaluate (..)- -- * Representations- , TypedContent (..)- , ToTypedContent (..)- , HasContentType (..)- -- ** Specific content types- , RepHtml- , RepJson (..)- , RepPlain (..)- , RepXml (..)- -- ** Smart constructors- , repJson- , repPlain- , repXml- ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Text.Lazy (Text, pack)-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8Builder)-import qualified Data.Text.Lazy as TL-import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)-import Text.Hamlet (Html)-import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)-import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)-import Control.Monad (liftM)-import Control.Monad.Trans.Resource (ResourceT)-import qualified Data.Conduit.Internal as CI--import qualified Data.Aeson as J-import Data.Text.Lazy.Builder (toLazyText)-import Yesod.Core.Types-import Text.Lucius (Css, renderCss)-import Text.Julius (Javascript, unJavascript)-import Data.Word8 (_semicolon, _slash)-import Control.Arrow (second)---- | Zero-length enumerator.-emptyContent :: Content-emptyContent = ContentBuilder mempty $ Just 0---- | Anything which can be converted into 'Content'. Most of the time, you will--- want to use the 'ContentBuilder' constructor. An easier approach will be to use--- a pre-defined 'toContent' function, such as converting your data into a lazy--- bytestring and then calling 'toContent' on that.------ Please note that the built-in instances for lazy data structures ('String',--- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include--- the content length for the 'ContentBuilder' constructor.-class ToContent a where- toContent :: a -> Content--instance ToContent Content where- toContent = id-instance ToContent Builder where- toContent = flip ContentBuilder Nothing-instance ToContent B.ByteString where- toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs-instance ToContent L.ByteString where- toContent = flip ContentBuilder Nothing . lazyByteString-instance ToContent T.Text where- toContent = toContent . encodeUtf8Builder-instance ToContent Text where- toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks-instance ToContent String where- toContent = toContent . stringUtf8-instance ToContent Html where- toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing-instance ToContent () where- toContent () = toContent B.empty-instance ToContent (ContentType, Content) where- toContent = snd-instance ToContent TypedContent where- toContent (TypedContent _ c) = c--instance ToContent Css where- toContent = toContent . renderCss-instance ToContent Javascript where- toContent = toContent . toLazyText . unJavascript--instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where- toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)--instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where- toContent src = ContentSource $ mapOutput toFlushBuilder src-instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where- toContent (CI.SealedConduitT src) = toContent src---- | A class for all data which can be sent in a streaming response. Note that--- for textual data, instances must use UTF-8 encoding.------ Since 1.2.0-class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder-instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id-instance ToFlushBuilder Builder where toFlushBuilder = Chunk-instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString-instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString-instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString-instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString-instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)-instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks-instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder-instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder-instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8-instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8-instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder-instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder--repJson :: ToContent a => a -> RepJson-repJson = RepJson . toContent--repPlain :: ToContent a => a -> RepPlain-repPlain = RepPlain . toContent--repXml :: ToContent a => a -> RepXml-repXml = RepXml . toContent--class ToTypedContent a => HasContentType a where- getContentType :: Monad m => m a -> ContentType--instance HasContentType RepJson where- getContentType _ = typeJson-deriving instance ToContent RepJson--instance HasContentType RepPlain where- getContentType _ = typePlain-deriving instance ToContent RepPlain--instance HasContentType RepXml where- getContentType _ = typeXml-deriving instance ToContent RepXml---typeHtml :: ContentType-typeHtml = "text/html; charset=utf-8"--typePlain :: ContentType-typePlain = "text/plain; charset=utf-8"--typeJson :: ContentType-typeJson = "application/json; charset=utf-8"--typeXml :: ContentType-typeXml = "text/xml"--typeAtom :: ContentType-typeAtom = "application/atom+xml"--typeRss :: ContentType-typeRss = "application/rss+xml"--typeJpeg :: ContentType-typeJpeg = "image/jpeg"--typePng :: ContentType-typePng = "image/png"--typeGif :: ContentType-typeGif = "image/gif"--typeSvg :: ContentType-typeSvg = "image/svg+xml"--typeJavascript :: ContentType-typeJavascript = "text/javascript; charset=utf-8"--typeCss :: ContentType-typeCss = "text/css; charset=utf-8"--typeFlv :: ContentType-typeFlv = "video/x-flv"--typeOgv :: ContentType-typeOgv = "video/ogg"--typeOctet :: ContentType-typeOctet = "application/octet-stream"---- | Removes \"extra\" information at the end of a content type string. In--- particular, removes everything after the semicolon, if present.------ For example, \"text/html; charset=utf-8\" is commonly used to specify the--- character encoding for HTML data. This function would return \"text/html\".-simpleContentType :: ContentType -> ContentType-simpleContentType = fst . B.break (== _semicolon)---- | Give just the media types as a pair.------ For example, \"text/html; charset=utf-8\" returns ("text", "html")-contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)-contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType- where- tailEmpty x = if B.null x then "" else B.tail x--instance HasContentType a => HasContentType (DontFullyEvaluate a) where- getContentType = getContentType . liftM unDontFullyEvaluate--instance ToContent a => ToContent (DontFullyEvaluate a) where- toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a--instance ToContent J.Value where- toContent = flip ContentBuilder Nothing- . J.fromEncoding- . J.toEncoding--instance ToContent J.Encoding where- toContent = flip ContentBuilder Nothing . J.fromEncoding--instance HasContentType J.Value where- getContentType _ = typeJson--instance HasContentType J.Encoding where- getContentType _ = typeJson--instance HasContentType Html where- getContentType _ = typeHtml--instance HasContentType Text where- getContentType _ = typePlain--instance HasContentType T.Text where- getContentType _ = typePlain--instance HasContentType Css where- getContentType _ = typeCss--instance HasContentType Javascript where- getContentType _ = typeJavascript---- | Any type which can be converted to 'TypedContent'.------ Since 1.2.0-class ToContent a => ToTypedContent a where- toTypedContent :: a -> TypedContent--instance ToTypedContent TypedContent where- toTypedContent = id-instance ToTypedContent () where- toTypedContent () = TypedContent typePlain (toContent ())-instance ToTypedContent (ContentType, Content) where- toTypedContent (ct, content) = TypedContent ct content-instance ToTypedContent RepJson where- toTypedContent (RepJson c) = TypedContent typeJson c-instance ToTypedContent RepPlain where- toTypedContent (RepPlain c) = TypedContent typePlain c-instance ToTypedContent RepXml where- toTypedContent (RepXml c) = TypedContent typeXml c-instance ToTypedContent J.Value where- toTypedContent v = TypedContent typeJson (toContent v)-instance ToTypedContent J.Encoding where- toTypedContent e = TypedContent typeJson (toContent e)-instance ToTypedContent Html where- toTypedContent h = TypedContent typeHtml (toContent h)-instance ToTypedContent T.Text where- toTypedContent t = TypedContent typePlain (toContent t)-instance ToTypedContent [Char] where- toTypedContent = toTypedContent . pack-instance ToTypedContent Text where- toTypedContent t = TypedContent typePlain (toContent t)-instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where- toTypedContent (DontFullyEvaluate a) =- let TypedContent ct c = toTypedContent a- in TypedContent ct (ContentDontEvaluate c)--instance ToTypedContent Css where- toTypedContent = TypedContent typeCss . toContent-instance ToTypedContent Javascript where- toTypedContent = TypedContent typeJavascript . toContent
− Yesod/Core/Dispatch.hs
@@ -1,254 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Yesod.Core.Dispatch- ( -- * Quasi-quoted routing- parseRoutes- , parseRoutesNoCheck- , parseRoutesFile- , parseRoutesFileNoCheck- , mkYesod- , mkYesodWith- -- ** More fine-grained- , mkYesodData- , mkYesodSubData- , mkYesodDispatch- , mkYesodSubDispatch- -- *** Helpers- , getGetMaxExpires- -- ** Path pieces- , PathPiece (..)- , PathMultiPiece (..)- , Texts- -- * Convert to WAI- , toWaiApp- , toWaiAppPlain- , toWaiAppYre- , warp- , warpDebug- , warpEnv- , mkDefaultMiddlewares- , defaultMiddlewaresNoLogging- -- * WAI subsites- , WaiSubsite (..)- , WaiSubsiteWithAuth (..)- ) where--import Prelude hiding (exp)-import Yesod.Core.Internal.TH-import Language.Haskell.TH.Syntax (qLocation)--import Web.PathPieces--import qualified Network.Wai as W--import Data.ByteString.Lazy.Char8 ()--import Data.Text (Text)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Builder (byteString, toLazyByteString)-import Network.HTTP.Types (status301, status307)-import Yesod.Routes.Parse-import Yesod.Core.Types-import Yesod.Core.Class.Yesod-import Yesod.Core.Class.Dispatch-import Yesod.Core.Internal.Run-import Text.Read (readMaybe)-import System.Environment (getEnvironment)-import qualified System.Random as Random-import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)-import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)--import Network.Wai.Middleware.Autohead-import Network.Wai.Middleware.AcceptOverride-import Network.Wai.Middleware.RequestLogger-import Network.Wai.Middleware.Gzip-import Network.Wai.Middleware.MethodOverride--import qualified Network.Wai.Handler.Warp-import System.Log.FastLogger-import Control.Monad.Logger-import Control.Monad (when)-import qualified Paths_yesod_core-import Data.Version (showVersion)---- | Convert the given argument into a WAI application, executable with any WAI--- handler. This function will provide no middlewares; if you want commonly--- used middlewares, please use 'toWaiApp'.-toWaiAppPlain :: YesodDispatch site => site -> IO W.Application-toWaiAppPlain site = do- logger <- makeLogger site- sb <- makeSessionBackend site- getMaxExpires <- getGetMaxExpires- return $ toWaiAppYre YesodRunnerEnv- { yreLogger = logger- , yreSite = site- , yreSessionBackend = sb- , yreGen = defaultGen- , yreGetMaxExpires = getMaxExpires- }--defaultGen :: IO Int-defaultGen = Random.getStdRandom Random.next---- | Pure low level function to construct WAI application. Usefull--- when you need not standard way to run your app, or want to embed it--- inside another app.------ @since 1.4.29-toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application-toWaiAppYre yre req =- case cleanPath site $ W.pathInfo req of- Left pieces -> sendRedirect site pieces req- Right pieces -> yesodDispatch yre req- { W.pathInfo = pieces- }- where- site = yreSite yre- sendRedirect :: Yesod master => master -> [Text] -> W.Application- sendRedirect y segments' env sendResponse =- sendResponse $ W.responseLBS status- [ ("Content-Type", "text/plain")- , ("Location", BL.toStrict $ toLazyByteString dest')- ] "Redirecting"- where- -- Ensure that non-GET requests get redirected correctly. See:- -- https://github.com/yesodweb/yesod/issues/951- status- | W.requestMethod env == "GET" = status301- | otherwise = status307-- dest = joinPath y (resolveApproot y env) segments' []- dest' =- if S.null (W.rawQueryString env)- then dest- else dest `mappend`- byteString (W.rawQueryString env)---- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This--- set may change with future releases, but currently covers:------ * Logging------ * GZIP compression------ * Automatic HEAD method handling------ * Request method override with the _method query string parameter------ * Accept header override with the _accept query string parameter-toWaiApp :: YesodDispatch site => site -> IO W.Application-toWaiApp site = do- logger <- makeLogger site- toWaiAppLogger logger site--toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application-toWaiAppLogger logger site = do- sb <- makeSessionBackend site- getMaxExpires <- getGetMaxExpires- let yre = YesodRunnerEnv- { yreLogger = logger- , yreSite = site- , yreSessionBackend = sb- , yreGen = defaultGen- , yreGetMaxExpires = getMaxExpires- }- messageLoggerSource- site- logger- $(qLocation >>= liftLoc)- "yesod-core"- LevelInfo- (toLogStr ("Application launched" :: S.ByteString))- middleware <- mkDefaultMiddlewares logger- return $ middleware $ toWaiAppYre yre---- | A convenience method to run an application using the Warp webserver on the--- specified port. Automatically calls 'toWaiApp'. Provides a default set of--- middlewares. This set may change at any point without a breaking version--- number. Currently, it includes:------ If you need more fine-grained control of middlewares, please use 'toWaiApp'--- directly.------ Since 1.2.0-warp :: YesodDispatch site => Int -> site -> IO ()-warp port site = do- logger <- makeLogger site- toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (- Network.Wai.Handler.Warp.setPort port $- Network.Wai.Handler.Warp.setServerName serverValue $- Network.Wai.Handler.Warp.setOnException (\_ e ->- when (shouldLog' e) $- messageLoggerSource- site- logger- $(qLocation >>= liftLoc)- "yesod-core"- LevelError- (toLogStr $ "Exception from Warp: " ++ show e))- Network.Wai.Handler.Warp.defaultSettings)- where- shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException--serverValue :: S8.ByteString-serverValue = S8.pack $ concat- [ "Warp/"- , Network.Wai.Handler.Warp.warpVersion- , " + Yesod/"- , showVersion Paths_yesod_core.version- , " (core)"- ]---- | A default set of middlewares.------ Since 1.2.0-mkDefaultMiddlewares :: Logger -> IO W.Middleware-mkDefaultMiddlewares logger = do- logWare <- mkRequestLogger def- { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger- , outputFormat = Apache FromSocket- }- return $ logWare . defaultMiddlewaresNoLogging---- | All of the default middlewares, excluding logging.------ Since 1.2.12-defaultMiddlewaresNoLogging :: W.Middleware-defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride---- | Deprecated synonym for 'warp'.-warpDebug :: YesodDispatch site => Int -> site -> IO ()-warpDebug = warp-{-# DEPRECATED warpDebug "Please use warp instead" #-}---- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It--- reads port information from the PORT environment variable, as used by tools--- such as Keter and the FP Complete School of Haskell.------ Note that the exact behavior of this function may be modified slightly over--- time to work correctly with external tools, without a change to the type--- signature.-warpEnv :: YesodDispatch site => site -> IO ()-warpEnv site = do- env <- getEnvironment- case lookup "PORT" env of- Nothing -> error "warpEnv: no PORT environment variable found"- Just portS ->- case readMaybe portS of- Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS- Just port -> warp port site---- | Default constructor for 'yreGetMaxExpires' field. Low level--- function for simple manual construction of 'YesodRunnerEnv'.------ @since 1.4.29-getGetMaxExpires :: IO (IO Text)-getGetMaxExpires = mkAutoUpdate defaultUpdateSettings- { updateAction = getCurrentMaxExpiresRFC1123- , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day- }
− Yesod/Core/Handler.hs
@@ -1,1686 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------- Module : Yesod.Handler--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : stable--- Portability : portable------ Define Handler stuff.--------------------------------------------------------------module Yesod.Core.Handler- ( -- * Handler monad- HandlerT- , HandlerFor- -- ** Read information from handler- , getYesod- , getsYesod- , getUrlRender- , getUrlRenderParams- , getPostParams- , getCurrentRoute- , getRequest- , waiRequest- , runRequestBody- , rawRequestBody- -- ** Request information- -- *** Request datatype- , RequestBodyContents- , YesodRequest (..)- , FileInfo- , fileName- , fileContentType- , fileSource- , fileSourceByteString- , fileMove- -- *** Convenience functions- , languages- -- *** Lookup parameters- , lookupGetParam- , lookupPostParam- , lookupCookie- , lookupFile- , lookupHeader- -- **** Lookup authentication data- , lookupBasicAuth- , lookupBearerAuth- -- **** Multi-lookup- , lookupGetParams- , lookupPostParams- , lookupCookies- , lookupFiles- , lookupHeaders- -- * Responses- -- ** Pure- , respond- -- ** Streaming- , respondSource- , sendChunk- , sendFlush- , sendChunkBS- , sendChunkLBS- , sendChunkText- , sendChunkLazyText- , sendChunkHtml- -- ** Redirecting- , RedirectUrl (..)- , redirect- , redirectWith- , redirectToPost- , Fragment(..)- -- ** Errors- , notFound- , badMethod- , notAuthenticated- , permissionDenied- , permissionDeniedI- , invalidArgs- , invalidArgsI- -- ** Short-circuit responses.- , sendFile- , sendFilePart- , sendResponse- , sendResponseStatus- -- ** Type specific response with custom status- , sendStatusJSON- , sendResponseCreated- , sendResponseNoContent- , sendWaiResponse- , sendWaiApplication- , sendRawResponse- , sendRawResponseNoConduit- , notModified- -- * Different representations- -- $representations- , selectRep- , provideRep- , provideRepType- , ProvidedRep- -- * Setting headers- , setCookie- , getExpires- , deleteCookie- , addHeader- , setHeader- , replaceOrAddHeader- , setLanguage- , addContentDispositionFileName- -- ** Content caching and expiration- , cacheSeconds- , neverExpires- , alreadyExpired- , expiresAt- , setEtag- , setWeakEtag- -- * Session- , SessionMap- , lookupSession- , lookupSessionBS- , getSession- , setSession- , setSessionBS- , deleteSession- , clearSession- -- ** Ultimate destination- , setUltDest- , setUltDestCurrent- , setUltDestReferer- , redirectUltDest- , clearUltDest- -- ** Messages- , addMessage- , addMessageI- , getMessages- , setMessage- , setMessageI- , getMessage- -- * Subsites- , SubHandlerFor- , getSubYesod- , getRouteToParent- , getSubCurrentRoute- -- * Helpers for specific content- -- ** Hamlet- , hamletToRepHtml- , giveUrlRenderer- , withUrlRenderer- -- ** Misc- , newIdent- -- * Lifting- , handlerToIO- , forkHandler- -- * i18n- , getMessageRender- -- * Per-request caching- , cached- , cacheGet- , cacheSet- , cachedBy- , cacheByGet- , cacheBySet- -- * AJAX CSRF protection-- -- $ajaxCSRFOverview-- -- ** Setting CSRF Cookies- , setCsrfCookie- , setCsrfCookieWithCookie- , defaultCsrfCookieName- -- ** Looking up CSRF Headers- , checkCsrfHeaderNamed- , hasValidCsrfHeaderNamed- , defaultCsrfHeaderName- -- ** Looking up CSRF POST Parameters- , hasValidCsrfParamNamed- , checkCsrfParamNamed- , defaultCsrfParamName- -- ** Checking CSRF Headers or POST Parameters- , checkCsrfHeaderOrParam- ) where--import Data.Time (UTCTime, addUTCTime,- getCurrentTime)-import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,- mkFileInfoLBS, mkFileInfoSource)---import Control.Applicative ((<|>))-import qualified Data.CaseInsensitive as CI-import Control.Exception (evaluate, SomeException, throwIO)-import Control.Exception (handle)--import Control.Monad (void, liftM, unless)-import qualified Control.Monad.Trans.Writer as Writer--import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO)--import qualified Network.HTTP.Types as H-import qualified Network.Wai as W-import Network.Wai.Middleware.HttpAuth- ( extractBasicAuth, extractBearerAuth )-import Control.Monad.Trans.Class (lift)--import Data.Aeson (ToJSON(..))-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.Lazy as TL-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)-import Text.Hamlet (Html, HtmlUrl, hamlet)--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import qualified Data.HashMap.Strict as HM--import Data.Byteable (constEqBytes)--import Control.Arrow ((***))-import qualified Data.ByteString.Char8 as S8-import Data.Monoid (Endo (..))-import Data.Text (Text)-import qualified Network.Wai.Parse as NWP-import Text.Shakespeare.I18N (RenderMessage (..))-import Web.Cookie (SetCookie (..), defaultSetCookie)-import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))-import Yesod.Core.Internal.Util (formatRFC1123)-import Text.Blaze.Html (preEscapedToHtml, toHtml)--import qualified Data.IORef as I-import Data.Maybe (listToMaybe, mapMaybe)-import Data.Typeable (Typeable)-import Web.PathPieces (PathPiece(..))-import Yesod.Core.Class.Handler-import Yesod.Core.Types-import Yesod.Routes.Class (Route)-import Data.ByteString.Builder (Builder)-import Data.CaseInsensitive (CI, original)-import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)-import qualified System.PosixCompat.Files as PC-import Conduit ((.|), runConduit, sinkLazy)-import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)-import qualified Yesod.Core.TypeCache as Cache-import qualified Data.Word8 as W8-import qualified Data.Foldable as Fold-import Control.Monad.Logger (MonadLogger, logWarnS)--type HandlerT site (m :: * -> *) = HandlerFor site-{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}--get :: MonadHandler m => m GHState-get = liftHandler $ HandlerFor $ I.readIORef . handlerState--put :: MonadHandler m => GHState -> m ()-put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState--modify :: MonadHandler m => (GHState -> GHState) -> m ()-modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState--tell :: MonadHandler m => Endo [Header] -> m ()-tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }--handlerError :: MonadHandler m => HandlerContents -> m a-handlerError = liftIO . throwIO--hcError :: MonadHandler m => ErrorResponse -> m a-hcError = handlerError . HCError--getRequest :: MonadHandler m => m YesodRequest-getRequest = liftHandler $ HandlerFor $ return . handlerRequest--runRequestBody :: MonadHandler m => m RequestBodyContents-runRequestBody = do- HandlerData- { handlerEnv = RunHandlerEnv {..}- , handlerRequest = req- } <- liftHandler $ HandlerFor return- let len = W.requestBodyLength $ reqWaiRequest req- upload = rheUpload len- x <- get- case ghsRBC x of- Just rbc -> return rbc- Nothing -> do- rr <- waiRequest- internalState <- liftResourceT getInternalState- rbc <- liftIO $ rbHelper upload rr internalState- put x { ghsRBC = Just rbc }- return rbc--rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents-rbHelper upload req internalState =- case upload of- FileUploadMemory s -> rbHelper' s mkFileInfoLBS req- FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req- FileUploadSource s -> rbHelper' s mkFileInfoSource req--rbHelper' :: NWP.BackEnd x- -> (Text -> Text -> x -> FileInfo)- -> W.Request- -> IO ([(Text, Text)], [(Text, FileInfo)])-rbHelper' backend mkFI req =- (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req- where- fix1 = go *** go- fix2 (x, NWP.FileInfo a' b c)- | S.null a = Nothing- | otherwise = Just (go x, mkFI (go a) (go b) c)- where- a- | S.length a' < 2 = a'- | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'- | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'- | otherwise = a'- go = decodeUtf8With lenientDecode--askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))-askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv---- | Get the master site application argument.-getYesod :: MonadHandler m => m (HandlerSite m)-getYesod = rheSite <$> askHandlerEnv---- | Get a specific component of the master site application argument.--- Analogous to the 'gets' function for operating on 'StateT'.-getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a-getsYesod f = (f . rheSite) <$> askHandlerEnv---- | Get the URL rendering function.-getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)-getUrlRender = do- x <- rheRender <$> askHandlerEnv- return $ flip x []---- | The URL rendering function with query-string parameters.-getUrlRenderParams- :: MonadHandler m- => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)-getUrlRenderParams = rheRender <$> askHandlerEnv---- | Get all the post parameters passed to the handler. To also get--- the submitted files (if any), you have to use 'runRequestBody'--- instead of this function.------ @since 1.4.33-getPostParams- :: MonadHandler m- => m [(Text, Text)]-getPostParams = do- reqBodyContent <- runRequestBody- return $ fst reqBodyContent---- | Get the route requested by the user. If this is a 404 response- where the--- user requested an invalid route- this function will return 'Nothing'.-getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))-getCurrentRoute = rheRoute <$> askHandlerEnv---- | Returns a function that runs 'HandlerT' actions inside @IO@.------ Sometimes you want to run an inner 'HandlerT' action outside--- the control flow of an HTTP request (on the outer 'HandlerT'--- action). For example, you may want to spawn a new thread:------ @--- getFooR :: Handler RepHtml--- getFooR = do--- runInnerHandler <- handlerToIO--- liftIO $ forkIO $ runInnerHandler $ do--- /Code here runs inside GHandler but on a new thread./--- /This is the inner GHandler./--- ...--- /Code here runs inside the request's control flow./--- /This is the outer GHandler./--- ...--- @------ Another use case for this function is creating a stream of--- server-sent events using 'GHandler' actions (see--- @yesod-eventsource@).------ Most of the environment from the outer 'GHandler' is preserved--- on the inner 'GHandler', however:------ * The request body is cleared (otherwise it would be very--- difficult to prevent huge memory leaks).------ * The cache is cleared (see 'CacheKey').------ Changes to the response made inside the inner 'GHandler' are--- ignored (e.g., session variables, cookies, response headers).--- This allows the inner 'GHandler' to outlive the outer--- 'GHandler' (e.g., on the @forkIO@ example above, a response--- may be sent to the client without killing the new thread).-handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)-handlerToIO =- HandlerFor $ \oldHandlerData -> do- -- Take just the bits we need from oldHandlerData.- let newReq = oldReq { reqWaiRequest = newWaiReq }- where- oldReq = handlerRequest oldHandlerData- oldWaiReq = reqWaiRequest oldReq- newWaiReq = oldWaiReq { W.requestBody = return mempty- , W.requestBodyLength = W.KnownLength 0- }- oldEnv = handlerEnv oldHandlerData- newState <- liftIO $ do- oldState <- I.readIORef (handlerState oldHandlerData)- return $ oldState { ghsRBC = Nothing- , ghsIdent = 1- , ghsCache = mempty- , ghsCacheBy = mempty- , ghsHeaders = mempty }-- -- xx From this point onwards, no references to oldHandlerData xx- liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())-- -- Return GHandler running function.- return $ \(HandlerFor f) ->- liftIO $- runResourceT $ withInternalState $ \resState -> do- -- The state IORef needs to be created here, otherwise it- -- will be shared by different invocations of this function.- newStateIORef <- liftIO (I.newIORef newState)- let newHandlerData =- HandlerData- { handlerRequest = newReq- , handlerEnv = oldEnv- , handlerState = newStateIORef- , handlerResource = resState- }- liftIO (f newHandlerData)---- | forkIO for a Handler (run an action in the background)------ Uses 'handlerToIO', liftResourceT, and resourceForkIO--- for correctness and efficiency------ @since 1.2.8-forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler- -> HandlerFor site ()- -> HandlerFor site ()-forkHandler onErr handler = do- yesRunner <- handlerToIO- void $ liftResourceT $ resourceForkIO $- liftIO $ handle (yesRunner . onErr) (yesRunner handler)---- | 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--- technique, which should be the usual use case.------ If you want direct control of the final status code, or need a different--- status code, please use 'redirectWith'.-redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)- => url -> m a-redirect url = do- req <- waiRequest- let status =- if W.httpVersion req == H.http11- then H.status303- else H.status302- redirectWith status url---- | Redirect to the given URL with the specified status code.-redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)- => H.Status- -> url- -> m a-redirectWith status url = do- urlText <- toTextUrl url- handlerError $ HCRedirect status urlText--ultDestKey :: Text-ultDestKey = "_ULT"---- | Sets the ultimate destination variable to the given route.------ An ultimate destination is stored in the user session and can be loaded--- later by 'redirectUltDest'.-setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)- => url- -> m ()-setUltDest url = do- urlText <- toTextUrl url- setSession ultDestKey urlText---- | Same as 'setUltDest', but uses the current page.------ If this is a 404 handler, there is no current page, and then this call does--- nothing.-setUltDestCurrent :: MonadHandler m => m ()-setUltDestCurrent = do- route <- getCurrentRoute- case route of- Nothing -> return ()- Just r -> do- gets' <- reqGetParams <$> getRequest- setUltDest (r, gets')---- | Sets the ultimate destination to the referer request header, if present.------ This function will not overwrite an existing ultdest.-setUltDestReferer :: MonadHandler m => m ()-setUltDestReferer = do- mdest <- lookupSession ultDestKey- maybe- (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)- (const $ return ())- mdest- where- setUltDestBS = setUltDest . T.pack . S8.unpack---- | Redirect to the ultimate destination in the user's session. Clear the--- value from the session.------ The ultimate destination is set with 'setUltDest'.------ This function uses 'redirect', and thus will perform a temporary redirect to--- a GET request.-redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)- => url -- ^ default destination if nothing in session- -> m a-redirectUltDest defaultDestination = do- mdest <- lookupSession ultDestKey- deleteSession ultDestKey- maybe (redirect defaultDestination) redirect mdest---- | Remove a previously set ultimate destination. See 'setUltDest'.-clearUltDest :: MonadHandler m => m ()-clearUltDest = deleteSession ultDestKey--msgKey :: Text-msgKey = "_MSG"---- | Adds a status and message in the user's session.------ See 'getMessages'.------ @since 1.4.20-addMessage :: MonadHandler m- => Text -- ^ status- -> Html -- ^ message- -> m ()-addMessage status msg = do- val <- lookupSessionBS msgKey- setSessionBS msgKey $ addMsg val- where- addMsg = maybe msg' (S.append msg' . S.cons W8._nul)- msg' = S.append- (encodeUtf8 status)- (W8._nul `S.cons` L.toStrict (renderHtml msg))---- | Adds a message in the user's session but uses RenderMessage to allow for i18n------ See 'getMessages'.------ @since 1.4.20-addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)- => Text -> msg -> m ()-addMessageI status msg = do- mr <- getMessageRender- addMessage status $ toHtml $ mr msg---- | Gets all messages in the user's session, and then clears the variable.------ See 'addMessage'.------ @since 1.4.20-getMessages :: MonadHandler m => m [(Text, Html)]-getMessages = do- bs <- lookupSessionBS msgKey- let ms = maybe [] enlist bs- deleteSession msgKey- return ms- where- enlist = pairup . S.split W8._nul- pairup [] = []- pairup [_] = []- pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs- decode = decodeUtf8With lenientDecode---- | Calls 'addMessage' with an empty status-setMessage :: MonadHandler m => Html -> m ()-setMessage = addMessage ""---- | Calls 'addMessageI' with an empty status-setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)- => msg -> m ()-setMessageI = addMessageI ""---- | Gets just the last message in the user's session,--- discards the rest and the status-getMessage :: MonadHandler m => m (Maybe Html)-getMessage = fmap (fmap snd . listToMaybe) getMessages---- | Bypass remaining handler code and output the given file.------ For some backends, this is more efficient than reading in the file to--- memory, since they can optimize file sending via a system call to sendfile.-sendFile :: MonadHandler m => ContentType -> FilePath -> m a-sendFile ct fp = handlerError $ HCSendFile ct fp Nothing---- | Same as 'sendFile', but only sends part of a file.-sendFilePart :: MonadHandler m- => ContentType- -> FilePath- -> Integer -- ^ offset- -> Integer -- ^ count- -> m a-sendFilePart ct fp off count = do- fs <- liftIO $ PC.getFileStatus fp- handlerError $ HCSendFile ct fp $ Just W.FilePart- { W.filePartOffset = off- , W.filePartByteCount = count- , W.filePartFileSize = fromIntegral $ PC.fileSize fs- }---- | Bypass remaining handler code and output the given content with a 200--- status code.-sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a-sendResponse = handlerError . HCContent H.status200 . toTypedContent---- | Bypass remaining handler code and output the given content with the given--- status code.-sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a-sendResponseStatus s = handlerError . HCContent s . toTypedContent---- | Bypass remaining handler code and output the given JSON with the given--- status code.------ @since 1.4.18-sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a-sendStatusJSON s v = sendResponseStatus s (toEncoding v)---- | Send a 201 "Created" response with the given route as the Location--- response header.-sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a-sendResponseCreated url = do- r <- getUrlRender- handlerError $ HCCreated $ r url---- | Bypass remaining handler code and output no content with a 204 status code.------ @since 1.6.9-sendResponseNoContent :: MonadHandler m => m a-sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty---- | Send a 'W.Response'. Please note: this function is rarely--- necessary, and will /disregard/ any changes to response headers and session--- that you have already specified. This function short-circuits. It should be--- considered only for very specific needs. If you are not sure if you need it,--- you don't.-sendWaiResponse :: MonadHandler m => W.Response -> m b-sendWaiResponse = handlerError . HCWai---- | Switch over to handling the current request with a WAI @Application@.------ @since 1.2.17-sendWaiApplication :: MonadHandler m => W.Application -> m b-sendWaiApplication = handlerError . HCWaiApp---- | Send a raw response without conduit. This is used for cases such as--- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw--- responses (e.g., Warp).------ @since 1.2.16-sendRawResponseNoConduit- :: (MonadHandler m, MonadUnliftIO m)- => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())- -> m a-sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->- liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback- $ \src sink -> void $ runInIO (raw src sink)- where- fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]- "sendRawResponse: backend does not support raw responses"---- | Send a raw response. This is used for cases such as WebSockets. Requires--- WAI 2.1 or later, and a web server which supports raw responses (e.g.,--- Warp).------ @since 1.2.7-sendRawResponse- :: (MonadHandler m, MonadUnliftIO m)- => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())- -> m a-sendRawResponse raw = withRunInIO $ \runInIO ->- liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback- $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)- where- fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]- "sendRawResponse: backend does not support raw responses"- src' src = do- bs <- liftIO src- unless (S.null bs) $ do- yield bs- src' src---- | Send a 304 not modified response immediately. This is a short-circuiting--- action.------ @since 1.4.4-notModified :: MonadHandler m => m a-notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty---- | Return a 404 not found page. Also denotes no handler available.-notFound :: MonadHandler m => m a-notFound = hcError NotFound---- | Return a 405 method not supported page.-badMethod :: MonadHandler m => m a-badMethod = do- w <- waiRequest- hcError $ BadMethod $ W.requestMethod w---- | Return a 401 status code-notAuthenticated :: MonadHandler m => m a-notAuthenticated = hcError NotAuthenticated---- | Return a 403 permission denied page.-permissionDenied :: MonadHandler m => Text -> m a-permissionDenied = hcError . PermissionDenied---- | Return a 403 permission denied page.-permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)- => msg- -> m a-permissionDeniedI msg = do- mr <- getMessageRender- permissionDenied $ mr msg---- | Return a 400 invalid arguments page.-invalidArgs :: MonadHandler m => [Text] -> m a-invalidArgs = hcError . InvalidArgs---- | Return a 400 invalid arguments page.-invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a-invalidArgsI msg = do- mr <- getMessageRender- invalidArgs $ map mr msg--------- Headers--- | Set the cookie on the client.--setCookie :: MonadHandler m => SetCookie -> m ()-setCookie sc = do- addHeaderInternal (DeleteCookie name path)- addHeaderInternal (AddCookie sc)- where name = setCookieName sc- path = maybe "/" id (setCookiePath sc)---- | Helper function for setCookieExpires value-getExpires :: MonadIO m- => Int -- ^ minutes- -> m UTCTime-getExpires m = do- now <- liftIO getCurrentTime- return $ fromIntegral (m * 60) `addUTCTime` now----- | Unset the cookie on the client.------ Note: although the value used for key and path is 'Text', you should only--- use ASCII values to be HTTP compliant.-deleteCookie :: MonadHandler m- => Text -- ^ key- -> Text -- ^ path- -> m ()-deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8----- | Set the language in the user session. Will show up in 'languages' on the--- next request.-setLanguage :: MonadHandler m => Text -> m ()-setLanguage = setSession langKey---- | Set attachment file name.------ Allows Unicode characters by encoding to UTF-8.--- Some modurn browser parse UTF-8 characters with out encoding setting.--- But, for example IE9 can't parse UTF-8 characters.--- This function use--- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)------ @since 1.6.4-addContentDispositionFileName :: MonadHandler m => T.Text -> m ()-addContentDispositionFileName fileName- = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName---- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.------ > rfc6266Utf8FileName (Data.Text.pack "€")--- "attachment; filename*=UTF-8''%E2%82%AC"-rfc6266Utf8FileName :: T.Text -> T.Text-rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName))---- | Set an arbitrary response header.------ Note that, while the data type used here is 'Text', you must provide only--- ASCII value to be HTTP compliant.------ @since 1.2.0-addHeader :: MonadHandler m => Text -> Text -> m ()-addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8---- | Deprecated synonym for addHeader.-setHeader :: MonadHandler m => Text -> Text -> m ()-setHeader = addHeader-{-# DEPRECATED setHeader "Please use addHeader instead" #-}---- | Replace an existing header with a new value or add a new header--- if not present.------ Note that, while the data type used here is 'Text', you must provide only--- ASCII value to be HTTP compliant.------ @since 1.4.36-replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()-replaceOrAddHeader a b =- modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}- where- repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)-- sameHeaderName :: Header -> Header -> Bool- sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2- sameHeaderName _ _ = False-- replaceIndividualHeader :: [Header] -> [Header]- replaceIndividualHeader [] = [repHeader]- replaceIndividualHeader xs = aux xs []- where- aux [] acc = acc ++ [repHeader]- aux (x:xs') acc =- if sameHeaderName repHeader x- then acc ++- [repHeader] ++- (filter (\header -> not (sameHeaderName header repHeader)) xs')- else aux xs' (acc ++ [x])-- replaceHeader :: Endo [Header] -> Endo [Header]- replaceHeader endo =- let allHeaders :: [Header] = appEndo endo []- in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest)---- | Set the Cache-Control header to indicate this response should be cached--- for the given number of seconds.-cacheSeconds :: MonadHandler m => Int -> m ()-cacheSeconds i = setHeader "Cache-Control" $ T.concat- [ "max-age="- , T.pack $ show i- , ", public"- ]---- | Set the Expires header to some date in 2037. In other words, this content--- is never (realistically) expired.-neverExpires :: MonadHandler m => m ()-neverExpires = do- setHeader "Expires" . rheMaxExpires =<< askHandlerEnv- cacheSeconds oneYear- where- oneYear :: Int- oneYear = 60 * 60 * 24 * 365---- | Set an Expires header in the past, meaning this content should not be--- cached.-alreadyExpired :: MonadHandler m => m ()-alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"---- | Set an Expires header to the given date.-expiresAt :: MonadHandler m => UTCTime -> m ()-expiresAt = setHeader "Expires" . formatRFC1123--data Etag- = WeakEtag !S.ByteString- -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are- -- semantically identical but make no guarantees about being bytewise identical.- | StrongEtag !S.ByteString- -- ^ Signifies that contents should be byte-for-byte identical if they match- -- the provided ETag- | InvalidEtag !S.ByteString- -- ^ Anything else that ends up in a header that expects an ETag but doesn't- -- properly follow the ETag format specified in RFC 7232, section 2.3- deriving (Show, Eq)---- | Check the if-none-match header and, if it matches the given value, return--- a 304 not modified response. Otherwise, set the etag header to the given--- value.------ Note that it is the responsibility of the caller to ensure that the provided--- value is a valid etag value, no sanity checking is performed by this--- function.------ @since 1.4.4-setEtag :: MonadHandler m => Text -> m ()-setEtag etag = do- mmatch <- lookupHeader "if-none-match"- let matches = maybe [] parseMatch mmatch- baseTag = encodeUtf8 etag- strongTag = StrongEtag baseTag- badTag = InvalidEtag baseTag- if any (\tag -> tag == strongTag || tag == badTag) matches- then notModified- else addHeader "etag" $ T.concat ["\"", etag, "\""]----- | Parse an if-none-match field according to the spec.-parseMatch :: S.ByteString -> [Etag]-parseMatch =- map clean . S.split W8._comma- where- clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace-- classify bs- | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl- = StrongEtag $ S.init $ S.tail bs- | S.length bs >= 4 &&- S.head bs == W8._W &&- S.index bs 1 == W8._slash &&- S.index bs 2 == W8._quotedbl &&- S.last bs == W8._quotedbl- = WeakEtag $ S.init $ S.drop 3 bs- | otherwise = InvalidEtag bs---- | Check the if-none-match header and, if it matches the given value, return--- a 304 not modified response. Otherwise, set the etag header to the given--- value.------ A weak etag is only expected to be semantically identical to the prior content,--- but doesn't have to be byte-for-byte identical. Therefore it can be useful for--- dynamically generated content that may be difficult to perform bytewise hashing--- upon.------ Note that it is the responsibility of the caller to ensure that the provided--- value is a valid etag value, no sanity checking is performed by this--- function.------ @since 1.4.37-setWeakEtag :: MonadHandler m => Text -> m ()-setWeakEtag etag = do- mmatch <- lookupHeader "if-none-match"- let matches = maybe [] parseMatch mmatch- if WeakEtag (encodeUtf8 etag) `elem` matches- then notModified- else addHeader "etag" $ T.concat ["W/\"", etag, "\""]---- | Set a variable in the user's session.------ The session is handled by the clientsession package: it sets an encrypted--- and hashed cookie on the client. This ensures that all data is secure and--- not tampered with.-setSession :: MonadHandler m- => Text -- ^ key- -> Text -- ^ value- -> m ()-setSession k = setSessionBS k . encodeUtf8---- | Same as 'setSession', but uses binary data for the value.-setSessionBS :: MonadHandler m- => Text- -> S.ByteString- -> m ()-setSessionBS k = modify . modSession . Map.insert k---- | Unsets a session variable. See 'setSession'.-deleteSession :: MonadHandler m => Text -> m ()-deleteSession = modify . modSession . Map.delete---- | Clear all session variables.------ @since: 1.0.1-clearSession :: MonadHandler m => m ()-clearSession = modify $ \x -> x { ghsSession = Map.empty }--modSession :: (SessionMap -> SessionMap) -> GHState -> GHState-modSession f x = x { ghsSession = f $ ghsSession x }---- | Internal use only, not to be confused with 'setHeader'.-addHeaderInternal :: MonadHandler m => Header -> m ()-addHeaderInternal = tell . Endo . (:)---- | 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.- toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text--instance RedirectUrl master Text where- toTextUrl = return--instance RedirectUrl master String where- toTextUrl = toTextUrl . T.pack--instance RedirectUrl master (Route master) where- toTextUrl url = do- r <- getUrlRender- return $ r url--instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where- toTextUrl (url, params) = do- r <- getUrlRenderParams- return $ r url params--instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where- toTextUrl (url, params) = toTextUrl (url, Map.toList params)---- | Add a fragment identifier to a route to be used when--- redirecting. For example:------ > redirect (NewsfeedR :#: storyId)------ @since 1.2.9.-data Fragment a b = a :#: b deriving (Show, Typeable)--instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where- toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a----- | Lookup for session data.-lookupSession :: MonadHandler m => Text -> m (Maybe Text)-lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS---- | Lookup for session data in binary format.-lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)-lookupSessionBS n = do- m <- fmap ghsSession get- return $ Map.lookup n m---- | Get all session variables.-getSession :: MonadHandler m => m SessionMap-getSession = fmap ghsSession get---- | Get a unique identifier.-newIdent :: MonadHandler m => m Text-newIdent = do- x <- get- let i' = ghsIdent x + 1- put x { ghsIdent = i' }- return $ T.pack $ "hident" ++ show i'---- | Redirect to a POST resource.------ This is not technically a redirect; instead, it returns an HTML page with a--- POST form, and some Javascript to automatically submit the form. This can be--- useful when you need to post a plain link somewhere that needs to cause--- changes on the server.-redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)- => url- -> m a-redirectToPost url = do- urlText <- toTextUrl url- req <- getRequest- withUrlRenderer [hamlet|-$newline never-$doctype 5--<html>- <head>- <title>Redirecting...- <body onload="document.getElementById('form').submit()">- <form id="form" method="post" action=#{urlText}>- $maybe token <- reqToken req- <input type=hidden name=#{defaultCsrfParamName} value=#{token}>- <noscript>- <p>Javascript has been disabled; please click on the button below to be redirected.- <input type="submit" value="Continue">-|] >>= sendResponse---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html-hamletToRepHtml = withUrlRenderer-{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}---- | Deprecated synonym for 'withUrlRenderer'.------ @since 1.2.0-giveUrlRenderer :: MonadHandler m- => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)- -> m output-giveUrlRenderer = withUrlRenderer-{-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-}---- | Provide a URL rendering function to the given function and return the--- result. Useful for processing Shakespearean templates.------ @since 1.2.20-withUrlRenderer :: MonadHandler m- => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)- -> m output-withUrlRenderer f = do- render <- getUrlRenderParams- return $ f render---- | Get the request\'s 'W.Request' value.-waiRequest :: MonadHandler m => m W.Request-waiRequest = reqWaiRequest <$> getRequest--getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)- => m (message -> Text)-getMessageRender = do- env <- askHandlerEnv- l <- languages- return $ renderMessage (rheSite env) l---- | Use a per-request cache to avoid performing the same action multiple times.--- Values are stored by their type, the result of typeOf from Typeable.--- Therefore, you should use different newtype wrappers at each cache site.------ For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.--- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.------ See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>------ @since 1.2.0-cached :: (MonadHandler m, Typeable a)- => m a- -> m a-cached action = do- cache <- ghsCache <$> get- eres <- Cache.cached cache action- case eres of- Right res -> return res- Left (newCache, res) -> do- gs <- get- let merged = newCache `HM.union` ghsCache gs- put $ gs { ghsCache = merged }- return res---- | Retrieves a value from the cache used by 'cached'.------ @since 1.6.10-cacheGet :: (MonadHandler m, Typeable a)- => m (Maybe a)-cacheGet = do- cache <- ghsCache <$> get- pure $ Cache.cacheGet cache---- | Sets a value in the cache used by 'cached'.------ @since 1.6.10-cacheSet :: (MonadHandler m, Typeable a)- => a- -> m ()-cacheSet value = do- gs <- get- let cache = ghsCache gs- newCache = Cache.cacheSet value cache- put $ gs { ghsCache = newCache }---- | a per-request cache. just like 'cached'.--- 'cached' can only cache a single value per type.--- 'cachedBy' stores multiple values per type by usage of a ByteString key------ 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user--- 'cachedBy' is required if the action has parameters and can return multiple values per type.--- You can turn those parameters into a ByteString cache key.--- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.------ @since 1.4.0-cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a-cachedBy k action = do- cache <- ghsCacheBy <$> get- eres <- Cache.cachedBy cache k action- case eres of- Right res -> return res- Left (newCache, res) -> do- gs <- get- let merged = newCache `HM.union` ghsCacheBy gs- put $ gs { ghsCacheBy = merged }- return res---- | Retrieves a value from the cache used by 'cachedBy'.------ @since 1.6.10-cacheByGet :: (MonadHandler m, Typeable a)- => S.ByteString- -> m (Maybe a)-cacheByGet key = do- cache <- ghsCacheBy <$> get- pure $ Cache.cacheByGet key cache---- | Sets a value in the cache used by 'cachedBy'.------ @since 1.6.10-cacheBySet :: (MonadHandler m, Typeable a)- => S.ByteString- -> a- -> m ()-cacheBySet key value = do- gs <- get- let cache = ghsCacheBy gs- newCache = Cache.cacheBySet key value cache- put $ gs { ghsCacheBy = newCache }---- | Get the list of supported languages supplied by the user.------ Languages are determined based on the following (in descending order--- of preference):------ * The _LANG user session variable.------ * The _LANG get parameter.------ * The _LANG cookie.------ * Accept-Language HTTP header.------ Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.--- If a matching language is not found the default language will be used.------ This is handled by parseWaiRequest (not exposed).-languages :: MonadHandler m => m [Text]-languages = do- mlang <- lookupSession langKey- langs <- reqLangs <$> getRequest- return $ maybe id (:) mlang langs--lookup' :: Eq a => a -> [(a, b)] -> [b]-lookup' a = map snd . filter (\x -> a == fst x)---- | Lookup a request header.------ @since 1.2.2-lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)-lookupHeader = fmap listToMaybe . lookupHeaders---- | Lookup a request header.------ @since 1.2.2-lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]-lookupHeaders key = do- req <- waiRequest- return $ lookup' key $ W.requestHeaders req---- | Lookup basic authentication data from __Authorization__ header of--- request. Returns user name and password------ @since 1.4.9-lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))-lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")- where- getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)- <$> extractBasicAuth bs---- | Lookup bearer authentication datafrom __Authorization__ header of--- request. Returns bearer token value------ @since 1.4.9-lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)-lookupBearerAuth = fmap (>>= getBR)- (lookupHeader "Authorization")- where- getBR bs = decodeUtf8With lenientDecode- <$> extractBearerAuth bs----- | Lookup for GET parameters.-lookupGetParams :: MonadHandler m => Text -> m [Text]-lookupGetParams pn = do- rr <- getRequest- return $ lookup' pn $ reqGetParams rr---- | Lookup for GET parameters.-lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)-lookupGetParam = fmap listToMaybe . lookupGetParams---- | Lookup for POST parameters.-lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]-lookupPostParams pn = do- (pp, _) <- runRequestBody- return $ lookup' pn pp--lookupPostParam :: (MonadResource m, MonadHandler m)- => Text- -> m (Maybe Text)-lookupPostParam = fmap listToMaybe . lookupPostParams---- | Lookup for POSTed files.-lookupFile :: MonadHandler m- => Text- -> m (Maybe FileInfo)-lookupFile = fmap listToMaybe . lookupFiles---- | Lookup for POSTed files.-lookupFiles :: MonadHandler m- => Text- -> m [FileInfo]-lookupFiles pn = do- (_, files) <- runRequestBody- return $ lookup' pn files---- | Lookup for cookie data.-lookupCookie :: MonadHandler m => Text -> m (Maybe Text)-lookupCookie = fmap listToMaybe . lookupCookies---- | Lookup for cookie data.-lookupCookies :: MonadHandler m => Text -> m [Text]-lookupCookies pn = do- rr <- getRequest- return $ lookup' pn $ reqCookies rr---- $representations------ HTTP allows content negotation to determine what /representation/ of data--- you would like to use. The most common example of this is providing both a--- user-facing HTML page and an API facing JSON response from the same URL. The--- means of achieving this is the Accept HTTP header, which provides a list of--- content types the client will accept, sorted by preference.------ By using 'selectRep' and 'provideRep', you can provide a number of different--- representations, e.g.:------ > selectRep $ do--- > provideRep produceHtmlOutput--- > provideRep produceJsonOutput------ The first provided representation will be used if no matches are found.---- | Select a representation to send to the client based on the representations--- provided inside this do-block. Should be used together with 'provideRep'.------ @since 1.2.0-selectRep :: MonadHandler m- => Writer.Writer (Endo [ProvidedRep m]) ()- -> m TypedContent-selectRep w = do- -- the content types are already sorted by q values- -- which have been stripped- cts <- fmap reqAccept getRequest-- case mapMaybe tryAccept cts of- [] ->- case reps of- [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)- rep:_ -> returnRep rep- rep:_ -> returnRep rep- where- returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent-- reps = appEndo (Writer.execWriter w) []-- repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList- [ (k, v)- , (noSpace k, v)- , (simpleContentType k, v)- ]) reps-- -- match on the type for sub-type wildcards.- -- If the accept is text/ * it should match a provided text/html- mainTypeMap = Map.fromList $ reverse $ map- (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps-- tryAccept ct =- if subType == "*"- then if mainType == "*"- then listToMaybe reps- else Map.lookup mainType mainTypeMap- else lookupAccept ct- where- (mainType, subType) = contentTypeTypes ct-- lookupAccept ct = Map.lookup ct repMap <|>- Map.lookup (noSpace ct) repMap <|>- Map.lookup (simpleContentType ct) repMap-- -- Mime types such as "text/html; charset=foo" get converted to- -- "text/html;charset=foo"- noSpace = S8.filter (/= ' ')---- | Internal representation of a single provided representation.------ @since 1.2.0-data ProvidedRep m = ProvidedRep !ContentType !(m Content)---- | Provide a single representation to be used, based on the request of the--- client. Should be used together with 'selectRep'.------ @since 1.2.0-provideRep :: (Monad m, HasContentType a)- => m a- -> Writer.Writer (Endo [ProvidedRep m]) ()-provideRep handler = provideRepType (getContentType handler) handler---- | Same as 'provideRep', but instead of determining the content type from the--- type of the value itself, you provide the content type separately. This can--- be a convenience instead of creating newtype wrappers for uncommonly used--- content types.------ > provideRepType "application/x-special-format" "This is the content"------ @since 1.2.0-provideRepType :: (Monad m, ToContent a)- => ContentType- -> m a- -> Writer.Writer (Endo [ProvidedRep m]) ()-provideRepType ct handler =- Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):)---- | Stream in the raw request body without any parsing.------ @since 1.2.0-rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()-rawRequestBody = do- req <- lift waiRequest- let loop = do- bs <- liftIO $ W.requestBody req- unless (S.null bs) $ do- yield bs- loop- loop---- | Stream the data from the file. Since Yesod 1.2, this has been generalized--- to work in any @MonadResource@.-fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()-fileSource = transPipe liftResourceT . fileSourceRaw---- | Extract a strict `ByteString` body from a `FileInfo`.------ This function will block while reading the file.------ > do--- > fileByteString <- fileSourceByteString fileInfo------ @since 1.6.5-fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString-fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy))---- | Provide a pure value for the response body.------ > respond ct = return . TypedContent ct . toContent------ @since 1.2.0-respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent-respond ct = return . TypedContent ct . toContent---- | Use a @Source@ for the response body.------ Note that, for ease of use, the underlying monad is a @HandlerT@. This--- implies that you can run any @HandlerT@ action. However, since a streaming--- response occurs after the response headers have already been sent, some--- actions make no sense here. For example: short-circuit responses, setting--- headers, changing status codes, etc.------ @since 1.2.0-respondSource :: ContentType- -> ConduitT () (Flush Builder) (HandlerFor site) ()- -> HandlerFor site TypedContent-respondSource ctype src = HandlerFor $ \hd ->- -- Note that this implementation relies on the fact that the ResourceT- -- environment provided by the server is the same one used in HandlerT.- -- This is a safe assumption assuming the HandlerT is run correctly.- return $ TypedContent ctype $ ContentSource- $ transPipe (lift . flip unHandlerFor hd) src---- | In a streaming response, send a single chunk of data. This function works--- on most datatypes, such as @ByteString@ and @Html@.------ @since 1.2.0-sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()-sendChunk = yield . toFlushBuilder---- | In a streaming response, send a flush command, causing all buffered data--- to be immediately sent to the client.------ @since 1.2.0-sendFlush :: Monad m => ConduitT i (Flush Builder) m ()-sendFlush = yield Flush---- | Type-specialized version of 'sendChunk' for strict @ByteString@s.------ @since 1.2.0-sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()-sendChunkBS = sendChunk---- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.------ @since 1.2.0-sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()-sendChunkLBS = sendChunk---- | Type-specialized version of 'sendChunk' for strict @Text@s.------ @since 1.2.0-sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()-sendChunkText = sendChunk---- | Type-specialized version of 'sendChunk' for lazy @Text@s.------ @since 1.2.0-sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()-sendChunkLazyText = sendChunk---- | Type-specialized version of 'sendChunk' for @Html@s.------ @since 1.2.0-sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()-sendChunkHtml = sendChunk---- $ajaxCSRFOverview--- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.--- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.--- This is known as a <https://en.wikipedia.org/wiki/Cross-site_request_forgery Cross Site Request Forgery> (CSRF) attack.------ To combat this attack, you need a way to verify that the request is valid.--- This is achieved by generating a random string ("token"), storing it in your encrypted session so that the server can look it up (see 'reqToken'), and adding the token to HTTP requests made to your server.--- When a request comes in, the token in the request is compared to the one from the encrypted session. If they match, you can be sure the request is valid.------ Yesod implements this behavior in two ways:------ (1) The yesod-form package <http://www.yesodweb.com/book/forms#forms_running_forms stores the CSRF token in a hidden field> in the form, then validates it with functions like 'Yesod.Form.Functions.runFormPost'.------ (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session.------ The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam').------ The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware.------ === Opting-out of CSRF checking for specific routes------ (Note: this code is generic to opting out of any Yesod middleware)------ @--- 'yesodMiddleware' app = do--- maybeRoute <- 'getCurrentRoute'--- let dontCheckCsrf = case maybeRoute of--- Just HomeR -> True -- Don't check HomeR--- Nothing -> True -- Don't check for 404s--- _ -> False -- Check other routes------ 'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app--- @------ This can also be implemented using the 'csrfCheckMiddleware' function.---- | The default cookie name for the CSRF token ("XSRF-TOKEN").------ @since 1.4.14-defaultCsrfCookieName :: S8.ByteString-defaultCsrfCookieName = "XSRF-TOKEN"---- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name.------ The cookie's path is set to @/@, making it valid for your whole website.------ @since 1.4.14-setCsrfCookie :: MonadHandler m => m ()-setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie- { setCookieName = defaultCsrfCookieName- , setCookiePath = Just "/"- }---- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.------ Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.------ @since 1.4.14-setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()-setCsrfCookieWithCookie cookie = do- mCsrfToken <- reqToken <$> getRequest- Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token })---- | The default header name for the CSRF token ("X-XSRF-TOKEN").------ @since 1.4.14-defaultCsrfHeaderName :: CI S8.ByteString-defaultCsrfHeaderName = "X-XSRF-TOKEN"---- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,--- this function throws a 'PermissionDenied' error.------ @since 1.4.14-checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()-checkCsrfHeaderNamed headerName = do- (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName- unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])---- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.------ @since 1.4.14-hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool-hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName---- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.-hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)-hasValidCsrfHeaderNamed' headerName = do- mCsrfToken <- reqToken <$> getRequest- mXsrfHeader <- lookupHeader headerName-- return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)---- CSRF Parameter checking---- | The default parameter name for the CSRF token ("_token")------ @since 1.4.14-defaultCsrfParamName :: Text-defaultCsrfParamName = "_token"---- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,--- this function throws a 'PermissionDenied' error.------ @since 1.4.14-checkCsrfParamNamed :: MonadHandler m => Text -> m ()-checkCsrfParamNamed paramName = do- (valid, mParam) <- hasValidCsrfParamNamed' paramName- unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])---- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.------ @since 1.4.14-hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool-hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName---- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.-hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)-hasValidCsrfParamNamed' paramName = do- mCsrfToken <- reqToken <$> getRequest- mCsrfParam <- lookupPostParam paramName-- return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)---- | Checks that a valid CSRF token is present in either the request headers or POST parameters.--- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.------ @since 1.4.14-checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)- => CI S8.ByteString -- ^ The header name to lookup the CSRF token- -> Text -- ^ The POST parameter name to lookup the CSRF token- -> m ()-checkCsrfHeaderOrParam headerName paramName = do- (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName- (validParam, mParam) <- hasValidCsrfParamNamed' paramName- unless (validHeader || validParam) $ do- let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam]- $logWarnS "yesod-core" errorMessage- permissionDenied errorMessage--validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool--- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.-validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param-validCsrf Nothing _param = True-validCsrf (Just _token) Nothing = False--data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value- | CSRFParam Text (Maybe Text) -- Key/Value--csrfErrorMessage :: [CSRFExpectation]- -> Text -- ^ Error message-csrfErrorMessage expectedLocations = T.intercalate "\n"- [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."- , "If you're a developer of this site, these tips will help you debug the issue:"- , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."- , "- Check that your HTTP client is persisting cookies between requests, like a browser does."- , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "."- , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations)- ]-- where csrfLocation expected = case expected of- CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)]- CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)]-- formatValue :: Maybe Text -> Text- formatValue maybeText = case maybeText of- Nothing -> "(which is not currently set)"- Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]--getSubYesod :: MonadHandler m => m (SubHandlerSite m)-getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv--getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))-getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv--getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))-getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv
− Yesod/Core/Internal.hs
@@ -1,8 +0,0 @@--- | Exposed mostly for testing. These functions provide an unstable API and--- should not be relied upon.-module Yesod.Core.Internal- ( module X- ) where--import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)-import Yesod.Core.Internal.TH as X (mkYesodGeneral)
− Yesod/Core/Internal/LiteApp.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}-module Yesod.Core.Internal.LiteApp where--#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))-#endif-import Yesod.Routes.Class-import Yesod.Core.Class.Yesod-import Yesod.Core.Class.Dispatch-import Yesod.Core.Types-import Yesod.Core.Content-import Data.Text (Text)-import Web.PathPieces-import Network.Wai-import Yesod.Core.Handler-import Yesod.Core.Internal.Run-import Network.HTTP.Types (Method)-import Data.Maybe (fromMaybe)-import Control.Applicative ((<|>))-import Control.Monad.Trans.Writer--newtype LiteApp = LiteApp- { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)- }--instance Yesod LiteApp--instance YesodDispatch LiteApp where- yesodDispatch yre req =- yesodRunner- (fromMaybe notFound $ f (requestMethod req) (pathInfo req))- yre- (Just $ LiteAppRoute $ pathInfo req)- req- where- LiteApp f = yreSite yre--instance RenderRoute LiteApp where- data Route LiteApp = LiteAppRoute [Text]- deriving (Show, Eq, Read, Ord)- renderRoute (LiteAppRoute x) = (x, [])-instance ParseRoute LiteApp where- parseRoute (x, _) = Just $ LiteAppRoute x--instance Semigroup LiteApp where- LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps--instance Monoid LiteApp where- mempty = LiteApp $ \_ _ -> Nothing-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif--type LiteHandler = HandlerFor LiteApp-type LiteWidget = WidgetFor LiteApp--liteApp :: Writer LiteApp () -> LiteApp-liteApp = execWriter--dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()-dispatchTo handler = tell $ LiteApp $ \_ ps ->- if null ps- then Just $ fmap toTypedContent handler- else Nothing--onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()-onMethod method f = tell $ LiteApp $ \m ps ->- if method == m- then unLiteApp (liteApp f) m ps- else Nothing--onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()-onStatic p0 f = tell $ LiteApp $ \m ps0 ->- case ps0 of- p:ps | p == p0 -> unLiteApp (liteApp f) m ps- _ -> Nothing--withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()-withDynamic f = tell $ LiteApp $ \m ps0 ->- case ps0 of- p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps- _ -> Nothing--withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()-withDynamicMulti f = tell $ LiteApp $ \m ps ->- case fromPathMultiPiece ps of- Nothing -> Nothing- Just v -> unLiteApp (liteApp $ f v) m []
− Yesod/Core/Internal/Request.hs
@@ -1,198 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-module Yesod.Core.Internal.Request- ( parseWaiRequest- , RequestBodyContents- , FileInfo- , fileName- , fileContentType- , fileMove- , mkFileInfoLBS- , mkFileInfoFile- , mkFileInfoSource- , FileUpload (..)- , tooLargeResponse- , tokenKey- , langKey- , textQueryString- -- The below are exported for testing.- , randomString- ) where--import Data.String (IsString)-import Control.Arrow (second)-import qualified Network.Wai.Parse as NWP-import qualified Network.Wai as W-import Web.Cookie (parseCookiesText)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy.Char8 as LS8-import Data.Text (Text, pack)-import Network.HTTP.Types (queryToQueryText, Status (Status))-import Data.Maybe (fromMaybe, catMaybes)-import qualified Data.ByteString.Lazy as L-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, decodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import Conduit-import Data.Word (Word8, Word64)-import Control.Exception (throwIO)-import Control.Monad ((<=<), liftM)-import Yesod.Core.Types-import qualified Data.Map as Map-import Data.IORef-import qualified Data.Vector.Storable as V-import Data.ByteString.Internal (ByteString (PS))-import qualified Data.Word8 as Word8---- | Impose a limit on the size of the request body.-limitRequestBody :: Word64 -> W.Request -> IO W.Request-limitRequestBody maxLen req = do- ref <- newIORef maxLen- return req- { W.requestBody = do- bs <- W.requestBody req- remaining <- readIORef ref- let len = fromIntegral $ S8.length bs- remaining' = remaining - len- if remaining < len- then throwIO $ HCWai $ tooLargeResponse maxLen len- else do- writeIORef ref remaining'- return bs- }--tooLargeResponse :: Word64 -> Word64 -> W.Response-tooLargeResponse maxLen bodyLen = W.responseLBS- (Status 413 "Too Large")- [("Content-Type", "text/plain")]- (L.concat - [ "Request body too large to be processed. The maximum size is "- , (LS8.pack (show maxLen))- , " bytes; your request body was "- , (LS8.pack (show bodyLen))- , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` function on the Yesod typeclass."- ])--parseWaiRequest :: W.Request- -> SessionMap- -> Bool- -> Maybe Word64 -- ^ max body size- -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)-parseWaiRequest env session useToken mmaxBodySize =- -- In most cases, we won't need to generate any random values. Therefore,- -- we split our results: if we need a random generator, return a Right- -- value, otherwise return a Left and avoid the relatively costly generator- -- acquisition.- case etoken of- Left token -> Left $ mkRequest token- Right mkToken -> Right $ mkRequest <=< mkToken- where- mkRequest token' = do- envLimited <- maybe return limitRequestBody mmaxBodySize env- return YesodRequest- { reqGetParams = gets- , reqCookies = cookies- , reqWaiRequest = envLimited- , reqLangs = langs''- , reqToken = token'- , reqSession = if useToken- then Map.delete tokenKey session- else session- , reqAccept = httpAccept env- }- gets = textQueryString env- reqCookie = lookup "Cookie" $ W.requestHeaders env- cookies = maybe [] parseCookiesText reqCookie- acceptLang = lookup "Accept-Language" $ W.requestHeaders env- langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang-- lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k-- -- The language preferences are prioritized as follows:- langs' = catMaybes [ lookup langKey gets -- Query _LANG- , lookup langKey cookies -- Cookie _LANG- , lookupText langKey session -- Session _LANG- ] ++ langs -- Accept-Language(s)-- -- Github issue #195. We want to add an extra two-letter version of any- -- language in the list.- langs'' = addTwoLetters (id, Set.empty) langs'-- -- If sessions are disabled tokens should not be used (any- -- tokenKey present in the session is ignored). If sessions- -- are enabled and a session has no tokenKey a new one is- -- generated.- etoken- | useToken =- case Map.lookup tokenKey session of- -- Already have a token, use it.- Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs- -- Don't have a token, get a random generator and make a new one.- Nothing -> Right $ fmap Just . randomString 10- | otherwise = Left Nothing--textQueryString :: W.Request -> [(Text, Text)]-textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString---- | Get the list of accepted content types from the WAI Request\'s Accept--- header.------ Since 1.2.0-httpAccept :: W.Request -> [ContentType]-httpAccept = NWP.parseHttpAccept- . fromMaybe S8.empty- . lookup "Accept"- . W.requestHeaders--addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]-addTwoLetters (toAdd, exist) [] =- filter (`Set.notMember` exist) $ toAdd []-addTwoLetters (toAdd, exist) (l:ls) =- l : addTwoLetters (toAdd', exist') ls- where- (toAdd', exist')- | T.length l > 2 = (toAdd . (T.take 2 l:), exist)- | otherwise = (toAdd, Set.insert l exist)---- | Generate a random String of alphanumerical characters--- (a-z, A-Z, and 0-9) of the given length using the given--- random number generator.-randomString :: Monad m => Int -> m Int -> m Text-randomString len gen =- liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar- where- asciiChar =- let loop = do- x <- gen- let y = fromIntegral $ x `mod` 64- case () of- ()- | y < 26 -> return $ y + Word8._A- | y < 52 -> return $ y + Word8._a - 26- | y < 62 -> return $ y + Word8._0 - 52- | otherwise -> loop- in loop--fromByteVector :: V.Vector Word8 -> ByteString-fromByteVector v =- PS fptr offset idx- where- (fptr, offset, idx) = V.unsafeToForeignPtr v-{-# INLINE fromByteVector #-}--mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo-mkFileInfoLBS name ct lbs =- FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)--mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo-mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)--mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo-mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)--tokenKey :: IsString a => a-tokenKey = "_TOKEN"--langKey :: IsString a => a-langKey = "_LANG"
− Yesod/Core/Internal/Response.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-module Yesod.Core.Internal.Response where--import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as BL-import Data.CaseInsensitive (CI)-import Network.Wai-import Control.Monad (mplus)-import Control.Monad.Trans.Resource (runInternalState, InternalState)-import Network.Wai.Internal-import Web.Cookie (renderSetCookie)-import Yesod.Core.Content-import Yesod.Core.Types-import qualified Network.HTTP.Types as H-import qualified Data.Text as T-import Control.Exception (SomeException, handle)-import Data.ByteString.Builder (lazyByteString, toLazyByteString)-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import Yesod.Core.Internal.Request (tokenKey)-import Data.Text.Encoding (encodeUtf8)-import Conduit--yarToResponse :: YesodResponse- -> (SessionMap -> IO [Header]) -- ^ save session- -> YesodRequest- -> Request- -> InternalState- -> (Response -> IO ResponseReceived)- -> IO ResponseReceived-yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a-yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse-yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do- extraHeaders <- do- let nsToken = maybe- newSess- (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)- (reqToken yreq)- sessionHeaders <- saveSession nsToken- return $ ("Content-Type", ct) : map headerToPair sessionHeaders- let finalHeaders = extraHeaders ++ map headerToPair hs- finalHeaders' len = ("Content-Length", S8.pack $ show len)- : finalHeaders-- let go (ContentBuilder b mlen) = do- let hs' = maybe finalHeaders finalHeaders' mlen- sendResponse $ ResponseBuilder s hs' b- go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p- go (ContentSource body) = sendResponse $ responseStream s finalHeaders- $ \sendChunk flush -> runConduit $- transPipe (`runInternalState` is) body- .| mapM_C (\mchunk ->- case mchunk of- Flush -> flush- Chunk builder -> sendChunk builder)- go (ContentDontEvaluate c') = go c'- go c- where- s- | s' == defaultStatus = H.status200- | otherwise = s'---- | Indicates that the user provided no specific status code to be used, and--- therefore the default status code should be used. For normal responses, this--- would be a 200 response, whereas for error responses this would be an--- appropriate status code.------ For more information on motivation for this, see:------ https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ------ Since 1.2.3.1-defaultStatus :: H.Status-defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"---- | Convert Header to a key/value pair.-headerToPair :: Header- -> (CI ByteString, ByteString)-headerToPair (AddCookie sc) =- ("Set-Cookie", BL.toStrict $ toLazyByteString $ 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) = (key, value)--evaluateContent :: Content -> IO (Either ErrorResponse Content)-evaluateContent (ContentBuilder b mlen) = handle f $ do- let lbs = toLazyByteString b- len = L.length lbs- mlen' = mlen `mplus` Just (fromIntegral len)- len `seq` return (Right $ ContentBuilder (lazyByteString 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 NotAuthenticated = H.status401-getStatus (PermissionDenied _) = H.status403-getStatus (BadMethod _) = H.status405
− Yesod/Core/Internal/Run.hs
@@ -1,368 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Core.Internal.Run where---import Yesod.Core.Internal.Response-import Data.ByteString.Builder (toLazyByteString)-import qualified Data.ByteString.Lazy as BL-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Logger (LogLevel (LevelError), LogSource,- liftLoc)-import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.IORef as I-import qualified Data.Map as Map-import Data.Maybe (isJust, fromMaybe)-import Data.Monoid (appEndo)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Language.Haskell.TH.Syntax (Loc, qLocation)-import qualified Network.HTTP.Types as H-import Network.Wai-import Network.Wai.Internal-import System.Log.FastLogger (LogStr, toLogStr)-import Yesod.Core.Content-import Yesod.Core.Class.Yesod-import Yesod.Core.Types-import Yesod.Core.Internal.Request (parseWaiRequest,- tooLargeResponse)-import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)-import Yesod.Routes.Class (Route, renderRoute)-import Control.DeepSeq (($!!), NFData)-import UnliftIO.Exception---- | Convert a synchronous exception into an ErrorResponse-toErrorHandler :: SomeException -> IO ErrorResponse-toErrorHandler e0 = handleAny errFromShow $- case fromException e0 of- Just (HCError x) -> evaluate $!! x- _ -> errFromShow e0---- | Generate an @ErrorResponse@ based on the shown version of the exception-errFromShow :: SomeException -> IO ErrorResponse-errFromShow x = do- text <- evaluate (T.pack $ show x) `catchAny` \_ ->- return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")- return $ InternalError text---- | Do a basic run of a handler, getting some contents and the final--- @GHState@. The @GHState@ unfortunately may contain some impure--- exceptions, but all other synchronous exceptions will be caught and--- represented by the @HandlerContents@.-basicRunHandler :: ToTypedContent c- => RunHandlerEnv site site- -> HandlerFor site c- -> YesodRequest- -> InternalState- -> IO (GHState, HandlerContents)-basicRunHandler rhe handler yreq resState = do- -- Create a mutable ref to hold the state. We use mutable refs so- -- that the updates will survive runtime exceptions.- istate <- I.newIORef defState-- -- Run the handler itself, capturing any runtime exceptions and- -- converting them into a @HandlerContents@- contents' <- catchAny- (do- res <- unHandlerFor handler (hd istate)- tc <- evaluate (toTypedContent res)- -- Success! Wrap it up in an @HCContent@- return (HCContent defaultStatus tc))- (\e ->- case fromException e of- Just e' -> return e'- Nothing -> HCError <$> toErrorHandler e)-- -- Get the raw state and return- state <- I.readIORef istate- return (state, contents')- where- defState = GHState- { ghsSession = reqSession yreq- , ghsRBC = Nothing- , ghsIdent = 1- , ghsCache = mempty- , ghsCacheBy = mempty- , ghsHeaders = mempty- }- hd istate = HandlerData- { handlerRequest = yreq- , handlerEnv = rhe- , handlerState = istate- , handlerResource = resState- }---- | Convert an @ErrorResponse@ into a @YesodResponse@-handleError :: RunHandlerEnv sub site- -> YesodRequest- -> InternalState- -> Map.Map Text S8.ByteString- -> [Header]- -> ErrorResponse- -> IO YesodResponse-handleError rhe yreq resState finalSession headers e0 = do- -- Find any evil hidden impure exceptions- e <- (evaluate $!! e0) `catchAny` errFromShow-- -- Generate a response, leveraging the updated session and- -- response headers- flip runInternalState resState $ do- yar <- rheOnError rhe e yreq- { reqSession = finalSession- }- case yar of- YRPlain status' hs ct c sess ->- let hs' = headers ++ hs- status- | status' == defaultStatus = getStatus e- | otherwise = status'- in return $ YRPlain status hs' ct c sess- YRWai _ -> return yar- YRWaiApp _ -> return yar---- | Convert a @HandlerContents@ into a @YesodResponse@-handleContents :: (ErrorResponse -> IO YesodResponse)- -> Map.Map Text S8.ByteString- -> [Header]- -> HandlerContents- -> IO YesodResponse-handleContents handleError' finalSession headers contents =- case contents of- HCContent status (TypedContent ct c) -> do- -- Check for impure exceptions hiding in the contents- ec' <- evaluateContent c- case ec' of- Left e -> handleError' e- Right c' -> return $ YRPlain status headers ct c' finalSession- HCError e -> handleError' e- HCRedirect status loc -> do- let disable_caching x =- Header "Cache-Control" "no-cache, must-revalidate"- : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"- : x- hs = (if status /= H.movedPermanently301 then disable_caching else id)- $ Header "Location" (encodeUtf8 loc) : headers- return $ YRPlain- status hs typePlain emptyContent- finalSession- HCSendFile ct fp p -> return $ YRPlain- H.status200- headers- ct- (ContentFile fp p)- finalSession- HCCreated loc -> return $ YRPlain- H.status201- (Header "Location" (encodeUtf8 loc) : headers)- typePlain- emptyContent- finalSession- HCWai r -> return $ YRWai r- HCWaiApp a -> return $ YRWaiApp a---- | Evaluate the given value. If an exception is thrown, use it to--- replace the provided contents and then return @mempty@ in place of the--- evaluated value.-evalFallback :: (Monoid w, NFData w)- => HandlerContents- -> w- -> IO (w, HandlerContents)-evalFallback contents val = catchAny- (fmap (, contents) (evaluate $!! val))- (fmap ((mempty, ) . HCError) . toErrorHandler)---- | Function used internally by Yesod in the process of converting a--- 'HandlerT' into an 'Application'. Should not be needed by users.-runHandler :: ToTypedContent c- => RunHandlerEnv site site- -> HandlerFor site c- -> YesodApp-runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do- -- Get the raw state and original contents- (state, contents0) <- basicRunHandler rhe handler yreq resState-- -- Evaluate the unfortunately-lazy session and headers,- -- propagating exceptions into the contents- (finalSession, contents1) <- evalFallback contents0 (ghsSession state)- (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])- contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)-- -- Convert the HandlerContents into the final YesodResponse- handleContents- (handleError rhe yreq resState finalSession headers)- finalSession- headers- contents3--safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())- -> ErrorResponse- -> YesodApp-safeEh log' er req = do- liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError- $ toLogStr $ "Error handler errored out: " ++ show er- return $ YRPlain- H.status500- []- typePlain- (toContent ("Internal Server Error" :: S.ByteString))- (reqSession req)---- | Run a 'HandlerT' 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 'HandlerT'--- 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--- @HandlerT@. The only useful information the @HandlerT@ 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--- @HandlerT@ is completely ignored, including changes to the--- session, cookies or headers. We only return you the--- @HandlerT@'s return value.-runFakeHandler :: (Yesod site, MonadIO m) =>- SessionMap- -> (site -> Logger)- -> site- -> HandlerFor site a- -> m (Either ErrorResponse a)-runFakeHandler fakeSessionMap logger site handler = liftIO $ do- ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")- maxExpires <- getCurrentMaxExpiresRFC1123- let handler' = liftIO . I.writeIORef ret . Right =<< handler- let yapp = runHandler- RunHandlerEnv- { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest- , rheRoute = Nothing- , rheRouteToMaster = id- , rheChild = site- , rheSite = site- , rheUpload = fileUpload site- , rheLog = messageLoggerSource site $ logger site- , rheOnError = errHandler- , rheMaxExpires = maxExpires- }- handler'- errHandler err req = do- liftIO $ I.writeIORef ret (Left err)- return $ YRPlain- H.status500- []- typePlain- (toContent ("runFakeHandler: errHandler" :: S8.ByteString))- (reqSession req)- fakeWaiRequest = Request- { requestMethod = "POST"- , httpVersion = H.http11- , rawPathInfo = "/runFakeHandler/pathInfo"- , rawQueryString = ""- , requestHeaderHost = Nothing- , requestHeaders = []- , isSecure = False- , remoteHost = error "runFakeHandler-remoteHost"- , pathInfo = ["runFakeHandler", "pathInfo"]- , queryString = []- , requestBody = return mempty- , vault = mempty- , requestBodyLength = KnownLength 0- , requestHeaderRange = Nothing- , requestHeaderReferer = Nothing- , requestHeaderUserAgent = Nothing- }- fakeRequest =- YesodRequest- { reqGetParams = []- , reqCookies = []- , reqWaiRequest = fakeWaiRequest- , reqLangs = []- , reqToken = Just "NaN" -- not a nonce =)- , reqAccept = []- , reqSession = fakeSessionMap- }- _ <- runResourceT $ yapp fakeRequest- I.readIORef ret--yesodRunner :: (ToTypedContent res, Yesod site)- => HandlerFor site res- -> YesodRunnerEnv site- -> Maybe (Route site)- -> Application-yesodRunner handler' YesodRunnerEnv {..} route req sendResponse- | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse (tooLargeResponse maxLen len)- | otherwise = do- let dontSaveSession _ = return []- (session, saveSession) <- liftIO $- maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend- maxExpires <- yreGetMaxExpires- let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen- let yreq =- case mkYesodReq of- Left yreq' -> yreq'- Right needGen -> needGen yreGen- let ra = resolveApproot yreSite req- let log' = messageLoggerSource yreSite yreLogger- -- We set up two environments: the first one has a "safe" error handler- -- which will never throw an exception. The second one uses the- -- user-provided errorHandler function. If that errorHandler function- -- errors out, it will use the safeEh below to recover.- rheSafe = RunHandlerEnv- { rheRender = yesodRender yreSite ra- , rheRoute = route- , rheRouteToMaster = id- , rheChild = yreSite- , rheSite = yreSite- , rheUpload = fileUpload yreSite- , rheLog = log'- , rheOnError = safeEh log'- , rheMaxExpires = maxExpires- }- rhe = rheSafe- { rheOnError = runHandler rheSafe . errorHandler- }-- yesodWithInternalState yreSite route $ \is -> do- yreq' <- yreq- yar <- runInternalState (runHandler rhe handler yreq') is- yarToResponse yar saveSession yreq' req is sendResponse- where- mmaxLen = maximumContentLength yreSite route- handler = yesodMiddleware handler'--yesodRender :: Yesod y- => y- -> ResolvedApproot- -> Route y- -> [(Text, Text)] -- ^ url query string- -> Text-yesodRender y ar url params =- decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $- fromMaybe- (joinPath y ar ps- $ params ++ params')- (urlParamRenderOverride y url params)- where- (ps, params') = renderRoute url--resolveApproot :: Yesod master => master -> Request -> ResolvedApproot-resolveApproot master req =- case approot of- ApprootRelative -> ""- ApprootStatic t -> t- ApprootMaster f -> f master- ApprootRequest f -> f master req
− Yesod/Core/Internal/Session.hs
@@ -1,70 +0,0 @@-module Yesod.Core.Internal.Session- ( encodeClientSession- , decodeClientSession- , clientSessionDateCacher- , ClientSessionDateCache(..)- , SaveSession- , SessionBackend(..)- ) where--import qualified Web.ClientSession as CS-import Data.Serialize-import Data.Time-import Data.ByteString (ByteString)-import Control.Monad (guard)-import Yesod.Core.Types-import Yesod.Core.Internal.Util-import Control.AutoUpdate--encodeClientSession :: CS.Key- -> CS.IV- -> ClientSessionDateCache -- ^ expire time- -> ByteString -- ^ remote host- -> SessionMap -- ^ session- -> ByteString -- ^ cookie value-encodeClientSession key iv date rhost session' =- CS.encrypt key iv $ encode $ SessionCookie expires rhost session'- where expires = Right (csdcExpiresSerialized date)--decodeClientSession :: CS.Key- -> ClientSessionDateCache -- ^ current time- -> ByteString -- ^ remote host field- -> ByteString -- ^ cookie value- -> Maybe SessionMap-decodeClientSession key date rhost encrypted = do- decrypted <- CS.decrypt key encrypted- SessionCookie (Left expire) rhost' session' <-- either (const Nothing) Just $ decode decrypted- guard $ expire > csdcNow date- guard $ rhost' == rhost- return session'------------------------------------------------------------------------------ Originally copied from Kazu's date-cache, but now using mkAutoUpdate.------ The cached date is updated every 10s, we don't need second--- resolution for session expiration times.------ The second component of the returned tuple used to be an action that--- killed the updater thread, but is now a no-op that's just there--- to preserve the type.--clientSessionDateCacher ::- NominalDiffTime -- ^ Inactive session validity.- -> IO (IO ClientSessionDateCache, IO ())-clientSessionDateCacher validity = do- getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings- { updateAction = getUpdated- , updateFreq = 10000000 -- 10s- }-- return (getClientSessionDateCache, return ())- where- getUpdated = do- now <- getCurrentTime- let expires = validity `addUTCTime` now- expiresS = runPut (putTime expires)- return $! ClientSessionDateCache now expires expiresS
− Yesod/Core/Internal/TH.hs
@@ -1,220 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Core.Internal.TH where--import Prelude hiding (exp)-import Yesod.Core.Handler--import Language.Haskell.TH hiding (cxt, instanceD)-import Language.Haskell.TH.Syntax--import qualified Network.Wai as W--import Data.ByteString.Lazy.Char8 ()-import Data.List (foldl')-import Control.Monad (replicateM, void)-import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)-import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)--import Yesod.Routes.TH-import Yesod.Routes.Parse-import Yesod.Core.Types-import Yesod.Core.Class.Dispatch-import Yesod.Core.Internal.Run---- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.--- Use 'parseRoutes' to create the 'Resource's.------ Contexts and type variables in the name of the datatype are parsed. --- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.-mkYesod :: String -- ^ name of the argument datatype- -> [ResourceTree String]- -> Q [Dec]-mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return--{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}--- | Similar to 'mkYesod', except contexts and type variables are not parsed. --- Instead, they are explicitly provided. --- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.-mkYesodWith :: [[String]] -- ^ list of contexts- -> String -- ^ name of the argument datatype- -> [String] -- ^ list of type variables- -> [ResourceTree String]- -> Q [Dec]-mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return---- | Sometimes, you will want to declare your routes in one file and define--- your handlers elsewhere. For example, this is the only way to break up a--- monolithic file into smaller parts. Use this function, paired with--- 'mkYesodDispatch', to do just that.-mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name resS = fst <$> mkYesodWithParser name False return resS--mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS---- | Parses contexts and type arguments out of name before generating TH.-mkYesodWithParser :: String -- ^ foundation type- -> Bool -- ^ is this a subsite- -> (Exp -> Q Exp) -- ^ unwrap handler- -> [ResourceTree String]- -> Q([Dec],[Dec])-mkYesodWithParser name isSub f resS = do- let (name', rest, cxt) = case parse parseName "" name of- Left err -> error $ show err- Right a -> a- mkYesodGeneral cxt name' rest isSub f resS-- where- parseName = do- cxt <- option [] parseContext- name' <- parseWord- args <- many parseWord- spaces- eof- return ( name', args, cxt)-- parseWord = do- spaces- many1 alphaNum-- parseContext = try $ do- cxts <- parseParen parseContexts- spaces- _ <- string "=>"- return cxts-- parseParen p = do- spaces- _ <- char '('- r <- p- spaces- _ <- char ')'- return r-- parseContexts = - sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())---- | See 'mkYesodData'.-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodWithParser name False return---- | Get the Handler and Widget type synonyms for the given site.-masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?-masterTypeSyns vs site =- [ TySynD (mkName "Handler") (fmap PlainTV vs)- $ ConT ''HandlerFor `AppT` site- , TySynD (mkName "Widget") (fmap PlainTV vs)- $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()- ]--mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.- -> String -- ^ foundation type- -> [String] -- ^ arguments for the type- -> Bool -- ^ is this a subsite- -> (Exp -> Q Exp) -- ^ unwrap handler- -> [ResourceTree String]- -> Q([Dec],[Dec])-mkYesodGeneral appCxt' namestr mtys isSub f resS = do- let appCxt = fmap (\(c:rest) -> - foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest- ) appCxt'- mname <- lookupTypeName namestr- arity <- case mname of- Just name -> do- info <- reify name- return $- case info of- TyConI dec ->- case dec of- DataD _ _ vs _ _ _ -> length vs- NewtypeD _ _ vs _ _ _ -> length vs- TySynD _ vs _ -> length vs- _ -> 0- _ -> 0- _ -> return 0- let name = mkName namestr- -- Generate as many variable names as the arity indicates- vns <- replicateM (arity - length mtys) $ newName "t"- -- Base type (site type with variables)- let argtypes = fmap nameToType mtys ++ fmap VarT vns- site = foldl' AppT (ConT name) argtypes- res = map (fmap (parseType . dropBracket)) resS- renderRouteDec <- mkRenderRouteInstance appCxt site res- routeAttrsDec <- mkRouteAttrsInstance appCxt site res- dispatchDec <- mkDispatchInstance site appCxt f res- parseRoute <- mkParseRouteInstance appCxt site res- let rname = mkName $ "resources" ++ namestr- eres <- lift resS- let resourcesDec =- [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)- , FunD rname [Clause [] (NormalB eres) []]- ]- let dataDec = concat- [ [parseRoute]- , renderRouteDec- , [routeAttrsDec]- , resourcesDec- , if isSub then [] else masterTypeSyns vns site- ]- return (dataDec, dispatchDec)--mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b-mkMDS f rh = MkDispatchSettings- { mdsRunHandler = rh- , mdsSubDispatcher =- [|\parentRunner getSub toParent env -> yesodSubDispatch- YesodSubRunnerEnv- { ysreParentRunner = parentRunner- , ysreGetSub = getSub- , ysreToParentRoute = toParent- , ysreParentEnv = env- }- |]- , mdsGetPathInfo = [|W.pathInfo|]- , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]- , mdsMethod = [|W.requestMethod|]- , mds404 = [|void notFound|]- , mds405 = [|void badMethod|]- , mdsGetHandler = defaultGetHandler- , mdsUnwrapper = f- }---- | If the generation of @'YesodDispatch'@ instance require finer--- control of the types, contexts etc. using this combinator. You will--- hardly need this generality. However, in certain situations, like--- when writing library/plugin for yesod, this combinator becomes--- handy.-mkDispatchInstance :: Type -- ^ The master site type- -> Cxt -- ^ Context of the instance- -> (Exp -> Q Exp) -- ^ Unwrap handler- -> [ResourceTree c] -- ^ The resource- -> DecsQ-mkDispatchInstance master cxt f res = do- clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res- let thisDispatch = FunD 'yesodDispatch [clause']- return [instanceD cxt yDispatch [thisDispatch]]- where- yDispatch = ConT ''YesodDispatch `AppT` master--mkYesodSubDispatch :: [ResourceTree a] -> Q Exp-mkYesodSubDispatch res = do- clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res- inner <- newName "inner"- let innerFun = FunD inner [clause']- helper <- newName "helper"- let fun = FunD helper- [ Clause- []- (NormalB $ VarE inner)- [innerFun]- ]- return $ LetE [fun] (VarE helper)--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing
− Yesod/Core/Internal/Util.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE CPP #-}-module Yesod.Core.Internal.Util- ( putTime- , getTime- , formatW3- , formatRFC1123- , formatRFC822- , getCurrentMaxExpiresRFC1123- ) where--import Data.Int (Int64)-import Data.Serialize (Get, Put, Serialize (..))-import qualified Data.Text as T-import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),- DiffTime, UTCTime (..), formatTime,- getCurrentTime, addUTCTime, defaultTimeLocale)--putTime :: UTCTime -> Put-putTime (UTCTime d t) =- let d' = fromInteger $ toModifiedJulianDay d- t' = fromIntegral $ fromEnum (t / diffTimeScale)- in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')--getTime :: Get UTCTime-getTime = do- val <- get- let (d, t) = val `divMod` posixDayLength_int64- d' = ModifiedJulianDay $! fromIntegral d- t' = fromIntegral t- d' `seq` t' `seq` return (UTCTime d' t')--posixDayLength_int64 :: Int64-posixDayLength_int64 = 86400--diffTimeScale :: DiffTime-diffTimeScale = 1e12---- | Format a 'UTCTime' in W3 format.-formatW3 :: UTCTime -> T.Text-formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"---- | Format as per RFC 1123.-formatRFC1123 :: UTCTime -> T.Text-formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"---- | Format as per RFC 822.-formatRFC822 :: UTCTime -> T.Text-formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"--{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry-date on a resource that never expires. See RFC 2616 section 14.21 for details.--}-getCurrentMaxExpiresRFC1123 :: IO T.Text-getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
− Yesod/Core/Json.hs
@@ -1,220 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Yesod.Core.Json- ( -- * Convert from a JSON value- defaultLayoutJson- , jsonToRepJson- , returnJson- , returnJsonEncoding- , provideJson-- -- * Convert to a JSON value- , parseCheckJsonBody- , parseInsecureJsonBody- , requireCheckJsonBody- , requireInsecureJsonBody- -- ** Deprecated JSON conversion- , parseJsonBody- , parseJsonBody_- , requireJsonBody-- -- * Produce JSON values- , J.Value (..)- , J.ToJSON (..)- , J.FromJSON (..)- , array- , object- , (.=)- , (J..:)-- -- * Convenience functions- , jsonOrRedirect- , jsonEncodingOrRedirect- , acceptsJson- ) where--import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)-import Control.Monad.Trans.Writer (Writer)-import Data.Monoid (Endo)-import Yesod.Core.Content (TypedContent)-import Yesod.Core.Types (reqAccept)-import Yesod.Core.Class.Yesod (defaultLayout, Yesod)-import Yesod.Core.Class.Handler-import Yesod.Core.Widget (WidgetFor)-import Yesod.Routes.Class-import qualified Data.Aeson as J-import qualified Data.Aeson.Parser as JP-import Data.Aeson ((.=), object)-import Data.Conduit.Attoparsec (sinkParser)-import Data.Text (pack)-import qualified Data.Vector as V-import Data.Conduit-import Data.Conduit.Lift-import qualified Data.ByteString.Char8 as B8-import Data.Maybe (listToMaybe)-import Control.Monad (liftM)---- | Provide both an HTML and JSON representation for a piece of--- data, using the default layout for the HTML output--- ('defaultLayout').------ @since 0.3.0-defaultLayoutJson :: (Yesod site, J.ToJSON a)- => WidgetFor site () -- ^ HTML- -> HandlerFor site a -- ^ JSON- -> HandlerFor site TypedContent-defaultLayoutJson w json = selectRep $ do- provideRep $ defaultLayout w- provideRep $ fmap J.toEncoding json---- | Wraps a data type in a 'RepJson'. The data type must--- support conversion to JSON via 'J.ToJSON'.------ @since 0.3.0-jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value-jsonToRepJson = return . J.toJSON-{-# DEPRECATED jsonToRepJson "Use returnJson instead" #-}---- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function.------ @since 1.2.1-returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value-returnJson = return . J.toJSON---- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.------ @since 1.4.21-returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding-returnJsonEncoding = return . J.toEncoding---- | Provide a JSON representation for usage with 'selectReps', using aeson\'s--- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.------ @since 1.2.1-provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()-provideJson = provideRep . return . J.toEncoding---- | Same as 'parseInsecureJsonBody'------ @since 0.3.0-parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)-parseJsonBody = parseInsecureJsonBody-{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}---- | Same as 'parseCheckJsonBody', but does not check that the mime type--- indicates JSON content.------ Note: This function is vulnerable to CSRF attacks.------ @since 1.6.11-parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)-parseInsecureJsonBody = do- eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')- return $ case eValue of- Left e -> J.Error $ show e- Right value -> J.fromJSON value---- | Parse the request body to a data type as a JSON value. The--- data type must support conversion from JSON via 'J.FromJSON'.--- If you want the raw JSON value, just ask for a @'J.Result'--- 'J.Value'@.------ The MIME type must indicate JSON content. Requiring a JSON--- content-type helps secure your site against CSRF attacks--- (browsers will perform POST requests for form and text/plain--- content-types without doing a CORS check, and those content-types--- can easily contain valid JSON).------ Note that this function will consume the request body. As such, calling it--- twice will result in a parse error on the second call, since the request--- body will no longer be available.------ @since 0.3.0-parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)-parseCheckJsonBody = do- mct <- lookupHeader "content-type"- case fmap (B8.takeWhile (/= ';')) mct of- Just "application/json" -> parseInsecureJsonBody- _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct---- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse--- error.-parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a-parseJsonBody_ = requireInsecureJsonBody-{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}---- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse--- error.-requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a-requireJsonBody = requireInsecureJsonBody-{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}---- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse--- error.------ @since 1.6.11-requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a-requireInsecureJsonBody = do- ra <- parseInsecureJsonBody- case ra of- J.Error s -> invalidArgs [pack s]- J.Success a -> return a---- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse--- error.-requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a-requireCheckJsonBody = do- ra <- parseCheckJsonBody- case ra of- J.Error s -> invalidArgs [pack s]- J.Success a -> return a---- | Convert a list of values to an 'J.Array'.-array :: J.ToJSON a => [a] -> J.Value-array = J.Array . V.fromList . map J.toJSON---- | jsonOrRedirect simplifies the scenario where a POST handler sends a different--- response based on Accept headers:------ 1. 200 with JSON data if the client prefers--- @application\/json@ (e.g. AJAX, see 'acceptsJSON').------ 2. 3xx otherwise, following the PRG pattern.-jsonOrRedirect :: (MonadHandler m, J.ToJSON a)- => Route (HandlerSite m) -- ^ Redirect target- -> a -- ^ Data to send via JSON- -> m J.Value-jsonOrRedirect = jsonOrRedirect' J.toJSON---- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different--- response based on Accept headers:------ 1. 200 with JSON data if the client prefers--- @application\/json@ (e.g. AJAX, see 'acceptsJSON').------ 2. 3xx otherwise, following the PRG pattern.--- @since 1.4.21-jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)- => Route (HandlerSite m) -- ^ Redirect target- -> a -- ^ Data to send via JSON- -> m J.Encoding-jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding--jsonOrRedirect' :: MonadHandler m- => (a -> b)- -> Route (HandlerSite m) -- ^ Redirect target- -> a -- ^ Data to send via JSON- -> m b-jsonOrRedirect' f r j = do- q <- acceptsJson- if q then return (f j)- else redirect r---- | Returns @True@ if the client prefers @application\/json@ as--- indicated by the @Accept@ HTTP header.-acceptsJson :: MonadHandler m => m Bool-acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))- . listToMaybe- . reqAccept)- `liftM` getRequest
− Yesod/Core/TypeCache.hs
@@ -1,96 +0,0 @@--- | a module for caching a monadic action based on its return type------ The cache is a HashMap where the key uses the TypeReP from Typeable.--- The value stored is toDyn from Dynamic to support arbitrary value types in the same Map.------ un-exported newtype wrappers should be used to maintain unique keys in the cache.--- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.------ used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'-module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where--import Prelude hiding (lookup)-import Data.Typeable (Typeable, TypeRep, typeOf)-import Data.HashMap.Strict-import Data.ByteString (ByteString)-import Data.Dynamic (Dynamic, toDyn, fromDynamic)--type TypeMap = HashMap TypeRep Dynamic-type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic---- | avoid performing the same action multiple times.--- Values are stored by their TypeRep from Typeable.--- Therefore, you should use un-exported newtype wrappers for each cache.------ For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.--- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.------ In Yesod, this is used for a request-local cache that is cleared at the end of every request.--- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>------ Since 1.4.0-cached :: (Monad m, Typeable a)- => TypeMap- -> m a -- ^ cache the result of this action- -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit-cached cache action = case cacheGet cache of- Just val -> return $ Right val- Nothing -> do- val <- action- return $ Left (cacheSet val cache, val)---- | Retrieves a value from the cache------ @since 1.6.10-cacheGet :: Typeable a => TypeMap -> Maybe a-cacheGet cache = res- where- res = lookup (typeOf $ fromJust res) cache >>= fromDynamic- fromJust :: Maybe a -> a- fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"---- | Sets a value in the cache------ @since 1.6.10-cacheSet :: (Typeable a)- => a- -> TypeMap- -> TypeMap-cacheSet v cache = insert (typeOf v) (toDyn v) cache---- | similar to 'cached'.--- 'cached' can only cache a single value per type.--- 'cachedBy' stores multiple values per type by indexing on a ByteString key------ 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user--- 'cachedBy' is required if the action has parameters and can return multiple values per type.--- You can turn those parameters into a ByteString cache key.--- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.------ Since 1.4.0-cachedBy :: (Monad m, Typeable a)- => KeyedTypeMap- -> ByteString -- ^ a cache key- -> m a -- ^ cache the result of this action- -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit-cachedBy cache k action = case cacheByGet k cache of- Just val -> return $ Right val- Nothing -> do- val <- action- return $ Left (cacheBySet k val cache, val)---- | Retrieves a value from the keyed cache------ @since 1.6.10-cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a-cacheByGet key c = res- where- res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic- fromJust :: Maybe a -> a- fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"---- | Sets a value in the keyed cache------ @since 1.6.10-cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap-cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache
− Yesod/Core/Types.hs
@@ -1,554 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Yesod.Core.Types where--import qualified Data.ByteString.Builder as BB-import Control.Arrow (first)-import Control.Exception (Exception)-import Control.Monad (ap)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Logger (LogLevel, LogSource,- MonadLogger (..))-import Control.Monad.Primitive (PrimMonad (..))-import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as L-import Data.CaseInsensitive (CI)-import Data.Conduit (Flush, ConduitT)-import Data.IORef (IORef, modifyIORef')-import Data.Map (Map, unionWith)-import qualified Data.Map as Map-import Data.Monoid (Endo (..), Last (..))-import Data.Semigroup (Semigroup(..))-import Data.Serialize (Serialize (..),- putByteString)-import Data.String (IsString (fromString))-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy.Builder as TBuilder-import Data.Time (UTCTime)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Language.Haskell.TH.Syntax (Loc)-import qualified Network.HTTP.Types as H-import Network.Wai (FilePart,- RequestBodyLength)-import qualified Network.Wai as W-import qualified Network.Wai.Parse as NWP-import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)-import Network.Wai.Logger (DateCacheGetter)-import Text.Blaze.Html (Html, toHtml)-import Text.Hamlet (HtmlUrl)-import Text.Julius (JavascriptUrl)-import Web.Cookie (SetCookie)-import Yesod.Core.Internal.Util (getTime, putTime)-import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))-import Control.Monad.Reader (MonadReader (..))-import Control.DeepSeq (NFData (rnf))-import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)-import Control.Monad.Logger (MonadLoggerIO (..))-import UnliftIO (MonadUnliftIO (..), UnliftIO (..))---- Sessions-type SessionMap = Map Text ByteString--type SaveSession = SessionMap -- ^ The session contents after running the handler- -> IO [Header]--newtype SessionBackend = SessionBackend- { sbLoadSession :: W.Request- -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session- }--data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap- deriving (Show, Read)-instance Serialize SessionCookie where- put (SessionCookie a b c) = do- either putTime putByteString a- put b- put (map (first T.unpack) $ Map.toList c)-- get = do- a <- getTime- b <- get- c <- map (first T.pack) <$> get- return $ SessionCookie (Left a) b (Map.fromList c)--data ClientSessionDateCache =- ClientSessionDateCache {- csdcNow :: !UTCTime- , csdcExpires :: !UTCTime- , csdcExpiresSerialized :: !ByteString- } deriving (Eq, Show)---- | The parsed request information. This type augments the standard WAI--- 'W.Request' with additional information.-data YesodRequest = YesodRequest- { reqGetParams :: ![(Text, Text)]- -- ^ Same as 'W.queryString', but decoded to @Text@.- , reqCookies :: ![(Text, Text)]- , reqWaiRequest :: !W.Request- , reqLangs :: ![Text]- -- ^ Languages which the client supports. This is an ordered list by preference.- , reqToken :: !(Maybe Text)- -- ^ A random, session-specific token used to prevent CSRF attacks.- , reqSession :: !SessionMap- -- ^ Initial session sent from the client.- --- -- Since 1.2.0- , reqAccept :: ![ContentType]- -- ^ An ordered list of the accepted content types.- --- -- Since 1.2.0- }---- | An augmented WAI 'W.Response'. This can either be a standard @Response@,--- or a higher-level data structure which Yesod will turn into a @Response@.-data YesodResponse- = YRWai !W.Response- | YRWaiApp !W.Application- | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap---- | A tuple containing both the POST parameters and submitted files.-type RequestBodyContents =- ( [(Text, Text)]- , [(Text, FileInfo)]- )--data FileInfo = FileInfo- { fileName :: !Text- , fileContentType :: !Text- , fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ())- , fileMove :: !(FilePath -> IO ())- }--data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)- | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)- | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))---- | How to determine the root of the application for constructing URLs.------ Note that future versions of Yesod may add new constructors without bumping--- the major version number. As a result, you should /not/ pattern match on--- @Approot@ values.-data Approot master = ApprootRelative -- ^ No application root.- | ApprootStatic !Text- | ApprootMaster !(master -> Text)- | ApprootRequest !(master -> W.Request -> Text)--type ResolvedApproot = Text--data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text- deriving (Eq, Show, Read)--data ScriptLoadPosition master- = BottomOfBody- | BottomOfHeadBlocking- | BottomOfHeadAsync !(BottomOfHeadAsync master)--type BottomOfHeadAsync master- = [Text] -- ^ urls to load asynchronously- -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion- -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head>--type Texts = [Text]---- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.-newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }---- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.------ @since 1.4.34-newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }--data RunHandlerEnv child site = RunHandlerEnv- { rheRender :: !(Route site -> [(Text, Text)] -> Text)- , rheRoute :: !(Maybe (Route child))- , rheRouteToMaster :: !(Route child -> Route site)- , rheSite :: !site- , rheChild :: !child- , rheUpload :: !(RequestBodyLength -> FileUpload)- , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())- , rheOnError :: !(ErrorResponse -> YesodApp)- -- ^ How to respond when an error is thrown internally.- --- -- Since 1.2.0- , rheMaxExpires :: !Text- }--data HandlerData child site = HandlerData- { handlerRequest :: !YesodRequest- , handlerEnv :: !(RunHandlerEnv child site)- , handlerState :: !(IORef GHState)- , handlerResource :: !InternalState- }--data YesodRunnerEnv site = YesodRunnerEnv- { yreLogger :: !Logger- , yreSite :: !site- , yreSessionBackend :: !(Maybe SessionBackend)- , yreGen :: !(IO Int)- -- ^ Generate a random number- , yreGetMaxExpires :: !(IO Text)- }--data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv- { ysreParentRunner :: !(ParentRunner parent)- , ysreGetSub :: !(parent -> sub)- , ysreToParentRoute :: !(Route sub -> Route parent)- , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?- }--type ParentRunner parent- = HandlerFor parent TypedContent- -> YesodRunnerEnv parent- -> Maybe (Route parent)- -> W.Application---- | A generic handler monad, which can have a different subsite and master--- site. We define a newtype for better error message.-newtype HandlerFor site a = HandlerFor- { unHandlerFor :: HandlerData site site -> IO a- }- deriving Functor--data GHState = GHState- { ghsSession :: !SessionMap- , ghsRBC :: !(Maybe RequestBodyContents)- , ghsIdent :: !Int- , ghsCache :: !TypeMap- , ghsCacheBy :: !KeyedTypeMap- , ghsHeaders :: !(Endo [Header])- }---- | An extension of the basic WAI 'W.Application' datatype to provide extra--- features needed by Yesod. Users should never need to use this directly, as--- the 'HandlerT' monad and template haskell code should hide it away.-type YesodApp = YesodRequest -> ResourceT IO YesodResponse---- | A generic widget, allowing specification of both the subsite and master--- site datatypes. While this is simply a @WriterT@, we define a newtype for--- better error messages.-newtype WidgetFor site a = WidgetFor- { unWidgetFor :: WidgetData site -> IO a- }- deriving Functor--data WidgetData site = WidgetData- { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))- , wdHandler :: {-# UNPACK #-} !(HandlerData site site)- }--instance a ~ () => Monoid (WidgetFor site a) where- mempty = return ()-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif-instance a ~ () => Semigroup (WidgetFor site a) where- x <> y = x >> y---- | A 'String' can be trivially promoted to a widget.------ For example, in a yesod-scaffold site you could use:------ @getHomeR = do defaultLayout "Widget text"@-instance a ~ () => IsString (WidgetFor site a) where- fromString = toWidget . toHtml . T.pack- where toWidget x = tellWidget mempty { gwdBody = Body (const x) }--tellWidget :: GWData (Route site) -> WidgetFor site ()-tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)--type RY master = Route master -> [(Text, Text)] -> Text---- | Newtype wrapper allowing injection of arbitrary content into CSS.------ Usage:------ > toWidget $ CssBuilder "p { color: red }"------ Since: 1.1.3-newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }---- | Content for a web page. By providing this datatype, we can easily create--- generic site templates, which would have the type signature:------ > PageContent url -> HtmlUrl url-data PageContent url = PageContent- { pageTitle :: !Html- , pageHead :: !(HtmlUrl url)- , pageBody :: !(HtmlUrl url)- }--data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.- | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())- | ContentFile !FilePath !(Maybe FilePart)- | ContentDontEvaluate !Content--data TypedContent = TypedContent !ContentType !Content--type RepHtml = Html-{-# DEPRECATED RepHtml "Please use Html instead" #-}-newtype RepJson = RepJson Content-newtype RepPlain = RepPlain Content-newtype RepXml = RepXml Content--type ContentType = ByteString -- FIXME Text?---- | Prevents a response body from being fully evaluated before sending the--- request.------ Since 1.1.0-newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }---- | Responses to indicate some form of an error occurred.-data ErrorResponse =- NotFound- | InternalError !Text- | InvalidArgs ![Text]- | NotAuthenticated- | PermissionDenied !Text- | BadMethod !H.Method- deriving (Show, Eq, Typeable, Generic)-instance NFData ErrorResponse------- header stuff--- | Headers to be added to a 'Result'.-data Header =- AddCookie !SetCookie- | DeleteCookie !ByteString !ByteString- -- ^ name and path- | Header !(CI ByteString) !ByteString- -- ^ key and value- deriving (Eq, Show)---- FIXME In the next major version bump, let's just add strictness annotations--- to Header (and probably everywhere else). We can also add strictness--- annotations to SetCookie in the cookie package.-instance NFData Header where- rnf (AddCookie x) = rnf x- rnf (DeleteCookie x y) = x `seq` y `seq` ()- rnf (Header x y) = x `seq` y `seq` ()--data Location url = Local !url | Remote !Text- deriving (Show, Eq)---- | A diff list that does not directly enforce uniqueness.--- When creating a widget Yesod will use nub to make it unique.-newtype UniqueList x = UniqueList ([x] -> [x])--data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }- deriving (Show, Eq)-data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }- deriving (Show, Eq)-newtype Title = Title { unTitle :: Html }--newtype Head url = Head (HtmlUrl url)- deriving Monoid-instance Semigroup (Head url) where- (<>) = mappend-newtype Body url = Body (HtmlUrl url)- deriving Monoid-instance Semigroup (Body url) where- (<>) = mappend--type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder--data GWData a = GWData- { gwdBody :: !(Body a)- , gwdTitle :: !(Last Title)- , gwdScripts :: !(UniqueList (Script a))- , gwdStylesheets :: !(UniqueList (Stylesheet a))- , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type- , gwdJavascript :: !(Maybe (JavascriptUrl a))- , gwdHead :: !(Head a)- }-instance Monoid (GWData a) where- mempty = GWData mempty mempty mempty mempty mempty mempty mempty-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif-instance Semigroup (GWData a) where- GWData a1 a2 a3 a4 a5 a6 a7 <>- GWData b1 b2 b3 b4 b5 b6 b7 = GWData- (mappend a1 b1)- (mappend a2 b2)- (mappend a3 b3)- (mappend a4 b4)- (unionWith mappend a5 b5)- (mappend a6 b6)- (mappend a7 b7)--data HandlerContents =- HCContent !H.Status !TypedContent- | HCError !ErrorResponse- | HCSendFile !ContentType !FilePath !(Maybe FilePart)- | HCRedirect !H.Status !Text- | HCCreated !Text- | HCWai !W.Response- | HCWaiApp !W.Application- deriving Typeable--instance Show HandlerContents where- show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)- show (HCError e) = "HCError " ++ show e- show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)- show (HCRedirect s t) = "HCRedirect " ++ show (s, t)- show (HCCreated t) = "HCCreated " ++ show t- show (HCWai _) = "HCWai"- show (HCWaiApp _) = "HCWaiApp"-instance Exception HandlerContents---- Instances for WidgetFor-instance Applicative (WidgetFor site) where- pure = WidgetFor . const . pure- (<*>) = ap-instance Monad (WidgetFor site) where- return = pure- WidgetFor x >>= f = WidgetFor $ \wd -> do- a <- x wd- unWidgetFor (f a) wd-instance MonadIO (WidgetFor site) where- liftIO = WidgetFor . const--- | @since 1.6.7-instance PrimMonad (WidgetFor site) where- type PrimState (WidgetFor site) = PrimState IO- primitive = liftIO . primitive--- | @since 1.4.38-instance MonadUnliftIO (WidgetFor site) where- {-# INLINE askUnliftIO #-}- askUnliftIO = WidgetFor $ \wd ->- return (UnliftIO (flip unWidgetFor wd))-instance MonadReader (WidgetData site) (WidgetFor site) where- ask = WidgetFor return- local f (WidgetFor g) = WidgetFor $ g . f--instance MonadThrow (WidgetFor site) where- throwM = liftIO . throwM--instance MonadResource (WidgetFor site) where- liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler--instance MonadLogger (WidgetFor site) where- monadLoggerLog a b c d = WidgetFor $ \wd ->- rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)--instance MonadLoggerIO (WidgetFor site) where- askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler---- Instances for HandlerT-instance Applicative (HandlerFor site) where- pure = HandlerFor . const . return- (<*>) = ap-instance Monad (HandlerFor site) where- return = pure- HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r-instance MonadIO (HandlerFor site) where- liftIO = HandlerFor . const--- | @since 1.6.7-instance PrimMonad (HandlerFor site) where- type PrimState (HandlerFor site) = PrimState IO- primitive = liftIO . primitive-instance MonadReader (HandlerData site site) (HandlerFor site) where- ask = HandlerFor return- local f (HandlerFor g) = HandlerFor $ g . f---- | @since 1.4.38-instance MonadUnliftIO (HandlerFor site) where- {-# INLINE askUnliftIO #-}- askUnliftIO = HandlerFor $ \r ->- return (UnliftIO (flip unHandlerFor r))--instance MonadThrow (HandlerFor site) where- throwM = liftIO . throwM--instance MonadResource (HandlerFor site) where- liftResourceT f = HandlerFor $ runInternalState f . handlerResource--instance MonadLogger (HandlerFor site) where- monadLoggerLog a b c d = HandlerFor $ \hd ->- rheLog (handlerEnv hd) a b c (toLogStr d)--instance MonadLoggerIO (HandlerFor site) where- askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))--instance Monoid (UniqueList x) where- mempty = UniqueList id-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif-instance Semigroup (UniqueList x) where- UniqueList x <> UniqueList y = UniqueList $ x . y--instance IsString Content where- fromString = flip ContentBuilder Nothing . BB.stringUtf8--instance RenderRoute WaiSubsite where- data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]- deriving (Show, Eq, Read, Ord)- renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)-instance ParseRoute WaiSubsite where- parseRoute (x, y) = Just $ WaiSubsiteRoute x y--instance RenderRoute WaiSubsiteWithAuth where- data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]- deriving (Show, Eq, Read, Ord)- renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)--instance ParseRoute WaiSubsiteWithAuth where- parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y--data Logger = Logger- { loggerSet :: !LoggerSet- , loggerDate :: !DateCacheGetter- }--loggerPutStr :: Logger -> LogStr -> IO ()-loggerPutStr (Logger ls _) = pushLogStr ls---- | A handler monad for subsite------ @since 1.6.0-newtype SubHandlerFor sub master a = SubHandlerFor- { unSubHandlerFor :: HandlerData sub master -> IO a- }- deriving Functor--instance Applicative (SubHandlerFor child master) where- pure = SubHandlerFor . const . return- (<*>) = ap-instance Monad (SubHandlerFor child master) where- return = pure- SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r-instance MonadIO (SubHandlerFor child master) where- liftIO = SubHandlerFor . const-instance MonadReader (HandlerData child master) (SubHandlerFor child master) where- ask = SubHandlerFor return- local f (SubHandlerFor g) = SubHandlerFor $ g . f---- | @since 1.4.38-instance MonadUnliftIO (SubHandlerFor child master) where- {-# INLINE askUnliftIO #-}- askUnliftIO = SubHandlerFor $ \r ->- return (UnliftIO (flip unSubHandlerFor r))--instance MonadThrow (SubHandlerFor child master) where- throwM = liftIO . throwM--instance MonadResource (SubHandlerFor child master) where- liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource--instance MonadLogger (SubHandlerFor child master) where- monadLoggerLog a b c d = SubHandlerFor $ \sd ->- rheLog (handlerEnv sd) a b c (toLogStr d)--instance MonadLoggerIO (SubHandlerFor child master) where- askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
− Yesod/Core/Unsafe.hs
@@ -1,25 +0,0 @@--- | This is designed to be used as------ > import qualified Yesod.Core.Unsafe as Unsafe------ This serves as a reminder that the functions are unsafe to use in many situations.-module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where--import Yesod.Core.Internal.Run (runFakeHandler)--import Yesod.Core.Types-import Yesod.Core.Class.Yesod-import Control.Monad.IO.Class (MonadIO)---- | designed to be used as------ > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger-fakeHandlerGetLogger :: (Yesod site, MonadIO m)- => (site -> Logger)- -> site- -> HandlerFor site a- -> m a-fakeHandlerGetLogger getLogger app f =- runFakeHandler mempty getLogger app f- >>= either (error . ("runFakeHandler issue: " `mappend`) . show)- return
− Yesod/Core/Widget.hs
@@ -1,274 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}--- | Widgets combine HTML with JS and CSS dependencies with a unique identifier--- generator, allowing you to create truly modular HTML components.-module Yesod.Core.Widget- ( -- * Datatype- WidgetT- , WidgetFor- , PageContent (..)- -- * Special Hamlet quasiquoter/TH for Widgets- , whamlet- , whamletFile- , ihamletToRepHtml- , ihamletToHtml- -- * Convert to Widget- , ToWidget (..)- , ToWidgetHead (..)- , ToWidgetBody (..)- , ToWidgetMedia (..)- -- * Creating- -- ** Head of page- , setTitle- , setTitleI- -- ** CSS- , addStylesheet- , addStylesheetAttrs- , addStylesheetRemote- , addStylesheetRemoteAttrs- , addStylesheetEither- , CssBuilder (..)- -- ** Javascript- , addScript- , addScriptAttrs- , addScriptRemote- , addScriptRemoteAttrs- , addScriptEither- -- * Subsites- , handlerToWidget- -- * Internal- , whamletFileWithSettings- , asWidgetT- ) where--import Data.Monoid-import qualified Text.Blaze.Html5 as H-import Text.Hamlet-import Text.Cassius-import Text.Julius-import Yesod.Routes.Class-import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)-import Text.Shakespeare.I18N (RenderMessage)-import Data.Text (Text)-import qualified Data.Map as Map-import Language.Haskell.TH.Quote (QuasiQuoter)-import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)--import qualified Text.Hamlet as NP-import Data.Text.Lazy.Builder (fromLazyText)-import Text.Blaze.Html (toHtml, preEscapedToMarkup)-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB--import Yesod.Core.Types-import Yesod.Core.Class.Handler--type WidgetT site (m :: * -> *) = WidgetFor site-{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}--preEscapedLazyText :: TL.Text -> Html-preEscapedLazyText = preEscapedToMarkup--class ToWidget site a where- toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()--instance render ~ RY site => ToWidget site (render -> Html) where- toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty-instance render ~ RY site => ToWidget site (render -> Css) where- toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x-instance ToWidget site Css where- toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x-instance render ~ RY site => ToWidget site (render -> CssBuilder) where- toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty-instance ToWidget site CssBuilder where- toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty-instance render ~ RY site => ToWidget site (render -> Javascript) where- toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty-instance ToWidget site Javascript where- toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty-instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where- toWidget = liftWidget-instance ToWidget site Html where- toWidget = toWidget . const--- | @since 1.4.28-instance ToWidget site Text where- toWidget = toWidget . toHtml--- | @since 1.4.28-instance ToWidget site TL.Text where- toWidget = toWidget . toHtml--- | @since 1.4.28-instance ToWidget site TB.Builder where- toWidget = toWidget . toHtml---- | Allows adding some CSS to the page with a specific media type.------ Since 1.2-class ToWidgetMedia site a where- -- | Add the given content to the page, but only for the given media type.- --- -- Since 1.2- toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)- => Text -- ^ media value- -> a- -> m ()-instance render ~ RY site => ToWidgetMedia site (render -> Css) where- toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x-instance ToWidgetMedia site Css where- toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x-instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where- toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty-instance ToWidgetMedia site CssBuilder where- toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty--class ToWidgetBody site a where- toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()--instance render ~ RY site => ToWidgetBody site (render -> Html) where- toWidgetBody = toWidget-instance render ~ RY site => ToWidgetBody site (render -> Javascript) where- toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetBody site Javascript where- toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j-instance ToWidgetBody site Html where- toWidgetBody = toWidget--class ToWidgetHead site a where- toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()--instance render ~ RY site => ToWidgetHead site (render -> Html) where- toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head-instance render ~ RY site => ToWidgetHead site (render -> Css) where- toWidgetHead = toWidget-instance ToWidgetHead site Css where- toWidgetHead = toWidget-instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where- toWidgetHead = toWidget-instance ToWidgetHead site CssBuilder where- toWidgetHead = toWidget-instance render ~ RY site => ToWidgetHead site (render -> Javascript) where- toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetHead site Javascript where- toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j-instance ToWidgetHead site Html where- toWidgetHead = toWidgetHead . const---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitle :: MonadWidget m => Html -> m ()-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()-setTitleI msg = do- mr <- getMessageRender- setTitle $ toHtml $ mr msg---- | Link to the specified local stylesheet.-addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()-addStylesheet = flip addStylesheetAttrs []---- | Link to the specified local stylesheet.-addStylesheetAttrs :: MonadWidget m- => Route (HandlerSite m)- -> [(Text, Text)]- -> m ()-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty---- | Link to the specified remote stylesheet.-addStylesheetRemote :: MonadWidget m => Text -> m ()-addStylesheetRemote = flip addStylesheetRemoteAttrs []---- | Link to the specified remote stylesheet.-addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty--addStylesheetEither :: MonadWidget m- => Either (Route (HandlerSite m)) Text- -> m ()-addStylesheetEither = either addStylesheet addStylesheetRemote--addScriptEither :: MonadWidget m- => Either (Route (HandlerSite m)) Text- -> m ()-addScriptEither = either addScript addScriptRemote---- | Link to the specified local script.-addScript :: MonadWidget m => Route (HandlerSite m) -> m ()-addScript = flip addScriptAttrs []---- | Link to the specified local script.-addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty---- | Link to the specified remote script.-addScriptRemote :: MonadWidget m => Text -> m ()-addScriptRemote = flip addScriptRemoteAttrs []---- | Link to the specified remote script.-addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty--whamlet :: QuasiQuoter-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings--whamletFile :: FilePath -> Q Exp-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings--whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp-whamletFileWithSettings = NP.hamletFileWithSettings rules--asWidgetT :: WidgetT site m () -> WidgetT site m ()-asWidgetT = id--rules :: Q NP.HamletRules-rules = do- ah <- [|asWidgetT . toWidget|]- let helper qg f = do- x <- newName "urender"- e <- f $ VarE x- let e' = LamE [VarP x] e- g <- qg- bind <- [|(>>=)|]- return $ InfixE (Just g) bind (Just e')- let ur f = do- let env = NP.Env- (Just $ helper [|getUrlRenderParams|])- (Just $ helper [|fmap (toHtml .) getMessageRender|])- f env- return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)- => HtmlUrlI18n message (Route (HandlerSite m))- -> m Html-ihamletToRepHtml = ihamletToHtml-{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.------ Since 1.2.1-ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)- => HtmlUrlI18n message (Route (HandlerSite m))- -> m Html-ihamletToHtml ih = do- urender <- getUrlRenderParams- mrender <- getMessageRender- return $ ih (toHtml . mrender) urender--tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()-tell = liftWidget . tellWidget--toUnique :: x -> UniqueList x-toUnique = UniqueList . (:)--handlerToWidget :: HandlerFor site a -> WidgetFor site a-handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
− Yesod/Routes/Class.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Routes.Class- ( RenderRoute (..)- , ParseRoute (..)- , RouteAttrs (..)- ) where--import Data.Text (Text)-import Data.Set (Set)--class Eq (Route a) => RenderRoute a where- -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument.- data Route a- renderRoute :: Route a- -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.--class RenderRoute a => ParseRoute a where- parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.- -> Maybe (Route a)--class RenderRoute a => RouteAttrs a where- routeAttrs :: Route a- -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.
− Yesod/Routes/Overlap.hs
@@ -1,88 +0,0 @@--- | Check for overlapping routes.-module Yesod.Routes.Overlap- ( findOverlapNames- , Overlap (..)- ) where--import Yesod.Routes.TH.Types-import Data.List (intercalate)--data Flattened t = Flattened- { fNames :: [String]- , fPieces :: [Piece t]- , fHasSuffix :: Bool- , fCheck :: CheckOverlap- }--flatten :: ResourceTree t -> [Flattened t]-flatten =- go id id True- where- go names pieces check (ResourceLeaf r) = return Flattened- { fNames = names [resourceName r]- , fPieces = pieces (resourcePieces r)- , fHasSuffix = hasSuffix $ ResourceLeaf r- , fCheck = check && resourceCheck r- }- go names pieces check (ResourceParent newname check' newpieces children) =- concatMap (go names' pieces' (check && check')) children- where- names' = names . (newname:)- pieces' = pieces . (newpieces ++)--data Overlap t = Overlap- { overlapParents :: [String] -> [String] -- ^ parent resource trees- , overlap1 :: ResourceTree t- , overlap2 :: ResourceTree t- }--data OverlapF = OverlapF- { _overlapF1 :: [String]- , _overlapF2 :: [String]- }--overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool---- No pieces on either side, will overlap regardless of suffix-overlaps [] [] _ _ = True---- No pieces on the left, will overlap if the left side has a suffix-overlaps [] _ suffixX _ = suffixX---- Ditto for the right-overlaps _ [] _ suffixY = suffixY---- Compare the actual pieces-overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =- piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY--piecesOverlap :: Piece t -> Piece t -> Bool--- Statics only match if they equal. Dynamics match with anything-piecesOverlap (Static x) (Static y) = x == y-piecesOverlap _ _ = True--findOverlapNames :: [ResourceTree t] -> [(String, String)]-findOverlapNames =- map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten- where- go (OverlapF x y) =- (go' x, go' y)- where- go' = intercalate "/"--findOverlapsF :: [Flattened t] -> [OverlapF]-findOverlapsF [] = []-findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs--findOverlapF :: Flattened t -> Flattened t -> [OverlapF]-findOverlapF x y- | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]- | otherwise = []--hasSuffix :: ResourceTree t -> Bool-hasSuffix (ResourceLeaf r) =- case resourceDispatch r of- Subsite{} -> True- Methods Just{} _ -> True- Methods Nothing _ -> False-hasSuffix ResourceParent{} = True
− Yesod/Routes/Parse.hs
@@ -1,296 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternGuards #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter-module Yesod.Routes.Parse- ( parseRoutes- , parseRoutesFile- , parseRoutesNoCheck- , parseRoutesFileNoCheck- , parseType- , parseTypeTree- , TypeTree (..)- , dropBracket- , nameToType- ) where--import Language.Haskell.TH.Syntax-import Data.Char (isUpper, isLower, isSpace)-import Language.Haskell.TH.Quote-import qualified System.IO as SIO-import Yesod.Routes.TH-import Yesod.Routes.Overlap (findOverlapNames)-import Data.List (foldl', isPrefixOf)-import Data.Maybe (mapMaybe)-import qualified Data.Set as Set---- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for--- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the--- checking. See documentation site for details on syntax.-parseRoutes :: QuasiQuoter-parseRoutes = QuasiQuoter { quoteExp = x }- where- x s = do- let res = resourcesFromString s- case findOverlapNames res of- [] -> lift res- z -> error $ unlines $ "Overlapping routes: " : map show z--parseRoutesFile :: FilePath -> Q Exp-parseRoutesFile = parseRoutesFileWith parseRoutes--parseRoutesFileNoCheck :: FilePath -> Q Exp-parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck--parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp-parseRoutesFileWith qq fp = do- qAddDependentFile fp- s <- qRunIO $ readUtf8File fp- quoteExp qq s--readUtf8File :: FilePath -> IO String-readUtf8File fp = do- h <- SIO.openFile fp SIO.ReadMode- SIO.hSetEncoding h SIO.utf8_bom- SIO.hGetContents h---- | Same as 'parseRoutes', but performs no overlap checking.-parseRoutesNoCheck :: QuasiQuoter-parseRoutesNoCheck = QuasiQuoter- { quoteExp = lift . resourcesFromString- }---- | Converts a multi-line string to a set of resources. See documentation for--- the format of this string. This is a partial function which calls 'error' on--- invalid input.-resourcesFromString :: String -> [ResourceTree String]-resourcesFromString =- fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')- where- parse _ [] = ([], [])- parse indent (thisLine:otherLines)- | length spaces < indent = ([], thisLine : otherLines)- | otherwise = (this others, remainder)- where- parseAttr ('!':x) = Just x- parseAttr _ = Nothing-- stripColonLast =- go id- where- go _ [] = Nothing- go front [x]- | null x = Nothing- | last x == ':' = Just $ front [init x]- | otherwise = Nothing- go front (x:xs) = go (front . (x:)) xs-- spaces = takeWhile (== ' ') thisLine- (others, remainder) = parse indent otherLines'- (this, otherLines') =- case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of- (pattern:rest0)- | Just (constr:rest) <- stripColonLast rest0- , Just attrs <- mapM parseAttr rest ->- let (children, otherLines'') = parse (length spaces + 1) otherLines- children' = addAttrs attrs children- (pieces, Nothing, check) = piecesFromStringCheck pattern- in ((ResourceParent constr check pieces children' :), otherLines'')- (pattern:constr:rest) ->- let (pieces, mmulti, check) = piecesFromStringCheck pattern- (attrs, rest') = takeAttrs rest- disp = dispatchFromString rest' mmulti- in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)- [] -> (id, otherLines)- _ -> error $ "Invalid resource line: " ++ thisLine---- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).-splitSpaces :: String -> [String]-splitSpaces "" = []-splitSpaces str = - let (rest, piece) = parse $ dropWhile isSpace str in- piece:(splitSpaces rest)-- where - parse :: String -> ( String, String)- parse ('{':s) = fmap ('{':) $ parseBracket s- parse (c:s) | isSpace c = (s, [])- parse (c:s) = fmap (c:) $ parse s- parse "" = ("", "")-- parseBracket :: String -> ( String, String)- parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str- parseBracket ('}':s) = fmap ('}':) $ parse s- parseBracket (c:s) = fmap (c:) $ parseBracket s- parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str--piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)-piecesFromStringCheck s0 =- (pieces, mmulti, check)- where- (s1, check1) = stripBang s0- (pieces', mmulti') = piecesFromString $ drop1Slash s1- pieces = map snd pieces'- mmulti = fmap snd mmulti'- check = check1 && all fst pieces' && maybe True fst mmulti'-- stripBang ('!':rest) = (rest, False)- stripBang x = (x, True)--addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]-addAttrs attrs =- map goTree- where- goTree (ResourceLeaf res) = ResourceLeaf (goRes res)- goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z)-- goRes res =- res { resourceAttrs = noDupes ++ resourceAttrs res }- where- usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res- used attr =- case toPair attr of- Nothing -> False- Just (key, _) -> key `Set.member` usedKeys- noDupes = filter (not . used) attrs-- toPair s =- case break (== '=') s of- (x, '=':y) -> Just (x, y)- _ -> Nothing---- | Take attributes out of the list and put them in the first slot in the--- result tuple.-takeAttrs :: [String] -> ([String], [String])-takeAttrs =- go id id- where- go x y [] = (x [], y [])- go x y (('!':attr):rest) = go (x . (attr:)) y rest- go x y (z:rest) = go x (y . (z:)) rest--dispatchFromString :: [String] -> Maybe String -> Dispatch String-dispatchFromString rest mmulti- | null rest = Methods mmulti []- | all (all isUpper) rest = Methods mmulti rest-dispatchFromString [subTyp, subFun] Nothing =- Subsite subTyp subFun-dispatchFromString [_, _] Just{} =- error "Subsites cannot have a multipiece"-dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest--drop1Slash :: String -> String-drop1Slash ('/':x) = x-drop1Slash x = x--piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))-piecesFromString "" = ([], Nothing)-piecesFromString x =- case (this, rest) of- (Left typ, ([], Nothing)) -> ([], Just typ)- (Left _, _) -> error "Multipiece must be last piece"- (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)- where- (y, z) = break (== '/') x- this = pieceFromString y- rest = piecesFromString $ drop 1 z--parseType :: String -> Type-parseType orig =- maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig--parseTypeTree :: String -> Maybe TypeTree-parseTypeTree orig =- toTypeTree pieces- where- pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig- addDashes [] = []- addDashes (x:xs) =- front $ addDashes xs- where- front rest- | x `elem` "()[]" = '-' : x : '-' : rest- | otherwise = x : rest- splitOn c s =- case y' of- _:y -> x : splitOn c y- [] -> [x]- where- (x, y') = break c s--data TypeTree = TTTerm String- | TTApp TypeTree TypeTree- | TTList TypeTree- deriving (Show, Eq)--toTypeTree :: [String] -> Maybe TypeTree-toTypeTree orig = do- (x, []) <- gos orig- return x- where- go [] = Nothing- go ("(":xs) = do- (x, rest) <- gos xs- case rest of- ")":rest' -> Just (x, rest')- _ -> Nothing- go ("[":xs) = do- (x, rest) <- gos xs- case rest of- "]":rest' -> Just (TTList x, rest')- _ -> Nothing- go (x:xs) = Just (TTTerm x, xs)-- gos xs1 = do- (t, xs2) <- go xs1- (ts, xs3) <- gos' id xs2- Just (foldl' TTApp t ts, xs3)-- gos' front [] = Just (front [], [])- gos' front (x:xs)- | x `elem` words ") ]" = Just (front [], x:xs)- | otherwise = do- (t, xs') <- go $ x:xs- gos' (front . (t:)) xs'--ttToType :: TypeTree -> Type-ttToType (TTTerm s) = nameToType s-ttToType (TTApp x y) = ttToType x `AppT` ttToType y-ttToType (TTList t) = ListT `AppT` ttToType t--nameToType :: String -> Type-nameToType t@(h:_) | isLower h = VarT $ mkName t-nameToType t = ConT $ mkName t--pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)-pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)-pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652-pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)--pieceFromString ('*':'!':x) = Left (False, x)-pieceFromString ('+':'!':x) = Left (False, x)--pieceFromString ('!':'*':x) = Left (False, x)-pieceFromString ('!':'+':x) = Left (False, x)--pieceFromString ('*':x) = Left (True, x)-pieceFromString ('+':x) = Left (True, x)--pieceFromString ('!':x) = Right $ (False, Static x)-pieceFromString x = Right $ (True, Static x)--dropBracket :: String -> String-dropBracket str@('{':x) = case break (== '}') x of- (s, "}") -> s- _ -> error $ "Unclosed bracket ('{'): " ++ str-dropBracket x = x---- | If this line ends with a backslash, concatenate it together with the next line.------ @since 1.6.8-lineContinuations :: String -> [String] -> [String]-lineContinuations this [] = [this]-lineContinuations this below@(next:rest) = case unsnoc this of- Just (this', '\\') -> (this'++next):rest- _ -> this:below- where unsnoc s = if null s then Nothing else Just (init s, last s)
− Yesod/Routes/TH.hs
@@ -1,15 +0,0 @@-module Yesod.Routes.TH- ( module Yesod.Routes.TH.Types- -- * Functions- , module Yesod.Routes.TH.RenderRoute- , module Yesod.Routes.TH.ParseRoute- , module Yesod.Routes.TH.RouteAttrs- -- ** Dispatch- , module Yesod.Routes.TH.Dispatch- ) where--import Yesod.Routes.TH.Types-import Yesod.Routes.TH.RenderRoute-import Yesod.Routes.TH.ParseRoute-import Yesod.Routes.TH.RouteAttrs-import Yesod.Routes.TH.Dispatch
− Yesod/Routes/TH/Dispatch.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}-module Yesod.Routes.TH.Dispatch- ( MkDispatchSettings (..)- , mkDispatchClause- , defaultGetHandler- ) where--import Prelude hiding (exp)-import Language.Haskell.TH.Syntax-import Web.PathPieces-import Data.Maybe (catMaybes)-import Control.Monad (forM)-import Data.List (foldl')-import Control.Arrow (second)-import System.Random (randomRIO)-import Yesod.Routes.TH.Types-import Data.Char (toLower)--data MkDispatchSettings b site c = MkDispatchSettings- { mdsRunHandler :: Q Exp- , mdsSubDispatcher :: Q Exp- , mdsGetPathInfo :: Q Exp- , mdsSetPathInfo :: Q Exp- , mdsMethod :: Q Exp- , mds404 :: Q Exp- , mds405 :: Q Exp- , mdsGetHandler :: Maybe String -> String -> Q Exp- , mdsUnwrapper :: Exp -> Q Exp- }--data SDC = SDC- { clause404 :: Clause- , extraParams :: [Exp]- , extraCons :: [Exp]- , envExp :: Exp- , reqExp :: Exp- }---- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on--- view patterns.------ Since 1.4.0-mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause-mkDispatchClause MkDispatchSettings {..} resources = do- suffix <- qRunIO $ randomRIO (1000, 9999 :: Int)- envName <- newName $ "env" ++ show suffix- reqName <- newName $ "req" ++ show suffix- helperName <- newName $ "helper" ++ show suffix-- let envE = VarE envName- reqE = VarE reqName- helperE = VarE helperName-- clause404' <- mkClause404 envE reqE- getPathInfo <- mdsGetPathInfo- let pathInfo = getPathInfo `AppE` reqE-- let sdc = SDC- { clause404 = clause404'- , extraParams = []- , extraCons = []- , envExp = envE- , reqExp = reqE- }- clauses <- mapM (go sdc) resources-- return $ Clause- [VarP envName, VarP reqName]- (NormalB $ helperE `AppE` pathInfo)- [FunD helperName $ clauses ++ [clause404']]- where- handlePiece :: Piece a -> Q (Pat, Maybe Exp)- handlePiece (Static str) = return (LitP $ StringL str, Nothing)- handlePiece (Dynamic _) = do- x <- newName "dyn"- let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])- return (pat, Just $ VarE x)-- handlePieces :: [Piece a] -> Q ([Pat], [Exp])- handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece-- mkCon :: String -> [Exp] -> Exp- mkCon name = foldl' AppE (ConE $ mkName name)-- mkPathPat :: Pat -> [Pat] -> Pat- mkPathPat final =- foldr addPat final- where- addPat x y = ConP '(:) [x, y]-- go :: SDC -> ResourceTree a -> Q Clause- go sdc (ResourceParent name _check pieces children) = do- (pats, dyns) <- handlePieces pieces- let sdc' = sdc- { extraParams = extraParams sdc ++ dyns- , extraCons = extraCons sdc ++ [mkCon name dyns]- }- childClauses <- mapM (go sdc') children-- restName <- newName "rest"- let restE = VarE restName- restP = VarP restName-- helperName <- newName $ "helper" ++ name- let helperE = VarE helperName-- return $ Clause- [mkPathPat restP pats]- (NormalB $ helperE `AppE` restE)- [FunD helperName $ childClauses ++ [clause404 sdc]]- go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do- (pats, dyns) <- handlePieces pieces-- (chooseMethod, finalPat) <- handleDispatch dispatch dyns-- return $ Clause- [mkPathPat finalPat pats]- (NormalB chooseMethod)- []- where- handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)- handleDispatch dispatch' dyns =- case dispatch' of- Methods multi methods -> do- (finalPat, mfinalE) <-- case multi of- Nothing -> return (ConP '[] [], Nothing)- Just _ -> do- multiName <- newName "multi"- let pat = ViewP (VarE 'fromPathMultiPiece)- (ConP 'Just [VarP multiName])- return (pat, Just $ VarE multiName)-- let dynsMulti =- case mfinalE of- Nothing -> dyns- Just e -> dyns ++ [e]- route' = foldl' AppE (ConE (mkName name)) dynsMulti- route = foldr AppE route' extraCons- jroute = ConE 'Just `AppE` route- allDyns = extraParams ++ dynsMulti- mkRunExp mmethod = do- runHandlerE <- mdsRunHandler- handlerE' <- mdsGetHandler mmethod name- handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns- return $ runHandlerE- `AppE` handlerE- `AppE` envExp- `AppE` jroute- `AppE` reqExp-- func <-- case methods of- [] -> mkRunExp Nothing- _ -> do- getMethod <- mdsMethod- let methodE = getMethod `AppE` reqExp- matches <- forM methods $ \method -> do- exp <- mkRunExp (Just method)- return $ Match (LitP $ StringL method) (NormalB exp) []- match405 <- do- runHandlerE <- mdsRunHandler- handlerE <- mds405- let exp = runHandlerE- `AppE` handlerE- `AppE` envExp- `AppE` jroute- `AppE` reqExp- return $ Match WildP (NormalB exp) []- return $ CaseE methodE $ matches ++ [match405]-- return (func, finalPat)- Subsite _ getSub -> do- restPath <- newName "restPath"- setPathInfoE <- mdsSetPathInfo- subDispatcherE <- mdsSubDispatcher- runHandlerE <- mdsRunHandler- sub <- newName "sub"- let allDyns = extraParams ++ dyns- sroute <- newName "sroute"- let sub2 = LamE [VarP sub]- (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)- let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp- route' = foldl' AppE (ConE (mkName name)) dyns- route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons- exp = subDispatcherE- `AppE` runHandlerE- `AppE` sub2- `AppE` route- `AppE` envExp- `AppE` reqExp'- return (exp, VarP restPath)-- mkClause404 envE reqE = do- handler <- mds404- runHandler <- mdsRunHandler- let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE- return $ Clause [WildP] (NormalB exp) []--defaultGetHandler :: Maybe String -> String -> Q Exp-defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s-defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
− Yesod/Routes/TH/ParseRoute.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Yesod.Routes.TH.ParseRoute- ( -- ** ParseRoute- mkParseRouteInstance- ) where--import Yesod.Routes.TH.Types-import Language.Haskell.TH.Syntax-import Data.Text (Text)-import Yesod.Routes.Class-import Yesod.Routes.TH.Dispatch--mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec-mkParseRouteInstance cxt typ ress = do- cls <- mkDispatchClause- MkDispatchSettings- { mdsRunHandler = [|\_ _ x _ -> x|]- , mds404 = [|error "mds404"|]- , mds405 = [|error "mds405"|]- , mdsGetPathInfo = [|fst|]- , mdsMethod = [|error "mdsMethod"|]- , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]- , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]- , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]- , mdsUnwrapper = return- }- (map removeMethods ress)- helper <- newName "helper"- fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]- return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)- [ FunD 'parseRoute $ return $ Clause- []- (NormalB $ fixer `AppE` VarE helper)- [FunD helper [cls]]- ]- where- -- We do this in order to ski the unnecessary method parsing- removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res- removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z-- removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res }-- fixDispatch (Methods x _) = Methods x []- fixDispatch x = x--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing
− Yesod/Routes/TH/RenderRoute.hs
@@ -1,167 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-module Yesod.Routes.TH.RenderRoute- ( -- ** RenderRoute- mkRenderRouteInstance- , mkRouteCons- , mkRenderRouteClauses- ) where--import Yesod.Routes.TH.Types-import Language.Haskell.TH (conT)-import Language.Haskell.TH.Syntax-import Data.Bits (xor)-import Data.Maybe (maybeToList)-import Control.Monad (replicateM)-import Data.Text (pack)-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))-import Yesod.Routes.Class---- | Generate the constructors of a route data type.-mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])-mkRouteCons rttypes =- mconcat <$> mapM mkRouteCon rttypes- where- mkRouteCon (ResourceLeaf res) =- return ([con], [])- where- con = NormalC (mkName $ resourceName res)- $ map (\x -> (notStrict, x))- $ concat [singles, multi, sub]- singles = concatMap toSingle $ resourcePieces res- toSingle Static{} = []- toSingle (Dynamic typ) = [typ]-- multi = maybeToList $ resourceMulti res-- sub =- case resourceDispatch res of- Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]- _ -> []-- mkRouteCon (ResourceParent name _check pieces children) = do- (cons, decs) <- mkRouteCons children-#if MIN_VERSION_template_haskell(2,12,0)- dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])-#else- dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]-#endif- return ([con], dec : decs)- where- con = NormalC (mkName name)- $ map (\x -> (notStrict, x))- $ singles ++ [ConT $ mkName name]-- singles = concatMap toSingle pieces- toSingle Static{} = []- toSingle (Dynamic typ) = [typ]---- | Clauses for the 'renderRoute' method.-mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]-mkRenderRouteClauses =- mapM go- where- isDynamic Dynamic{} = True- isDynamic _ = False-- go (ResourceParent name _check pieces children) = do- let cnt = length $ filter isDynamic pieces- dyns <- replicateM cnt $ newName "dyn"- child <- newName "child"- let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]-- pack' <- [|pack|]- tsp <- [|toPathPiece|]- let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns-- childRender <- newName "childRender"- let rr = VarE childRender- childClauses <- mkRenderRouteClauses children-- a <- newName "a"- b <- newName "b"-- colon <- [|(:)|]- let cons y ys = InfixE (Just y) colon (Just ys)- let pieces' = foldr cons (VarE a) piecesSingle-- let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)-- return $ Clause [pat] (NormalB body) [FunD childRender childClauses]-- go (ResourceLeaf res) = do- let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)- dyns <- replicateM cnt $ newName "dyn"- sub <-- case resourceDispatch res of- Subsite{} -> return <$> newName "sub"- _ -> return []- let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub-- pack' <- [|pack|]- tsp <- [|toPathPiece|]- let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns-- piecesMulti <-- case resourceMulti res of- Nothing -> return $ ListE []- Just{} -> do- tmp <- [|toPathMultiPiece|]- return $ tmp `AppE` VarE (last dyns)-- body <-- case sub of- [x] -> do- rr <- [|renderRoute|]- a <- newName "a"- b <- newName "b"-- colon <- [|(:)|]- let cons y ys = InfixE (Just y) colon (Just ys)- let pieces = foldr cons (VarE a) piecesSingle-- return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)- _ -> do- colon <- [|(:)|]- let cons a b = InfixE (Just a) colon (Just b)- return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]-- return $ Clause [pat] (NormalB body) []-- mkPieces _ _ [] _ = []- mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns- mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns- mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"---- | Generate the 'RenderRoute' instance.------ This includes both the 'Route' associated type and the--- 'renderRoute' method. This function uses both 'mkRouteCons' and--- 'mkRenderRouteClasses'.-mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]-mkRenderRouteInstance cxt typ ress = do- cls <- mkRenderRouteClauses ress- (cons, decs) <- mkRouteCons ress-#if MIN_VERSION_template_haskell(2,12,0)- did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))- let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)-#else- did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)- let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)-#endif- return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)- [ did- , FunD (mkName "renderRoute") cls- ]- : sds ++ decs- where- clazzes standalone = if standalone `xor` null cxt then- clazzes'- else- []- clazzes' = [''Show, ''Eq, ''Read]--notStrict :: Bang-notStrict = Bang NoSourceUnpackedness NoSourceStrictness--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing
− Yesod/Routes/TH/RouteAttrs.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}-module Yesod.Routes.TH.RouteAttrs- ( mkRouteAttrsInstance- ) where--import Yesod.Routes.TH.Types-import Yesod.Routes.Class-import Language.Haskell.TH.Syntax-import Data.Set (fromList)-import Data.Text (pack)--mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec-mkRouteAttrsInstance cxt typ ress = do- clauses <- mapM (goTree id) ress- return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)- [ FunD 'routeAttrs $ concat clauses- ]--goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]-goTree front (ResourceLeaf res) = return <$> goRes front res-goTree front (ResourceParent name _check pieces trees) =- concat <$> mapM (goTree front') trees- where- ignored = (replicate toIgnore WildP ++) . return- toIgnore = length $ filter isDynamic pieces- isDynamic Dynamic{} = True- isDynamic Static{} = False- front' = front . ConP (mkName name) . ignored--goRes :: (Pat -> Pat) -> Resource a -> Q Clause-goRes front Resource {..} =- return $ Clause- [front $ RecP (mkName resourceName) []]- (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))- []- where- toText s = VarE 'pack `AppE` LitE (StringL s)--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing
− Yesod/Routes/TH/Types.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TemplateHaskell #-}--- | Warning! This module is considered internal and may have breaking changes-module Yesod.Routes.TH.Types- ( -- * Data types- Resource (..)- , ResourceTree (..)- , Piece (..)- , Dispatch (..)- , CheckOverlap- , FlatResource (..)- -- ** Helper functions- , resourceMulti- , resourceTreePieces- , resourceTreeName- , flatten- ) where--import Language.Haskell.TH.Syntax--data ResourceTree typ- = ResourceLeaf (Resource typ)- | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]- deriving (Show, Functor)--resourceTreePieces :: ResourceTree typ -> [Piece typ]-resourceTreePieces (ResourceLeaf r) = resourcePieces r-resourceTreePieces (ResourceParent _ _ x _) = x--resourceTreeName :: ResourceTree typ -> String-resourceTreeName (ResourceLeaf r) = resourceName r-resourceTreeName (ResourceParent x _ _ _) = x--instance Lift t => Lift (ResourceTree t) where- lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]- lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]--data Resource typ = Resource- { resourceName :: String- , resourcePieces :: [Piece typ]- , resourceDispatch :: Dispatch typ- , resourceAttrs :: [String]- , resourceCheck :: CheckOverlap- }- deriving (Show, Functor)--type CheckOverlap = Bool--instance Lift t => Lift (Resource t) where- lift (Resource a b c d e) = [|Resource a b c d e|]--data Piece typ = Static String | Dynamic typ- deriving Show--instance Functor Piece where- fmap _ (Static s) = Static s- fmap f (Dynamic t) = Dynamic (f t)--instance Lift t => Lift (Piece t) where- lift (Static s) = [|Static $(lift s)|]- lift (Dynamic t) = [|Dynamic $(lift t)|]--data Dispatch typ =- Methods- { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end- , methodsMethods :: [String] -- ^ supported request methods- }- | Subsite- { subsiteType :: typ- , subsiteFunc :: String- }- deriving Show--instance Functor Dispatch where- fmap f (Methods a b) = Methods (fmap f a) b- fmap f (Subsite a b) = Subsite (f a) b--instance Lift t => Lift (Dispatch t) where- lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]- lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]- lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]--resourceMulti :: Resource typ -> Maybe typ-resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t-resourceMulti _ = Nothing--data FlatResource a = FlatResource- { frParentPieces :: [(String, [Piece a])]- , frName :: String- , frPieces :: [Piece a]- , frDispatch :: Dispatch a- , frCheck :: Bool- } deriving (Show)--flatten :: [ResourceTree a] -> [FlatResource a]-flatten =- concatMap (go id True)- where- go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]- go front check' (ResourceParent name check pieces children) =- concatMap (go (front . ((name, pieces):)) (check && check')) children
+ src/Yesod/Core.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+module Yesod.Core+ ( -- * Type classes+ Yesod (..)+ , YesodDispatch (..)+ , YesodSubDispatch (..)+ , RenderRoute (..)+ , ParseRoute (..)+ , RouteAttrs (..)+ -- ** Breadcrumbs+ , YesodBreadcrumbs (..)+ , breadcrumbs+ -- * Types+ , Approot (..)+ , FileUpload (..)+ , ErrorResponse (..)+ -- * Utilities+ , maybeAuthorized+ , widgetToPageContent+ -- * Defaults+ , defaultErrorHandler+ , defaultYesodMiddleware+ , authorizationCheck+ -- * Data types+ , AuthResult (..)+ , unauthorizedI+ -- * Logging+ , defaultMakeLogger+ , defaultMessageLoggerSource+ , defaultShouldLogIO+ , formatLogMessage+ , LogLevel (..)+ , logDebug+ , logInfo+ , logWarn+ , logError+ , logOther+ , logDebugS+ , logInfoS+ , logWarnS+ , logErrorS+ , logOtherS+ -- * Sessions+ , SessionBackend (..)+ , customizeSessionCookies+ , defaultClientSessionBackend+ , envClientSessionBackend+ , clientSessionBackend+ , sslOnlySessions+ , laxSameSiteSessions+ , strictSameSiteSessions+ , sslOnlyMiddleware+ , clientSessionDateCacher+ , loadClientSession+ , Header(..)+ -- * CSRF protection+ , defaultCsrfMiddleware+ , defaultCsrfSetCookieMiddleware+ , csrfSetCookieMiddleware+ , defaultCsrfCheckMiddleware+ , csrfCheckMiddleware+ -- * JS loaders+ , ScriptLoadPosition (..)+ , BottomOfHeadAsync+ -- * Generalizing type classes+ , MonadHandler (..)+ , MonadWidget (..)+ -- * Approot+ , guessApproot+ , guessApprootOr+ , getApprootText+ -- * Misc+ , yesodVersion+ , yesodRender+ , Yesod.Core.runFakeHandler+ -- * LiteApp+ , module Yesod.Core.Internal.LiteApp+ -- * Low-level+ , yesodRunner+ -- * Re-exports+ , module Yesod.Core.Content+ , module Yesod.Core.Dispatch+ , module Yesod.Core.Handler+ , module Yesod.Core.Widget+ , module Yesod.Core.Json+ , module Text.Shakespeare.I18N+ , module Yesod.Core.Internal.Util+ , module Text.Blaze.Html+ , MonadTrans (..)+ , MonadIO (..)+ , MonadUnliftIO (..)+ , MonadResource (..)+ , MonadLogger+ -- * Commonly referenced functions/datatypes+ , Application+ -- * Utilities+ , showIntegral+ , readIntegral+ -- * Shakespeare+ -- ** Hamlet+ , hamlet+ , shamlet+ , xhamlet+ , HtmlUrl+ -- ** Julius+ , julius+ , JavascriptUrl+ , renderJavascriptUrl+ -- ** Cassius/Lucius+ , cassius+ , lucius+ , CssUrl+ , renderCssUrl+ ) where++import Yesod.Core.Content+import Yesod.Core.Dispatch+import Yesod.Core.Handler+import Yesod.Core.Class.Handler+import Yesod.Core.Widget+import Yesod.Core.Json+import Yesod.Core.Types+import Text.Shakespeare.I18N+import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)+import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)++import Control.Monad.Logger+import Control.Monad.Trans.Class (MonadTrans (..))+import Yesod.Core.Internal.Session+import Yesod.Core.Internal.Run (yesodRunner, yesodRender)+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Class.Breadcrumbs+import qualified Yesod.Core.Internal.Run+import qualified Paths_yesod_core+import Data.Version (showVersion)+import Yesod.Routes.Class+import UnliftIO (MonadIO (..), MonadUnliftIO (..))++import Control.Monad.Trans.Resource (MonadResource (..))+import Yesod.Core.Internal.LiteApp+import Text.Hamlet+import Text.Cassius+import Text.Lucius+import Text.Julius+import Network.Wai (Application)++runFakeHandler :: (Yesod site, MonadIO m) =>+ SessionMap+ -> (site -> Logger)+ -> site+ -> HandlerT site IO a+ -> m (Either ErrorResponse a)+runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler+{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}++-- | Return an 'Unauthorized' value, with the given i18n message.+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult+unauthorizedI msg = do+ mr <- getMessageRender+ return $ Unauthorized $ mr msg++yesodVersion :: String+yesodVersion = showVersion Paths_yesod_core.version++-- | 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+-- contain links to pages the user is allowed to see.+maybeAuthorized :: Yesod site+ => Route site+ -> Bool -- ^ is this a write request?+ -> HandlerT site IO (Maybe (Route site))+maybeAuthorized r isWrite = do+ x <- isAuthorized r isWrite+ return $ if x == Authorized then Just r else Nothing++showIntegral :: Integral a => a -> String+showIntegral x = show (fromIntegral x :: Integer)++readIntegral :: Num a => String -> Maybe a+readIntegral s =+ case reads s of+ (i, _):_ -> Just $ fromInteger i+ [] -> Nothing
+ src/Yesod/Core/Class/Breadcrumbs.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Core.Class.Breadcrumbs where++import Yesod.Core.Handler+import Yesod.Routes.Class+import Data.Text (Text)++-- | 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).+class YesodBreadcrumbs site where+ -- | Returns the title and the parent resource, if available. If you return+ -- a 'Nothing', then this is considered a top-level page.+ breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))++-- | Gets the title of the current page and the hierarchy of parent pages,+-- along with their respective titles.+breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])+breadcrumbs = do+ x <- getCurrentRoute+ case x of+ Nothing -> return ("Not found", [])+ Just y -> do+ (title, next) <- breadcrumb y+ z <- go [] next+ return (title, z)+ where+ go back Nothing = return back+ go back (Just this) = do+ (title, next) <- breadcrumb this+ go ((this, title) : back) next
+ src/Yesod/Core/Class/Dispatch.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Core.Class.Dispatch where++import qualified Network.Wai as W+import Yesod.Core.Types+import Yesod.Core.Content (ToTypedContent (..))+import Yesod.Core.Handler (sendWaiApplication)+import Yesod.Core.Class.Yesod++-- | This class is automatically instantiated when you use the template haskell+-- mkYesod function. You should never need to deal with it directly.+class Yesod site => YesodDispatch site where+ yesodDispatch :: YesodRunnerEnv site -> W.Application++class YesodSubDispatch sub master where+ yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application++instance YesodSubDispatch WaiSubsite master where+ yesodSubDispatch YesodSubRunnerEnv {..} = app+ where+ WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv++instance YesodSubDispatch WaiSubsiteWithAuth master where+ yesodSubDispatch YesodSubRunnerEnv {..} req =+ ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req+ where+ route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []+ WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv+ handlert = sendWaiApplication set++subHelper+ :: ToTypedContent content+ => SubHandlerFor child master content+ -> YesodSubRunnerEnv child master+ -> Maybe (Route child)+ -> W.Application+subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =+ ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)+ where+ handler = fmap toTypedContent $ HandlerFor $ \hd ->+ let rhe = handlerEnv hd+ rhe' = rhe+ { rheRoute = mroute+ , rheChild = ysreGetSub $ yreSite ysreParentEnv+ , rheRouteToMaster = ysreToParentRoute+ }+ in f hd { handlerEnv = rhe' }
+ src/Yesod/Core/Class/Handler.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Yesod.Core.Class.Handler+ ( MonadHandler (..)+ , MonadWidget (..)+ , liftHandlerT+ , liftWidgetT+ ) where++import Yesod.Core.Types+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Class (lift)+import Data.Conduit.Internal (Pipe, ConduitM)++import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Except ( ExceptT )+import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )+import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++-- FIXME should we just use MonadReader instances instead?+class (MonadResource m, MonadLogger m) => MonadHandler m where+ type HandlerSite m+ type SubHandlerSite m+ liftHandler :: HandlerFor (HandlerSite m) a -> m a+ liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a++liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a+liftHandlerT = liftHandler+{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}++instance MonadHandler (HandlerFor site) where+ type HandlerSite (HandlerFor site) = site+ type SubHandlerSite (HandlerFor site) = site+ liftHandler = id+ {-# INLINE liftHandler #-}+ liftSubHandler (SubHandlerFor f) = HandlerFor f+ {-# INLINE liftSubHandler #-}++instance MonadHandler (SubHandlerFor sub master) where+ type HandlerSite (SubHandlerFor sub master) = master+ type SubHandlerSite (SubHandlerFor sub master) = sub+ liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd+ { handlerEnv =+ let rhe = handlerEnv hd+ in rhe+ { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)+ , rheRouteToMaster = id+ , rheChild = rheSite rhe+ }+ }+ {-# INLINE liftHandler #-}+ liftSubHandler = id+ {-# INLINE liftSubHandler #-}++instance MonadHandler (WidgetFor site) where+ type HandlerSite (WidgetFor site) = site+ type SubHandlerSite (WidgetFor site) = site+ liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler+ {-# INLINE liftHandler #-}+ liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler+ {-# INLINE liftSubHandler #-}++#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GO(ExceptT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX++class MonadHandler m => MonadWidget m where+ liftWidget :: WidgetFor (HandlerSite m) a -> m a+instance MonadWidget (WidgetFor site) where+ liftWidget = id+ {-# INLINE liftWidget #-}++liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a+liftWidgetT = liftWidget+{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}++#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GO(ExceptT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX
+ src/Yesod/Core/Class/Yesod.hs view
@@ -0,0 +1,920 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Core.Class.Yesod where++import Yesod.Core.Content+import Yesod.Core.Handler++import Yesod.Routes.Class++import Data.ByteString.Builder (Builder)+import Data.Text.Encoding (encodeUtf8Builder)+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, logErrorS)+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', nub)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+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.Parse (lbsBackEnd,+ tempFileBackEnd)+import Network.Wai.Logger (ZonedDate, clockDateCacher)+import System.Log.FastLogger+import Text.Blaze (customAttribute, textTag,+ toValue, (!),+ preEscapedToMarkup)+import qualified Text.Blaze.Html5 as TBH+import Text.Hamlet+import Text.Julius+import qualified Web.ClientSession as CS+import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,+ sameSiteStrict, SameSiteOption, defaultSetCookie)+import Yesod.Core.Types+import Yesod.Core.Internal.Session+import Yesod.Core.Widget+import Data.CaseInsensitive (CI)+import qualified Network.Wai.Request+import Data.IORef++-- | 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: 'guessApproot'. If you know your application root+ -- statically, it will be more efficient and more reliable to instead use+ -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute+ -- URLs, you can use 'ApprootRelative' instead.+ --+ -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.+ approot :: Approot site+ approot = guessApproot++ -- | Output error response pages.+ --+ -- Default value: 'defaultErrorHandler'.+ errorHandler :: ErrorResponse -> HandlerFor site TypedContent+ errorHandler = defaultErrorHandler++ -- | Applies some form of layout to the contents of a page.+ defaultLayout :: WidgetFor site () -> HandlerFor site Html+ defaultLayout w = do+ p <- widgetToPageContent w+ msgs <- getMessages+ withUrlRenderer [hamlet|+ $newline never+ $doctype 5+ <html>+ <head>+ <title>#{pageTitle p}+ ^{pageHead p}+ <body>+ $forall (status, msg) <- msgs+ <p class="message #{status}">#{msg}+ ^{pageBody p}+ |]++ -- | Override the rendering function for a particular URL and query string+ -- parameters. One use case for this is to offload static hosting to a+ -- different domain name to avoid sending cookies.+ --+ -- For backward compatibility default implementation is in terms of+ -- 'urlRenderOverride', probably ineffective+ --+ -- Since 1.4.23+ urlParamRenderOverride :: site+ -> Route site+ -> [(T.Text, T.Text)] -- ^ query string+ -> Maybe Builder+ urlParamRenderOverride _ _ _ = 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?+ -> HandlerFor site 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 -> HandlerFor site 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' =+ encodeUtf8Builder 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+ -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))+ addStaticContent _ _ _ = return Nothing++ -- | Maximum allowed length of the request body, in bytes.+ -- This method may be ignored if 'maximumContentLengthIO' is overridden.+ --+ -- If @Nothing@, no maximum is applied.+ --+ -- Default: 2 megabytes.+ maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64+ maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes++ -- | Maximum allowed length of the request body, in bytes. This is similar+ -- to 'maximumContentLength', but the result lives in @IO@. This allows+ -- you to dynamically change the maximum file size based on some external+ -- source like a database or an @IORef@.+ --+ -- The default implementation uses 'maximumContentLength'. Future version of yesod will+ -- remove 'maximumContentLength' and use this method exclusively.+ --+ -- @since 1.6.13+ maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)+ maximumContentLengthIO a b = pure $ maximumContentLength a b++ -- | 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'.+ jsLoader :: site -> ScriptLoadPosition site+ jsLoader _ = BottomOfBody++ -- | Default attributes to put on the JavaScript <script> tag+ -- generated for julius files+ jsAttributes :: site -> [(Text, Text)]+ jsAttributes _ = []++ -- | 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 _ = 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 'defaultShouldLogIO' function.+ --+ -- Since 1.2.4+ shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool+ shouldLogIO _ = defaultShouldLogIO++ -- | 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 => HandlerFor site res -> HandlerFor site 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 #-}++ -- | Convert a title and HTML snippet into a 'Widget'. Used+ -- primarily for wrapping up error messages for better display.+ --+ -- @since 1.4.30+ defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()+ defaultMessageWidget title body = do+ setTitle title+ toWidget+ [hamlet|+ <h1>#{title}+ ^{body}+ |]++-- | 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+defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool+defaultShouldLogIO _ level = return $ level >= LevelInfo++-- | Default implementation of 'yesodMiddleware'. Adds the response header+-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and+-- performs authorization checks.+--+-- Since 1.2.0+defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res+defaultYesodMiddleware handler = do+ addHeader "Vary" "Accept, Accept-Language"+ addHeader "X-XSS-Protection" "1; mode=block"+ 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++-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site+-- requests, and with cross-site top-level navigations.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+laxSameSiteSessions = sameSiteSession sameSiteLax++-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Strict. With the Strict setting, the cookie will only be+-- sent with same-site requests.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+strictSameSiteSessions = sameSiteSession sameSiteStrict++sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+sameSiteSession s = (fmap . fmap) secureSessionCookies+ where+ sameSite cookie = cookie { setCookieSameSite = Just s }+ secureSessionCookies = customizeSessionCookies sameSite++-- | 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 SSL-stripping man-in-the-middle attacks. It is only effective if+-- a secure connection has already been made; Strict-Transport-Security+-- headers are ignored over HTTP.+--+-- Since 1.4.7+sslOnlyMiddleware :: Int -- ^ minutes+ -> HandlerFor site res+ -> HandlerFor site 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 => HandlerFor site ()+authorizationCheck = 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' ->+ 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 => HandlerFor site res -> HandlerFor site res+defaultCsrfCheckMiddleware handler =+ 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 :: HandlerFor site res+ -> HandlerFor site 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.+ -> HandlerFor site res+csrfCheckMiddleware handler shouldCheckFn headerName paramName = do+ shouldCheck <- shouldCheckFn+ when shouldCheck (checkCsrfHeaderOrParam headerName paramName)+ handler++-- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'.+--+-- The cookie's path is set to @/@, making it valid for your whole website.+--+-- Since 1.4.14+defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res+defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler++-- | 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".+--+-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.+--+-- Since 1.4.14+csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res+csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler++-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.+--+-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".+--+-- You can chain this middleware together with other middleware like so:+--+-- @+-- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'+-- @+--+-- or:+--+-- @+-- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app+-- @+--+-- Since 1.4.14+defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res+defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware++-- | Convert a widget to a 'PageContent'.+widgetToPageContent :: Yesod site+ => WidgetFor site ()+ -> HandlerFor site (PageContent (Route site))+widgetToPageContent w = HandlerFor $ \hd -> do+ master <- unHandlerFor getYesod hd+ ref <- newIORef mempty+ unWidgetFor w WidgetData+ { wdRef = ref+ , wdHandler = hd+ }+ GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref+ let title = maybe mempty unTitle mTitle+ scripts = runUniqueList scripts'+ stylesheets = runUniqueList stylesheets'++ flip unHandlerFor hd $ do+ 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}" *{jsAttributes master}>+ $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+ )++ runUniqueList :: Eq x => UniqueList x -> [x]+ runUniqueList (UniqueList x) = nub $ x []++-- | The default error handler for 'errorHandler'.+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent+defaultErrorHandler NotFound = selectRep $ do+ provideRep $ defaultLayout $ do+ r <- waiRequest+ let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r+ defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]+ provideRep $ return $ object ["message" .= ("Not Found" :: Text)]+ provideRep $ return $ ("Not Found" :: Text)++-- For API requests.+-- For a user with a browser,+-- if you specify an authRoute the user will be redirected there and+-- this page will not be shown.+defaultErrorHandler NotAuthenticated = selectRep $ do+ provideRep $ defaultLayout $ defaultMessageWidget+ "Not logged in"+ [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|]++ provideRep $ do+ -- 401 *MUST* include a WWW-Authenticate header+ -- however, there is no standard to indicate a redirection+ --+ -- change this to Basic or Digest if you allow those forms of authentications+ addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""++ -- The client will just use the authentication_url in the JSON+ site <- getYesod+ rend <- getUrlRender+ let apair u = ["authentication_url" .= rend u]+ content = maybe [] apair (authRoute site)+ return $ object $ ("message" .= ("Not logged in"::Text)):content+ provideRep $ return $ ("Not logged in" :: Text)++defaultErrorHandler (PermissionDenied msg) = selectRep $ do+ provideRep $ defaultLayout $ defaultMessageWidget+ "Permission Denied"+ [hamlet|<p>#{msg}|]+ provideRep $+ return $ object ["message" .= ("Permission Denied. " <> msg)]+ provideRep $ return $ "Permission Denied. " <> msg++defaultErrorHandler (InvalidArgs ia) = selectRep $ do+ provideRep $ defaultLayout $ defaultMessageWidget+ "Invalid Arguments"+ [hamlet|+ <ul>+ $forall msg <- ia+ <li>#{msg}+ |]+ provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]+ provideRep $ return $ ("Invalid Arguments: " <> T.intercalate " " ia)++defaultErrorHandler (InternalError e) = do+ $logErrorS "yesod-core" e+ selectRep $ do+ provideRep $ defaultLayout $ defaultMessageWidget+ "Internal Server Error"+ [hamlet|<pre>#{e}|]+ provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]+ provideRep $ return $ "Internal Server Error: " <> e++defaultErrorHandler (BadMethod m) = selectRep $ do+ provideRep $ defaultLayout $ defaultMessageWidget+ "Method Not Supported"+ [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]+ provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]+ provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m++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++-- | Default formatting for log messages. When you use+-- the template haskell logging functions for to log with information+-- about the source location, that information will be appended to+-- the end of the log. When you use the non-TH logging functions,+-- like 'logDebugN', this function does not include source+-- information. This currently works by checking to see if the+-- package name is the string \"\<unknown\>\". This is a hack,+-- but it removes some of the visual clutter from non-TH logs.+--+-- Since 1.4.10+formatLogMessage :: IO ZonedDate+ -> Loc+ -> LogSource+ -> LogLevel+ -> LogStr -- ^ message+ -> IO LogStr+formatLogMessage getdate loc src level msg = do+ now <- getdate+ return $ mempty+ `mappend` toLogStr now+ `mappend` " ["+ `mappend` (case level of+ LevelOther t -> toLogStr t+ _ -> toLogStr $ drop 5 $ show level)+ `mappend` (if T.null src+ then mempty+ else "#" `mappend` toLogStr src)+ `mappend` "] "+ `mappend` msg+ `mappend` sourceSuffix+ `mappend` "\n"+ where+ sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty+ `mappend` " @("+ `mappend` toLogStr (fileLocationToString loc)+ `mappend` ")"++-- | Customize the cookies used by the session backend. You may+-- use this function on your definition of 'makeSessionBackend'.+--+-- For example, you could set the cookie domain so that it+-- would work across many subdomains:+--+-- @+-- makeSessionBackend site =+-- (fmap . fmap) (customizeSessionCookies addDomain) ...+-- where+-- addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }+-- @+--+-- Default: Do not customize anything ('id').+customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)+customizeSessionCookies customizeCookie backend = backend'+ where+ customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie)+ customizeHeader other = other+ customizeSaveSession = (fmap . fmap . fmap) customizeHeader+ backend' =+ backend {+ sbLoadSession = \req ->+ second customizeSaveSession `fmap` sbLoadSession backend req+ }+++defaultClientSessionBackend :: Int -- ^ minutes+ -> FilePath -- ^ key file+ -> IO SessionBackend+defaultClientSessionBackend minutes fp = do+ key <- CS.getKey fp+ (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)+ return $ clientSessionBackend key getCachedDate++-- | Create a @SessionBackend@ which reads the session key from the named+-- environment variable.+--+-- This can be useful if:+--+-- 1. You can't rely on a persistent file system (e.g. Heroku)+-- 2. Your application is open source (e.g. you can't commit the key)+--+-- By keeping a consistent value in the environment variable, your users will+-- have consistent sessions without relying on the file system.+--+-- Note: A suitable value should only be obtained in one of two ways:+--+-- 1. Run this code without the variable set, a value will be generated and+-- printed on @/dev/stdout/@+-- 2. Use @clientsession-generate@+--+-- Since 1.4.5+envClientSessionBackend :: Int -- ^ minutes+ -> String -- ^ environment variable name+ -> IO SessionBackend+envClientSessionBackend minutes name = do+ key <- CS.getKeyEnv name+ (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes+ return $ clientSessionBackend key getCachedDate++minToSec :: (Integral a, Num b) => a -> b+minToSec minutes = fromIntegral (minutes * 60)++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 :: CS.Key -- ^ The encryption key+ -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+ -> SessionBackend+clientSessionBackend key getCachedDate =+ SessionBackend {+ sbLoadSession = loadClientSession key getCachedDate "_SESSION"+ }++justSingleton :: a -> [Maybe a] -> a+justSingleton d = just . catMaybes+ where+ just [s] = s+ just _ = d++loadClientSession :: CS.Key+ -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+ -> S8.ByteString -- ^ session name+ -> W.Request+ -> IO (SessionMap, SaveSession)+loadClientSession key getCachedDate sessionName req = load+ where+ load = do+ date <- getCachedDate+ return (sess date, save date)+ sess date = justSingleton Map.empty $ do+ raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"]+ val <- [v | (k, v) <- parseCookies raw, k == sessionName]+ let host = "" -- fixme, properly lock sessions to client address+ return $ decodeClientSession key date host val+ save date sess' = do+ -- We should never cache the IV! Be careful!+ iv <- liftIO CS.randomIV+ return [AddCookie defaultSetCookie+ { setCookieName = sessionName+ , setCookieValue = encodeClientSession key iv date host sess'+ , setCookiePath = Just "/"+ , setCookieExpires = Just (csdcExpires date)+ , setCookieDomain = Nothing+ , 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 =+ concat+ [ loc_package loc+ , ':' : loc_module loc+ , ' ' : loc_filename loc+ , ':' : line loc+ , ':' : char loc+ ]+ where+ line = show . fst . loc_start+ char = show . snd . loc_start++-- | Guess the approot based on request headers. For more information, see+-- "Network.Wai.Middleware.Approot"+--+-- In the case of headers being unavailable, it falls back to 'ApprootRelative'+--+-- Since 1.4.16+guessApproot :: Approot site+guessApproot = guessApprootOr ApprootRelative++-- | Guess the approot based on request headers, with fall back to the+-- specified 'AppRoot'.+--+-- Since 1.4.16+guessApprootOr :: Approot site -> Approot site+guessApprootOr fallback = ApprootRequest $ \master req ->+ case W.requestHeaderHost req of+ Nothing -> getApprootText fallback master req+ Just host ->+ (if Network.Wai.Request.appearsSecure req+ then "https://"+ else "http://")+ `T.append` TE.decodeUtf8With TEE.lenientDecode host++-- | Get the textual application root from an 'Approot' value.+--+-- Since 1.4.17+getApprootText :: Approot site -> site -> W.Request -> Text+getApprootText ar site req =+ case ar of+ ApprootRelative -> ""+ ApprootStatic t -> t+ ApprootMaster f -> f site+ ApprootRequest f -> f site req
+ src/Yesod/Core/Content.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Core.Content+ ( -- * Content+ Content (..)+ , emptyContent+ , ToContent (..)+ , ToFlushBuilder (..)+ -- * Mime types+ -- ** Data type+ , ContentType+ , typeHtml+ , typePlain+ , typeJson+ , typeXml+ , typeAtom+ , typeRss+ , typeJpeg+ , typePng+ , typeGif+ , typeSvg+ , typeJavascript+ , typeCss+ , typeFlv+ , typeOgv+ , typeOctet+ -- * Utilities+ , simpleContentType+ , contentTypeTypes+ -- * Evaluation strategy+ , DontFullyEvaluate (..)+ -- * Representations+ , TypedContent (..)+ , ToTypedContent (..)+ , HasContentType (..)+ -- ** Specific content types+ , RepHtml+ , RepJson (..)+ , RepPlain (..)+ , RepXml (..)+ -- ** Smart constructors+ , repJson+ , repPlain+ , repXml+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Text.Lazy (Text, pack)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8Builder)+import qualified Data.Text.Lazy as TL+import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)+import Text.Hamlet (Html)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)+import Control.Monad (liftM)+import Control.Monad.Trans.Resource (ResourceT)+import qualified Data.Conduit.Internal as CI++import qualified Data.Aeson as J+import Data.Text.Lazy.Builder (toLazyText)+import Yesod.Core.Types+import Text.Lucius (Css, renderCss)+import Text.Julius (Javascript, unJavascript)+import Data.Word8 (_semicolon, _slash)+import Control.Arrow (second)++-- | Zero-length enumerator.+emptyContent :: Content+emptyContent = ContentBuilder mempty $ Just 0++-- | Anything which can be converted into 'Content'. Most of the time, you will+-- want to use the 'ContentBuilder' constructor. An easier approach will be to use+-- a pre-defined 'toContent' function, such as converting your data into a lazy+-- bytestring and then calling 'toContent' on that.+--+-- Please note that the built-in instances for lazy data structures ('String',+-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include+-- the content length for the 'ContentBuilder' constructor.+class ToContent a where+ toContent :: a -> Content++instance ToContent Content where+ toContent = id+instance ToContent Builder where+ toContent = flip ContentBuilder Nothing+instance ToContent B.ByteString where+ toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs+instance ToContent L.ByteString where+ toContent = flip ContentBuilder Nothing . lazyByteString+instance ToContent T.Text where+ toContent = toContent . encodeUtf8Builder+instance ToContent Text where+ toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks+instance ToContent String where+ toContent = toContent . stringUtf8+instance ToContent Html where+ toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing+instance ToContent () where+ toContent () = toContent B.empty+instance ToContent (ContentType, Content) where+ toContent = snd+instance ToContent TypedContent where+ toContent (TypedContent _ c) = c++instance ToContent Css where+ toContent = toContent . renderCss+instance ToContent Javascript where+ toContent = toContent . toLazyText . unJavascript++instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where+ toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)++instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where+ toContent src = ContentSource $ mapOutput toFlushBuilder src+instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where+ toContent (CI.SealedConduitT src) = toContent src++-- | A class for all data which can be sent in a streaming response. Note that+-- for textual data, instances must use UTF-8 encoding.+--+-- Since 1.2.0+class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder+instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id+instance ToFlushBuilder Builder where toFlushBuilder = Chunk+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)+instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8+instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8+instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder+instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder++repJson :: ToContent a => a -> RepJson+repJson = RepJson . toContent++repPlain :: ToContent a => a -> RepPlain+repPlain = RepPlain . toContent++repXml :: ToContent a => a -> RepXml+repXml = RepXml . toContent++class ToTypedContent a => HasContentType a where+ getContentType :: Monad m => m a -> ContentType++instance HasContentType RepJson where+ getContentType _ = typeJson+deriving instance ToContent RepJson++instance HasContentType RepPlain where+ getContentType _ = typePlain+deriving instance ToContent RepPlain++instance HasContentType RepXml where+ getContentType _ = typeXml+deriving instance ToContent RepXml+++typeHtml :: ContentType+typeHtml = "text/html; charset=utf-8"++typePlain :: ContentType+typePlain = "text/plain; charset=utf-8"++typeJson :: ContentType+typeJson = "application/json; charset=utf-8"++typeXml :: ContentType+typeXml = "text/xml"++typeAtom :: ContentType+typeAtom = "application/atom+xml"++typeRss :: ContentType+typeRss = "application/rss+xml"++typeJpeg :: ContentType+typeJpeg = "image/jpeg"++typePng :: ContentType+typePng = "image/png"++typeGif :: ContentType+typeGif = "image/gif"++typeSvg :: ContentType+typeSvg = "image/svg+xml"++typeJavascript :: ContentType+typeJavascript = "text/javascript; charset=utf-8"++typeCss :: ContentType+typeCss = "text/css; charset=utf-8"++typeFlv :: ContentType+typeFlv = "video/x-flv"++typeOgv :: ContentType+typeOgv = "video/ogg"++typeOctet :: ContentType+typeOctet = "application/octet-stream"++-- | Removes \"extra\" information at the end of a content type string. In+-- particular, removes everything after the semicolon, if present.+--+-- For example, \"text/html; charset=utf-8\" is commonly used to specify the+-- character encoding for HTML data. This function would return \"text/html\".+simpleContentType :: ContentType -> ContentType+simpleContentType = fst . B.break (== _semicolon)++-- | Give just the media types as a pair.+--+-- For example, \"text/html; charset=utf-8\" returns ("text", "html")+contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)+contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType+ where+ tailEmpty x = if B.null x then "" else B.tail x++instance HasContentType a => HasContentType (DontFullyEvaluate a) where+ getContentType = getContentType . liftM unDontFullyEvaluate++instance ToContent a => ToContent (DontFullyEvaluate a) where+ toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a++instance ToContent J.Value where+ toContent = flip ContentBuilder Nothing+ . J.fromEncoding+ . J.toEncoding++instance ToContent J.Encoding where+ toContent = flip ContentBuilder Nothing . J.fromEncoding++instance HasContentType J.Value where+ getContentType _ = typeJson++instance HasContentType J.Encoding where+ getContentType _ = typeJson++instance HasContentType Html where+ getContentType _ = typeHtml++instance HasContentType Text where+ getContentType _ = typePlain++instance HasContentType T.Text where+ getContentType _ = typePlain++instance HasContentType Css where+ getContentType _ = typeCss++instance HasContentType Javascript where+ getContentType _ = typeJavascript++-- | Any type which can be converted to 'TypedContent'.+--+-- Since 1.2.0+class ToContent a => ToTypedContent a where+ toTypedContent :: a -> TypedContent++instance ToTypedContent TypedContent where+ toTypedContent = id+instance ToTypedContent () where+ toTypedContent () = TypedContent typePlain (toContent ())+instance ToTypedContent (ContentType, Content) where+ toTypedContent (ct, content) = TypedContent ct content+instance ToTypedContent RepJson where+ toTypedContent (RepJson c) = TypedContent typeJson c+instance ToTypedContent RepPlain where+ toTypedContent (RepPlain c) = TypedContent typePlain c+instance ToTypedContent RepXml where+ toTypedContent (RepXml c) = TypedContent typeXml c+instance ToTypedContent J.Value where+ toTypedContent v = TypedContent typeJson (toContent v)+instance ToTypedContent J.Encoding where+ toTypedContent e = TypedContent typeJson (toContent e)+instance ToTypedContent Html where+ toTypedContent h = TypedContent typeHtml (toContent h)+instance ToTypedContent T.Text where+ toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent [Char] where+ toTypedContent = toTypedContent . pack+instance ToTypedContent Text where+ toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where+ toTypedContent (DontFullyEvaluate a) =+ let TypedContent ct c = toTypedContent a+ in TypedContent ct (ContentDontEvaluate c)++instance ToTypedContent Css where+ toTypedContent = TypedContent typeCss . toContent+instance ToTypedContent Javascript where+ toTypedContent = TypedContent typeJavascript . toContent
+ src/Yesod/Core/Dispatch.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Yesod.Core.Dispatch+ ( -- * Quasi-quoted routing+ parseRoutes+ , parseRoutesNoCheck+ , parseRoutesFile+ , parseRoutesFileNoCheck+ , mkYesod+ , mkYesodWith+ -- ** More fine-grained+ , mkYesodData+ , mkYesodSubData+ , mkYesodDispatch+ , mkYesodSubDispatch+ -- *** Helpers+ , getGetMaxExpires+ -- ** Path pieces+ , PathPiece (..)+ , PathMultiPiece (..)+ , Texts+ -- * Convert to WAI+ , toWaiApp+ , toWaiAppPlain+ , toWaiAppYre+ , warp+ , warpDebug+ , warpEnv+ , mkDefaultMiddlewares+ , defaultMiddlewaresNoLogging+ -- * WAI subsites+ , WaiSubsite (..)+ , WaiSubsiteWithAuth (..)+ ) where++import Prelude hiding (exp)+import Yesod.Core.Internal.TH+import Language.Haskell.TH.Syntax (qLocation)++import Web.PathPieces++import qualified Network.Wai as W++import Data.ByteString.Lazy.Char8 ()++import Data.Text (Text)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Builder (byteString, toLazyByteString)+import Network.HTTP.Types (status301, status307)+import Yesod.Routes.Parse+import Yesod.Core.Types+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Internal.Run+import Text.Read (readMaybe)+import System.Environment (getEnvironment)+import qualified System.Random as Random+import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)+import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)++import Network.Wai.Middleware.Autohead+import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.MethodOverride++import qualified Network.Wai.Handler.Warp+import System.Log.FastLogger+import Control.Monad.Logger+import Control.Monad (when)+import qualified Paths_yesod_core+import Data.Version (showVersion)++-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. This function will provide no middlewares; if you want commonly+-- used middlewares, please use 'toWaiApp'.+toWaiAppPlain :: YesodDispatch site => site -> IO W.Application+toWaiAppPlain site = do+ logger <- makeLogger site+ sb <- makeSessionBackend site+ getMaxExpires <- getGetMaxExpires+ return $ toWaiAppYre YesodRunnerEnv+ { yreLogger = logger+ , yreSite = site+ , yreSessionBackend = sb+ , yreGen = defaultGen+ , yreGetMaxExpires = getMaxExpires+ }++defaultGen :: IO Int+defaultGen = Random.getStdRandom Random.next++-- | Pure low level function to construct WAI application. Usefull+-- when you need not standard way to run your app, or want to embed it+-- inside another app.+--+-- @since 1.4.29+toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application+toWaiAppYre yre req =+ case cleanPath site $ W.pathInfo req of+ Left pieces -> sendRedirect site pieces req+ Right pieces -> yesodDispatch yre req+ { W.pathInfo = pieces+ }+ where+ site = yreSite yre+ sendRedirect :: Yesod master => master -> [Text] -> W.Application+ sendRedirect y segments' env sendResponse =+ sendResponse $ W.responseLBS status+ [ ("Content-Type", "text/plain")+ , ("Location", BL.toStrict $ toLazyByteString dest')+ ] "Redirecting"+ where+ -- Ensure that non-GET requests get redirected correctly. See:+ -- https://github.com/yesodweb/yesod/issues/951+ status+ | W.requestMethod env == "GET" = status301+ | otherwise = status307++ dest = joinPath y (resolveApproot y env) segments' []+ dest' =+ if S.null (W.rawQueryString env)+ then dest+ else dest `mappend`+ byteString (W.rawQueryString env)++-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This+-- set may change with future releases, but currently covers:+--+-- * Logging+--+-- * GZIP compression+--+-- * Automatic HEAD method handling+--+-- * Request method override with the _method query string parameter+--+-- * Accept header override with the _accept query string parameter+toWaiApp :: YesodDispatch site => site -> IO W.Application+toWaiApp site = do+ logger <- makeLogger site+ toWaiAppLogger logger site++toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application+toWaiAppLogger logger site = do+ sb <- makeSessionBackend site+ getMaxExpires <- getGetMaxExpires+ let yre = YesodRunnerEnv+ { yreLogger = logger+ , yreSite = site+ , yreSessionBackend = sb+ , yreGen = defaultGen+ , yreGetMaxExpires = getMaxExpires+ }+ messageLoggerSource+ site+ logger+ $(qLocation >>= liftLoc)+ "yesod-core"+ LevelInfo+ (toLogStr ("Application launched" :: S.ByteString))+ middleware <- mkDefaultMiddlewares logger+ return $ middleware $ toWaiAppYre yre++-- | A convenience method to run an application using the Warp webserver on the+-- specified port. Automatically calls 'toWaiApp'. Provides a default set of+-- middlewares. This set may change at any point without a breaking version+-- number. Currently, it includes:+--+-- If you need more fine-grained control of middlewares, please use 'toWaiApp'+-- directly.+--+-- Since 1.2.0+warp :: YesodDispatch site => Int -> site -> IO ()+warp port site = do+ logger <- makeLogger site+ toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (+ Network.Wai.Handler.Warp.setPort port $+ Network.Wai.Handler.Warp.setServerName serverValue $+ Network.Wai.Handler.Warp.setOnException (\_ e ->+ when (shouldLog' e) $+ messageLoggerSource+ site+ logger+ $(qLocation >>= liftLoc)+ "yesod-core"+ LevelError+ (toLogStr $ "Exception from Warp: " ++ show e))+ Network.Wai.Handler.Warp.defaultSettings)+ where+ shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException++serverValue :: S8.ByteString+serverValue = S8.pack $ concat+ [ "Warp/"+ , Network.Wai.Handler.Warp.warpVersion+ , " + Yesod/"+ , showVersion Paths_yesod_core.version+ , " (core)"+ ]++-- | A default set of middlewares.+--+-- Since 1.2.0+mkDefaultMiddlewares :: Logger -> IO W.Middleware+mkDefaultMiddlewares logger = do+ logWare <- mkRequestLogger def+ { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger+ , outputFormat = Apache FromSocket+ }+ return $ logWare . defaultMiddlewaresNoLogging++-- | All of the default middlewares, excluding logging.+--+-- Since 1.2.12+defaultMiddlewaresNoLogging :: W.Middleware+defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride++-- | Deprecated synonym for 'warp'.+warpDebug :: YesodDispatch site => Int -> site -> IO ()+warpDebug = warp+{-# DEPRECATED warpDebug "Please use warp instead" #-}++-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It+-- reads port information from the PORT environment variable, as used by tools+-- such as Keter and the FP Complete School of Haskell.+--+-- Note that the exact behavior of this function may be modified slightly over+-- time to work correctly with external tools, without a change to the type+-- signature.+warpEnv :: YesodDispatch site => site -> IO ()+warpEnv site = do+ env <- getEnvironment+ case lookup "PORT" env of+ Nothing -> error "warpEnv: no PORT environment variable found"+ Just portS ->+ case readMaybe portS of+ Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS+ Just port -> warp port site++-- | Default constructor for 'yreGetMaxExpires' field. Low level+-- function for simple manual construction of 'YesodRunnerEnv'.+--+-- @since 1.4.29+getGetMaxExpires :: IO (IO Text)+getGetMaxExpires = mkAutoUpdate defaultUpdateSettings+ { updateAction = getCurrentMaxExpiresRFC1123+ , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day+ }
+ src/Yesod/Core/Handler.hs view
@@ -0,0 +1,1686 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+---------------------------------------------------------+--+-- Module : Yesod.Handler+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : stable+-- Portability : portable+--+-- Define Handler stuff.+--+---------------------------------------------------------+module Yesod.Core.Handler+ ( -- * Handler monad+ HandlerT+ , HandlerFor+ -- ** Read information from handler+ , getYesod+ , getsYesod+ , getUrlRender+ , getUrlRenderParams+ , getPostParams+ , getCurrentRoute+ , getRequest+ , waiRequest+ , runRequestBody+ , rawRequestBody+ -- ** Request information+ -- *** Request datatype+ , RequestBodyContents+ , YesodRequest (..)+ , FileInfo+ , fileName+ , fileContentType+ , fileSource+ , fileSourceByteString+ , fileMove+ -- *** Convenience functions+ , languages+ -- *** Lookup parameters+ , lookupGetParam+ , lookupPostParam+ , lookupCookie+ , lookupFile+ , lookupHeader+ -- **** Lookup authentication data+ , lookupBasicAuth+ , lookupBearerAuth+ -- **** Multi-lookup+ , lookupGetParams+ , lookupPostParams+ , lookupCookies+ , lookupFiles+ , lookupHeaders+ -- * Responses+ -- ** Pure+ , respond+ -- ** Streaming+ , respondSource+ , sendChunk+ , sendFlush+ , sendChunkBS+ , sendChunkLBS+ , sendChunkText+ , sendChunkLazyText+ , sendChunkHtml+ -- ** Redirecting+ , RedirectUrl (..)+ , redirect+ , redirectWith+ , redirectToPost+ , Fragment(..)+ -- ** Errors+ , notFound+ , badMethod+ , notAuthenticated+ , permissionDenied+ , permissionDeniedI+ , invalidArgs+ , invalidArgsI+ -- ** Short-circuit responses.+ , sendFile+ , sendFilePart+ , sendResponse+ , sendResponseStatus+ -- ** Type specific response with custom status+ , sendStatusJSON+ , sendResponseCreated+ , sendResponseNoContent+ , sendWaiResponse+ , sendWaiApplication+ , sendRawResponse+ , sendRawResponseNoConduit+ , notModified+ -- * Different representations+ -- $representations+ , selectRep+ , provideRep+ , provideRepType+ , ProvidedRep+ -- * Setting headers+ , setCookie+ , getExpires+ , deleteCookie+ , addHeader+ , setHeader+ , replaceOrAddHeader+ , setLanguage+ , addContentDispositionFileName+ -- ** Content caching and expiration+ , cacheSeconds+ , neverExpires+ , alreadyExpired+ , expiresAt+ , setEtag+ , setWeakEtag+ -- * Session+ , SessionMap+ , lookupSession+ , lookupSessionBS+ , getSession+ , setSession+ , setSessionBS+ , deleteSession+ , clearSession+ -- ** Ultimate destination+ , setUltDest+ , setUltDestCurrent+ , setUltDestReferer+ , redirectUltDest+ , clearUltDest+ -- ** Messages+ , addMessage+ , addMessageI+ , getMessages+ , setMessage+ , setMessageI+ , getMessage+ -- * Subsites+ , SubHandlerFor+ , getSubYesod+ , getRouteToParent+ , getSubCurrentRoute+ -- * Helpers for specific content+ -- ** Hamlet+ , hamletToRepHtml+ , giveUrlRenderer+ , withUrlRenderer+ -- ** Misc+ , newIdent+ -- * Lifting+ , handlerToIO+ , forkHandler+ -- * i18n+ , getMessageRender+ -- * Per-request caching+ , cached+ , cacheGet+ , cacheSet+ , cachedBy+ , cacheByGet+ , cacheBySet+ -- * AJAX CSRF protection++ -- $ajaxCSRFOverview++ -- ** Setting CSRF Cookies+ , setCsrfCookie+ , setCsrfCookieWithCookie+ , defaultCsrfCookieName+ -- ** Looking up CSRF Headers+ , checkCsrfHeaderNamed+ , hasValidCsrfHeaderNamed+ , defaultCsrfHeaderName+ -- ** Looking up CSRF POST Parameters+ , hasValidCsrfParamNamed+ , checkCsrfParamNamed+ , defaultCsrfParamName+ -- ** Checking CSRF Headers or POST Parameters+ , checkCsrfHeaderOrParam+ ) where++import Data.Time (UTCTime, addUTCTime,+ getCurrentTime)+import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,+ mkFileInfoLBS, mkFileInfoSource)+++import Control.Applicative ((<|>))+import qualified Data.CaseInsensitive as CI+import Control.Exception (evaluate, SomeException, throwIO)+import Control.Exception (handle)++import Control.Monad (void, liftM, unless)+import qualified Control.Monad.Trans.Writer as Writer++import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO)++import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Network.Wai.Middleware.HttpAuth+ ( extractBasicAuth, extractBearerAuth )+import Control.Monad.Trans.Class (lift)++import Data.Aeson (ToJSON(..))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Lazy as TL+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Hamlet (Html, HtmlUrl, hamlet)++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HM++import Data.ByteArray (constEq)++import Control.Arrow ((***))+import qualified Data.ByteString.Char8 as S8+import Data.Monoid (Endo (..))+import Data.Text (Text)+import qualified Network.Wai.Parse as NWP+import Text.Shakespeare.I18N (RenderMessage (..))+import Web.Cookie (SetCookie (..), defaultSetCookie)+import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))+import Yesod.Core.Internal.Util (formatRFC1123)+import Text.Blaze.Html (preEscapedToHtml, toHtml)++import qualified Data.IORef as I+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Typeable (Typeable)+import Web.PathPieces (PathPiece(..))+import Yesod.Core.Class.Handler+import Yesod.Core.Types+import Yesod.Routes.Class (Route)+import Data.ByteString.Builder (Builder)+import Data.CaseInsensitive (CI, original)+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)+import qualified System.PosixCompat.Files as PC+import Conduit ((.|), runConduit, sinkLazy)+import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)+import qualified Yesod.Core.TypeCache as Cache+import qualified Data.Word8 as W8+import qualified Data.Foldable as Fold+import Control.Monad.Logger (MonadLogger, logWarnS)++type HandlerT site (m :: * -> *) = HandlerFor site+{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}++get :: MonadHandler m => m GHState+get = liftHandler $ HandlerFor $ I.readIORef . handlerState++put :: MonadHandler m => GHState -> m ()+put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState++modify :: MonadHandler m => (GHState -> GHState) -> m ()+modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState++tell :: MonadHandler m => Endo [Header] -> m ()+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }++handlerError :: MonadHandler m => HandlerContents -> m a+handlerError = liftIO . throwIO++hcError :: MonadHandler m => ErrorResponse -> m a+hcError = handlerError . HCError++getRequest :: MonadHandler m => m YesodRequest+getRequest = liftHandler $ HandlerFor $ return . handlerRequest++runRequestBody :: MonadHandler m => m RequestBodyContents+runRequestBody = do+ HandlerData+ { handlerEnv = RunHandlerEnv {..}+ , handlerRequest = req+ } <- liftHandler $ HandlerFor return+ let len = W.requestBodyLength $ reqWaiRequest req+ upload = rheUpload len+ x <- get+ case ghsRBC x of+ Just rbc -> return rbc+ Nothing -> do+ rr <- waiRequest+ internalState <- liftResourceT getInternalState+ rbc <- liftIO $ rbHelper upload rr internalState+ put x { ghsRBC = Just rbc }+ return rbc++rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents+rbHelper upload req internalState =+ case upload of+ FileUploadMemory s -> rbHelper' s mkFileInfoLBS req+ FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req+ FileUploadSource s -> rbHelper' s mkFileInfoSource req++rbHelper' :: NWP.BackEnd x+ -> (Text -> Text -> x -> FileInfo)+ -> W.Request+ -> IO ([(Text, Text)], [(Text, FileInfo)])+rbHelper' backend mkFI req =+ (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req+ where+ fix1 = go *** go+ fix2 (x, NWP.FileInfo a' b c)+ | S.null a = Nothing+ | otherwise = Just (go x, mkFI (go a) (go b) c)+ where+ a+ | S.length a' < 2 = a'+ | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'+ | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'+ | otherwise = a'+ go = decodeUtf8With lenientDecode++askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))+askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv++-- | Get the master site application argument.+getYesod :: MonadHandler m => m (HandlerSite m)+getYesod = rheSite <$> askHandlerEnv++-- | Get a specific component of the master site application argument.+-- Analogous to the 'gets' function for operating on 'StateT'.+getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a+getsYesod f = (f . rheSite) <$> askHandlerEnv++-- | Get the URL rendering function.+getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)+getUrlRender = do+ x <- rheRender <$> askHandlerEnv+ return $ flip x []++-- | The URL rendering function with query-string parameters.+getUrlRenderParams+ :: MonadHandler m+ => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)+getUrlRenderParams = rheRender <$> askHandlerEnv++-- | Get all the post parameters passed to the handler. To also get+-- the submitted files (if any), you have to use 'runRequestBody'+-- instead of this function.+--+-- @since 1.4.33+getPostParams+ :: MonadHandler m+ => m [(Text, Text)]+getPostParams = do+ reqBodyContent <- runRequestBody+ return $ fst reqBodyContent++-- | Get the route requested by the user. If this is a 404 response- where the+-- user requested an invalid route- this function will return 'Nothing'.+getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))+getCurrentRoute = rheRoute <$> askHandlerEnv++-- | Returns a function that runs 'HandlerT' actions inside @IO@.+--+-- Sometimes you want to run an inner 'HandlerT' action outside+-- the control flow of an HTTP request (on the outer 'HandlerT'+-- action). For example, you may want to spawn a new thread:+--+-- @+-- getFooR :: Handler RepHtml+-- getFooR = do+-- runInnerHandler <- handlerToIO+-- liftIO $ forkIO $ runInnerHandler $ do+-- /Code here runs inside GHandler but on a new thread./+-- /This is the inner GHandler./+-- ...+-- /Code here runs inside the request's control flow./+-- /This is the outer GHandler./+-- ...+-- @+--+-- Another use case for this function is creating a stream of+-- server-sent events using 'GHandler' actions (see+-- @yesod-eventsource@).+--+-- Most of the environment from the outer 'GHandler' is preserved+-- on the inner 'GHandler', however:+--+-- * The request body is cleared (otherwise it would be very+-- difficult to prevent huge memory leaks).+--+-- * The cache is cleared (see 'CacheKey').+--+-- Changes to the response made inside the inner 'GHandler' are+-- ignored (e.g., session variables, cookies, response headers).+-- This allows the inner 'GHandler' to outlive the outer+-- 'GHandler' (e.g., on the @forkIO@ example above, a response+-- may be sent to the client without killing the new thread).+handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)+handlerToIO =+ HandlerFor $ \oldHandlerData -> do+ -- Take just the bits we need from oldHandlerData.+ let newReq = oldReq { reqWaiRequest = newWaiReq }+ where+ oldReq = handlerRequest oldHandlerData+ oldWaiReq = reqWaiRequest oldReq+ newWaiReq = oldWaiReq { W.requestBody = return mempty+ , W.requestBodyLength = W.KnownLength 0+ }+ oldEnv = handlerEnv oldHandlerData+ newState <- liftIO $ do+ oldState <- I.readIORef (handlerState oldHandlerData)+ return $ oldState { ghsRBC = Nothing+ , ghsIdent = 1+ , ghsCache = mempty+ , ghsCacheBy = mempty+ , ghsHeaders = mempty }++ -- xx From this point onwards, no references to oldHandlerData xx+ liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())++ -- Return GHandler running function.+ return $ \(HandlerFor f) ->+ liftIO $+ runResourceT $ withInternalState $ \resState -> do+ -- The state IORef needs to be created here, otherwise it+ -- will be shared by different invocations of this function.+ newStateIORef <- liftIO (I.newIORef newState)+ let newHandlerData =+ HandlerData+ { handlerRequest = newReq+ , handlerEnv = oldEnv+ , handlerState = newStateIORef+ , handlerResource = resState+ }+ liftIO (f newHandlerData)++-- | forkIO for a Handler (run an action in the background)+--+-- Uses 'handlerToIO', liftResourceT, and resourceForkIO+-- for correctness and efficiency+--+-- @since 1.2.8+forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler+ -> HandlerFor site ()+ -> HandlerFor site ()+forkHandler onErr handler = do+ yesRunner <- handlerToIO+ void $ liftResourceT $ resourceForkIO $+ liftIO $ handle (yesRunner . onErr) (yesRunner handler)++-- | 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+-- technique, which should be the usual use case.+--+-- If you want direct control of the final status code, or need a different+-- status code, please use 'redirectWith'.+redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url -> m a+redirect url = do+ req <- waiRequest+ let status =+ if W.httpVersion req == H.http11+ then H.status303+ else H.status302+ redirectWith status url++-- | Redirect to the given URL with the specified status code.+redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => H.Status+ -> url+ -> m a+redirectWith status url = do+ urlText <- toTextUrl url+ handlerError $ HCRedirect status urlText++ultDestKey :: Text+ultDestKey = "_ULT"++-- | Sets the ultimate destination variable to the given route.+--+-- An ultimate destination is stored in the user session and can be loaded+-- later by 'redirectUltDest'.+setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url+ -> m ()+setUltDest url = do+ urlText <- toTextUrl url+ setSession ultDestKey urlText++-- | Same as 'setUltDest', but uses the current page.+--+-- If this is a 404 handler, there is no current page, and then this call does+-- nothing.+setUltDestCurrent :: MonadHandler m => m ()+setUltDestCurrent = do+ route <- getCurrentRoute+ case route of+ Nothing -> return ()+ Just r -> do+ gets' <- reqGetParams <$> getRequest+ setUltDest (r, gets')++-- | Sets the ultimate destination to the referer request header, if present.+--+-- This function will not overwrite an existing ultdest.+setUltDestReferer :: MonadHandler m => m ()+setUltDestReferer = do+ mdest <- lookupSession ultDestKey+ maybe+ (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)+ (const $ return ())+ mdest+ where+ setUltDestBS = setUltDest . T.pack . S8.unpack++-- | Redirect to the ultimate destination in the user's session. Clear the+-- value from the session.+--+-- The ultimate destination is set with 'setUltDest'.+--+-- This function uses 'redirect', and thus will perform a temporary redirect to+-- a GET request.+redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)+ => url -- ^ default destination if nothing in session+ -> m a+redirectUltDest defaultDestination = do+ mdest <- lookupSession ultDestKey+ deleteSession ultDestKey+ maybe (redirect defaultDestination) redirect mdest++-- | Remove a previously set ultimate destination. See 'setUltDest'.+clearUltDest :: MonadHandler m => m ()+clearUltDest = deleteSession ultDestKey++msgKey :: Text+msgKey = "_MSG"++-- | Adds a status and message in the user's session.+--+-- See 'getMessages'.+--+-- @since 1.4.20+addMessage :: MonadHandler m+ => Text -- ^ status+ -> Html -- ^ message+ -> m ()+addMessage status msg = do+ val <- lookupSessionBS msgKey+ setSessionBS msgKey $ addMsg val+ where+ addMsg = maybe msg' (S.append msg' . S.cons W8._nul)+ msg' = S.append+ (encodeUtf8 status)+ (W8._nul `S.cons` L.toStrict (renderHtml msg))++-- | Adds a message in the user's session but uses RenderMessage to allow for i18n+--+-- See 'getMessages'.+--+-- @since 1.4.20+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => Text -> msg -> m ()+addMessageI status msg = do+ mr <- getMessageRender+ addMessage status $ toHtml $ mr msg++-- | Gets all messages in the user's session, and then clears the variable.+--+-- See 'addMessage'.+--+-- @since 1.4.20+getMessages :: MonadHandler m => m [(Text, Html)]+getMessages = do+ bs <- lookupSessionBS msgKey+ let ms = maybe [] enlist bs+ deleteSession msgKey+ return ms+ where+ enlist = pairup . S.split W8._nul+ pairup [] = []+ pairup [_] = []+ pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs+ decode = decodeUtf8With lenientDecode++-- | Calls 'addMessage' with an empty status+setMessage :: MonadHandler m => Html -> m ()+setMessage = addMessage ""++-- | Calls 'addMessageI' with an empty status+setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => msg -> m ()+setMessageI = addMessageI ""++-- | Gets just the last message in the user's session,+-- discards the rest and the status+getMessage :: MonadHandler m => m (Maybe Html)+getMessage = fmap (fmap snd . listToMaybe) getMessages++-- | Bypass remaining handler code and output the given file.+--+-- For some backends, this is more efficient than reading in the file to+-- memory, since they can optimize file sending via a system call to sendfile.+sendFile :: MonadHandler m => ContentType -> FilePath -> m a+sendFile ct fp = handlerError $ HCSendFile ct fp Nothing++-- | Same as 'sendFile', but only sends part of a file.+sendFilePart :: MonadHandler m+ => ContentType+ -> FilePath+ -> Integer -- ^ offset+ -> Integer -- ^ count+ -> m a+sendFilePart ct fp off count = do+ fs <- liftIO $ PC.getFileStatus fp+ handlerError $ HCSendFile ct fp $ Just W.FilePart+ { W.filePartOffset = off+ , W.filePartByteCount = count+ , W.filePartFileSize = fromIntegral $ PC.fileSize fs+ }++-- | Bypass remaining handler code and output the given content with a 200+-- status code.+sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a+sendResponse = handlerError . HCContent H.status200 . toTypedContent++-- | Bypass remaining handler code and output the given content with the given+-- status code.+sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a+sendResponseStatus s = handlerError . HCContent s . toTypedContent++-- | Bypass remaining handler code and output the given JSON with the given+-- status code.+--+-- @since 1.4.18+sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a+sendStatusJSON s v = sendResponseStatus s (toEncoding v)++-- | Send a 201 "Created" response with the given route as the Location+-- response header.+sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a+sendResponseCreated url = do+ r <- getUrlRender+ handlerError $ HCCreated $ r url++-- | Bypass remaining handler code and output no content with a 204 status code.+--+-- @since 1.6.9+sendResponseNoContent :: MonadHandler m => m a+sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty++-- | Send a 'W.Response'. Please note: this function is rarely+-- necessary, and will /disregard/ any changes to response headers and session+-- that you have already specified. This function short-circuits. It should be+-- considered only for very specific needs. If you are not sure if you need it,+-- you don't.+sendWaiResponse :: MonadHandler m => W.Response -> m b+sendWaiResponse = handlerError . HCWai++-- | Switch over to handling the current request with a WAI @Application@.+--+-- @since 1.2.17+sendWaiApplication :: MonadHandler m => W.Application -> m b+sendWaiApplication = handlerError . HCWaiApp++-- | Send a raw response without conduit. This is used for cases such as+-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw+-- responses (e.g., Warp).+--+-- @since 1.2.16+sendRawResponseNoConduit+ :: (MonadHandler m, MonadUnliftIO m)+ => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())+ -> m a+sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->+ liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback+ $ \src sink -> void $ runInIO (raw src sink)+ where+ fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+ "sendRawResponse: backend does not support raw responses"++-- | Send a raw response. This is used for cases such as WebSockets. Requires+-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,+-- Warp).+--+-- @since 1.2.7+sendRawResponse+ :: (MonadHandler m, MonadUnliftIO m)+ => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())+ -> m a+sendRawResponse raw = withRunInIO $ \runInIO ->+ liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback+ $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)+ where+ fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+ "sendRawResponse: backend does not support raw responses"+ src' src = do+ bs <- liftIO src+ unless (S.null bs) $ do+ yield bs+ src' src++-- | Send a 304 not modified response immediately. This is a short-circuiting+-- action.+--+-- @since 1.4.4+notModified :: MonadHandler m => m a+notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty++-- | Return a 404 not found page. Also denotes no handler available.+notFound :: MonadHandler m => m a+notFound = hcError NotFound++-- | Return a 405 method not supported page.+badMethod :: MonadHandler m => m a+badMethod = do+ w <- waiRequest+ hcError $ BadMethod $ W.requestMethod w++-- | Return a 401 status code+notAuthenticated :: MonadHandler m => m a+notAuthenticated = hcError NotAuthenticated++-- | Return a 403 permission denied page.+permissionDenied :: MonadHandler m => Text -> m a+permissionDenied = hcError . PermissionDenied++-- | Return a 403 permission denied page.+permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)+ => msg+ -> m a+permissionDeniedI msg = do+ mr <- getMessageRender+ permissionDenied $ mr msg++-- | Return a 400 invalid arguments page.+invalidArgs :: MonadHandler m => [Text] -> m a+invalidArgs = hcError . InvalidArgs++-- | Return a 400 invalid arguments page.+invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a+invalidArgsI msg = do+ mr <- getMessageRender+ invalidArgs $ map mr msg++------- Headers+-- | Set the cookie on the client.++setCookie :: MonadHandler m => SetCookie -> m ()+setCookie sc = do+ addHeaderInternal (DeleteCookie name path)+ addHeaderInternal (AddCookie sc)+ where name = setCookieName sc+ path = maybe "/" id (setCookiePath sc)++-- | Helper function for setCookieExpires value+getExpires :: MonadIO m+ => Int -- ^ minutes+ -> m UTCTime+getExpires m = do+ now <- liftIO getCurrentTime+ return $ fromIntegral (m * 60) `addUTCTime` now+++-- | Unset the cookie on the client.+--+-- Note: although the value used for key and path is 'Text', you should only+-- use ASCII values to be HTTP compliant.+deleteCookie :: MonadHandler m+ => Text -- ^ key+ -> Text -- ^ path+ -> m ()+deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8+++-- | Set the language in the user session. Will show up in 'languages' on the+-- next request.+setLanguage :: MonadHandler m => Text -> m ()+setLanguage = setSession langKey++-- | Set attachment file name.+--+-- Allows Unicode characters by encoding to UTF-8.+-- Some modurn browser parse UTF-8 characters with out encoding setting.+-- But, for example IE9 can't parse UTF-8 characters.+-- This function use+-- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)+--+-- @since 1.6.4+addContentDispositionFileName :: MonadHandler m => T.Text -> m ()+addContentDispositionFileName fileName+ = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName++-- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.+--+-- > rfc6266Utf8FileName (Data.Text.pack "€")+-- "attachment; filename*=UTF-8''%E2%82%AC"+rfc6266Utf8FileName :: T.Text -> T.Text+rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName))++-- | Set an arbitrary response header.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- @since 1.2.0+addHeader :: MonadHandler m => Text -> Text -> m ()+addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8++-- | Deprecated synonym for addHeader.+setHeader :: MonadHandler m => Text -> Text -> m ()+setHeader = addHeader+{-# DEPRECATED setHeader "Please use addHeader instead" #-}++-- | Replace an existing header with a new value or add a new header+-- if not present.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- @since 1.4.36+replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()+replaceOrAddHeader a b =+ modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}+ where+ repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)++ sameHeaderName :: Header -> Header -> Bool+ sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2+ sameHeaderName _ _ = False++ replaceIndividualHeader :: [Header] -> [Header]+ replaceIndividualHeader [] = [repHeader]+ replaceIndividualHeader xs = aux xs []+ where+ aux [] acc = acc ++ [repHeader]+ aux (x:xs') acc =+ if sameHeaderName repHeader x+ then acc +++ [repHeader] +++ (filter (\header -> not (sameHeaderName header repHeader)) xs')+ else aux xs' (acc ++ [x])++ replaceHeader :: Endo [Header] -> Endo [Header]+ replaceHeader endo =+ let allHeaders :: [Header] = appEndo endo []+ in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest)++-- | Set the Cache-Control header to indicate this response should be cached+-- for the given number of seconds.+cacheSeconds :: MonadHandler m => Int -> m ()+cacheSeconds i = setHeader "Cache-Control" $ T.concat+ [ "max-age="+ , T.pack $ show i+ , ", public"+ ]++-- | Set the Expires header to some date in 2037. In other words, this content+-- is never (realistically) expired.+neverExpires :: MonadHandler m => m ()+neverExpires = do+ setHeader "Expires" . rheMaxExpires =<< askHandlerEnv+ cacheSeconds oneYear+ where+ oneYear :: Int+ oneYear = 60 * 60 * 24 * 365++-- | Set an Expires header in the past, meaning this content should not be+-- cached.+alreadyExpired :: MonadHandler m => m ()+alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"++-- | Set an Expires header to the given date.+expiresAt :: MonadHandler m => UTCTime -> m ()+expiresAt = setHeader "Expires" . formatRFC1123++data Etag+ = WeakEtag !S.ByteString+ -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are+ -- semantically identical but make no guarantees about being bytewise identical.+ | StrongEtag !S.ByteString+ -- ^ Signifies that contents should be byte-for-byte identical if they match+ -- the provided ETag+ | InvalidEtag !S.ByteString+ -- ^ Anything else that ends up in a header that expects an ETag but doesn't+ -- properly follow the ETag format specified in RFC 7232, section 2.3+ deriving (Show, Eq)++-- | Check the if-none-match header and, if it matches the given value, return+-- a 304 not modified response. Otherwise, set the etag header to the given+-- value.+--+-- Note that it is the responsibility of the caller to ensure that the provided+-- value is a valid etag value, no sanity checking is performed by this+-- function.+--+-- @since 1.4.4+setEtag :: MonadHandler m => Text -> m ()+setEtag etag = do+ mmatch <- lookupHeader "if-none-match"+ let matches = maybe [] parseMatch mmatch+ baseTag = encodeUtf8 etag+ strongTag = StrongEtag baseTag+ badTag = InvalidEtag baseTag+ if any (\tag -> tag == strongTag || tag == badTag) matches+ then notModified+ else addHeader "etag" $ T.concat ["\"", etag, "\""]+++-- | Parse an if-none-match field according to the spec.+parseMatch :: S.ByteString -> [Etag]+parseMatch =+ map clean . S.split W8._comma+ where+ clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace++ classify bs+ | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl+ = StrongEtag $ S.init $ S.tail bs+ | S.length bs >= 4 &&+ S.head bs == W8._W &&+ S.index bs 1 == W8._slash &&+ S.index bs 2 == W8._quotedbl &&+ S.last bs == W8._quotedbl+ = WeakEtag $ S.init $ S.drop 3 bs+ | otherwise = InvalidEtag bs++-- | Check the if-none-match header and, if it matches the given value, return+-- a 304 not modified response. Otherwise, set the etag header to the given+-- value.+--+-- A weak etag is only expected to be semantically identical to the prior content,+-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for+-- dynamically generated content that may be difficult to perform bytewise hashing+-- upon.+--+-- Note that it is the responsibility of the caller to ensure that the provided+-- value is a valid etag value, no sanity checking is performed by this+-- function.+--+-- @since 1.4.37+setWeakEtag :: MonadHandler m => Text -> m ()+setWeakEtag etag = do+ mmatch <- lookupHeader "if-none-match"+ let matches = maybe [] parseMatch mmatch+ if WeakEtag (encodeUtf8 etag) `elem` matches+ then notModified+ else addHeader "etag" $ T.concat ["W/\"", etag, "\""]++-- | Set a variable in the user's session.+--+-- The session is handled by the clientsession package: it sets an encrypted+-- and hashed cookie on the client. This ensures that all data is secure and+-- not tampered with.+setSession :: MonadHandler m+ => Text -- ^ key+ -> Text -- ^ value+ -> m ()+setSession k = setSessionBS k . encodeUtf8++-- | Same as 'setSession', but uses binary data for the value.+setSessionBS :: MonadHandler m+ => Text+ -> S.ByteString+ -> m ()+setSessionBS k = modify . modSession . Map.insert k++-- | Unsets a session variable. See 'setSession'.+deleteSession :: MonadHandler m => Text -> m ()+deleteSession = modify . modSession . Map.delete++-- | Clear all session variables.+--+-- @since: 1.0.1+clearSession :: MonadHandler m => m ()+clearSession = modify $ \x -> x { ghsSession = Map.empty }++modSession :: (SessionMap -> SessionMap) -> GHState -> GHState+modSession f x = x { ghsSession = f $ ghsSession x }++-- | Internal use only, not to be confused with 'setHeader'.+addHeaderInternal :: MonadHandler m => Header -> m ()+addHeaderInternal = tell . Endo . (:)++-- | 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.+ toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text++instance RedirectUrl master Text where+ toTextUrl = return++instance RedirectUrl master String where+ toTextUrl = toTextUrl . T.pack++instance RedirectUrl master (Route master) where+ toTextUrl url = do+ r <- getUrlRender+ return $ r url++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where+ toTextUrl (url, params) = do+ r <- getUrlRenderParams+ return $ r url params++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where+ toTextUrl (url, params) = toTextUrl (url, Map.toList params)++-- | Add a fragment identifier to a route to be used when+-- redirecting. For example:+--+-- > redirect (NewsfeedR :#: storyId)+--+-- @since 1.2.9.+data Fragment a b = a :#: b deriving (Show, Typeable)++instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where+ toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a+++-- | Lookup for session data.+lookupSession :: MonadHandler m => Text -> m (Maybe Text)+lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS++-- | Lookup for session data in binary format.+lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)+lookupSessionBS n = do+ m <- fmap ghsSession get+ return $ Map.lookup n m++-- | Get all session variables.+getSession :: MonadHandler m => m SessionMap+getSession = fmap ghsSession get++-- | Get a unique identifier.+newIdent :: MonadHandler m => m Text+newIdent = do+ x <- get+ let i' = ghsIdent x + 1+ put x { ghsIdent = i' }+ return $ T.pack $ "hident" ++ show i'++-- | Redirect to a POST resource.+--+-- This is not technically a redirect; instead, it returns an HTML page with a+-- POST form, and some Javascript to automatically submit the form. This can be+-- useful when you need to post a plain link somewhere that needs to cause+-- changes on the server.+redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url+ -> m a+redirectToPost url = do+ urlText <- toTextUrl url+ req <- getRequest+ withUrlRenderer [hamlet|+$newline never+$doctype 5++<html>+ <head>+ <title>Redirecting...+ <body onload="document.getElementById('form').submit()">+ <form id="form" method="post" action=#{urlText}>+ $maybe token <- reqToken req+ <input type=hidden name=#{defaultCsrfParamName} value=#{token}>+ <noscript>+ <p>Javascript has been disabled; please click on the button below to be redirected.+ <input type="submit" value="Continue">+|] >>= sendResponse++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html+hamletToRepHtml = withUrlRenderer+{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}++-- | Deprecated synonym for 'withUrlRenderer'.+--+-- @since 1.2.0+giveUrlRenderer :: MonadHandler m+ => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)+ -> m output+giveUrlRenderer = withUrlRenderer+{-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-}++-- | Provide a URL rendering function to the given function and return the+-- result. Useful for processing Shakespearean templates.+--+-- @since 1.2.20+withUrlRenderer :: MonadHandler m+ => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)+ -> m output+withUrlRenderer f = do+ render <- getUrlRenderParams+ return $ f render++-- | Get the request\'s 'W.Request' value.+waiRequest :: MonadHandler m => m W.Request+waiRequest = reqWaiRequest <$> getRequest++getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)+ => m (message -> Text)+getMessageRender = do+ env <- askHandlerEnv+ l <- languages+ return $ renderMessage (rheSite env) l++-- | Use a per-request cache to avoid performing the same action multiple times.+-- Values are stored by their type, the result of typeOf from Typeable.+-- Therefore, you should use different newtype wrappers at each cache site.+--+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.+--+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+--+-- @since 1.2.0+cached :: (MonadHandler m, Typeable a)+ => m a+ -> m a+cached action = do+ cache <- ghsCache <$> get+ eres <- Cache.cached cache action+ case eres of+ Right res -> return res+ Left (newCache, res) -> do+ gs <- get+ let merged = newCache `HM.union` ghsCache gs+ put $ gs { ghsCache = merged }+ return res++-- | Retrieves a value from the cache used by 'cached'.+--+-- @since 1.6.10+cacheGet :: (MonadHandler m, Typeable a)+ => m (Maybe a)+cacheGet = do+ cache <- ghsCache <$> get+ pure $ Cache.cacheGet cache++-- | Sets a value in the cache used by 'cached'.+--+-- @since 1.6.10+cacheSet :: (MonadHandler m, Typeable a)+ => a+ -> m ()+cacheSet value = do+ gs <- get+ let cache = ghsCache gs+ newCache = Cache.cacheSet value cache+ put $ gs { ghsCache = newCache }++-- | a per-request cache. just like 'cached'.+-- 'cached' can only cache a single value per type.+-- 'cachedBy' stores multiple values per type by usage of a ByteString key+--+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.+-- You can turn those parameters into a ByteString cache key.+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.+--+-- @since 1.4.0+cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a+cachedBy k action = do+ cache <- ghsCacheBy <$> get+ eres <- Cache.cachedBy cache k action+ case eres of+ Right res -> return res+ Left (newCache, res) -> do+ gs <- get+ let merged = newCache `HM.union` ghsCacheBy gs+ put $ gs { ghsCacheBy = merged }+ return res++-- | Retrieves a value from the cache used by 'cachedBy'.+--+-- @since 1.6.10+cacheByGet :: (MonadHandler m, Typeable a)+ => S.ByteString+ -> m (Maybe a)+cacheByGet key = do+ cache <- ghsCacheBy <$> get+ pure $ Cache.cacheByGet key cache++-- | Sets a value in the cache used by 'cachedBy'.+--+-- @since 1.6.10+cacheBySet :: (MonadHandler m, Typeable a)+ => S.ByteString+ -> a+ -> m ()+cacheBySet key value = do+ gs <- get+ let cache = ghsCacheBy gs+ newCache = Cache.cacheBySet key value cache+ put $ gs { ghsCacheBy = newCache }++-- | Get the list of supported languages supplied by the user.+--+-- Languages are determined based on the following (in descending order+-- of preference):+--+-- * The _LANG user session variable.+--+-- * The _LANG get parameter.+--+-- * The _LANG cookie.+--+-- * Accept-Language HTTP header.+--+-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.+-- If a matching language is not found the default language will be used.+--+-- This is handled by parseWaiRequest (not exposed).+languages :: MonadHandler m => m [Text]+languages = do+ mlang <- lookupSession langKey+ langs <- reqLangs <$> getRequest+ return $ maybe id (:) mlang langs++lookup' :: Eq a => a -> [(a, b)] -> [b]+lookup' a = map snd . filter (\x -> a == fst x)++-- | Lookup a request header.+--+-- @since 1.2.2+lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)+lookupHeader = fmap listToMaybe . lookupHeaders++-- | Lookup a request header.+--+-- @since 1.2.2+lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]+lookupHeaders key = do+ req <- waiRequest+ return $ lookup' key $ W.requestHeaders req++-- | Lookup basic authentication data from __Authorization__ header of+-- request. Returns user name and password+--+-- @since 1.4.9+lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))+lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")+ where+ getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)+ <$> extractBasicAuth bs++-- | Lookup bearer authentication datafrom __Authorization__ header of+-- request. Returns bearer token value+--+-- @since 1.4.9+lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)+lookupBearerAuth = fmap (>>= getBR)+ (lookupHeader "Authorization")+ where+ getBR bs = decodeUtf8With lenientDecode+ <$> extractBearerAuth bs+++-- | Lookup for GET parameters.+lookupGetParams :: MonadHandler m => Text -> m [Text]+lookupGetParams pn = do+ rr <- getRequest+ return $ lookup' pn $ reqGetParams rr++-- | Lookup for GET parameters.+lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)+lookupGetParam = fmap listToMaybe . lookupGetParams++-- | Lookup for POST parameters.+lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]+lookupPostParams pn = do+ (pp, _) <- runRequestBody+ return $ lookup' pn pp++lookupPostParam :: (MonadResource m, MonadHandler m)+ => Text+ -> m (Maybe Text)+lookupPostParam = fmap listToMaybe . lookupPostParams++-- | Lookup for POSTed files.+lookupFile :: MonadHandler m+ => Text+ -> m (Maybe FileInfo)+lookupFile = fmap listToMaybe . lookupFiles++-- | Lookup for POSTed files.+lookupFiles :: MonadHandler m+ => Text+ -> m [FileInfo]+lookupFiles pn = do+ (_, files) <- runRequestBody+ return $ lookup' pn files++-- | Lookup for cookie data.+lookupCookie :: MonadHandler m => Text -> m (Maybe Text)+lookupCookie = fmap listToMaybe . lookupCookies++-- | Lookup for cookie data.+lookupCookies :: MonadHandler m => Text -> m [Text]+lookupCookies pn = do+ rr <- getRequest+ return $ lookup' pn $ reqCookies rr++-- $representations+--+-- HTTP allows content negotation to determine what /representation/ of data+-- you would like to use. The most common example of this is providing both a+-- user-facing HTML page and an API facing JSON response from the same URL. The+-- means of achieving this is the Accept HTTP header, which provides a list of+-- content types the client will accept, sorted by preference.+--+-- By using 'selectRep' and 'provideRep', you can provide a number of different+-- representations, e.g.:+--+-- > selectRep $ do+-- > provideRep produceHtmlOutput+-- > provideRep produceJsonOutput+--+-- The first provided representation will be used if no matches are found.++-- | Select a representation to send to the client based on the representations+-- provided inside this do-block. Should be used together with 'provideRep'.+--+-- @since 1.2.0+selectRep :: MonadHandler m+ => Writer.Writer (Endo [ProvidedRep m]) ()+ -> m TypedContent+selectRep w = do+ -- the content types are already sorted by q values+ -- which have been stripped+ cts <- fmap reqAccept getRequest++ case mapMaybe tryAccept cts of+ [] ->+ case reps of+ [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)+ rep:_ -> returnRep rep+ rep:_ -> returnRep rep+ where+ returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent++ reps = appEndo (Writer.execWriter w) []++ repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList+ [ (k, v)+ , (noSpace k, v)+ , (simpleContentType k, v)+ ]) reps++ -- match on the type for sub-type wildcards.+ -- If the accept is text/ * it should match a provided text/html+ mainTypeMap = Map.fromList $ reverse $ map+ (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps++ tryAccept ct =+ if subType == "*"+ then if mainType == "*"+ then listToMaybe reps+ else Map.lookup mainType mainTypeMap+ else lookupAccept ct+ where+ (mainType, subType) = contentTypeTypes ct++ lookupAccept ct = Map.lookup ct repMap <|>+ Map.lookup (noSpace ct) repMap <|>+ Map.lookup (simpleContentType ct) repMap++ -- Mime types such as "text/html; charset=foo" get converted to+ -- "text/html;charset=foo"+ noSpace = S8.filter (/= ' ')++-- | Internal representation of a single provided representation.+--+-- @since 1.2.0+data ProvidedRep m = ProvidedRep !ContentType !(m Content)++-- | Provide a single representation to be used, based on the request of the+-- client. Should be used together with 'selectRep'.+--+-- @since 1.2.0+provideRep :: (Monad m, HasContentType a)+ => m a+ -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRep handler = provideRepType (getContentType handler) handler++-- | Same as 'provideRep', but instead of determining the content type from the+-- type of the value itself, you provide the content type separately. This can+-- be a convenience instead of creating newtype wrappers for uncommonly used+-- content types.+--+-- > provideRepType "application/x-special-format" "This is the content"+--+-- @since 1.2.0+provideRepType :: (Monad m, ToContent a)+ => ContentType+ -> m a+ -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRepType ct handler =+ Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):)++-- | Stream in the raw request body without any parsing.+--+-- @since 1.2.0+rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()+rawRequestBody = do+ req <- lift waiRequest+ let loop = do+ bs <- liftIO $ W.requestBody req+ unless (S.null bs) $ do+ yield bs+ loop+ loop++-- | Stream the data from the file. Since Yesod 1.2, this has been generalized+-- to work in any @MonadResource@.+fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()+fileSource = transPipe liftResourceT . fileSourceRaw++-- | Extract a strict `ByteString` body from a `FileInfo`.+--+-- This function will block while reading the file.+--+-- > do+-- > fileByteString <- fileSourceByteString fileInfo+--+-- @since 1.6.5+fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString+fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy))++-- | Provide a pure value for the response body.+--+-- > respond ct = return . TypedContent ct . toContent+--+-- @since 1.2.0+respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent+respond ct = return . TypedContent ct . toContent++-- | Use a @Source@ for the response body.+--+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This+-- implies that you can run any @HandlerT@ action. However, since a streaming+-- response occurs after the response headers have already been sent, some+-- actions make no sense here. For example: short-circuit responses, setting+-- headers, changing status codes, etc.+--+-- @since 1.2.0+respondSource :: ContentType+ -> ConduitT () (Flush Builder) (HandlerFor site) ()+ -> HandlerFor site TypedContent+respondSource ctype src = HandlerFor $ \hd ->+ -- Note that this implementation relies on the fact that the ResourceT+ -- environment provided by the server is the same one used in HandlerT.+ -- This is a safe assumption assuming the HandlerT is run correctly.+ return $ TypedContent ctype $ ContentSource+ $ transPipe (lift . flip unHandlerFor hd) src++-- | In a streaming response, send a single chunk of data. This function works+-- on most datatypes, such as @ByteString@ and @Html@.+--+-- @since 1.2.0+sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()+sendChunk = yield . toFlushBuilder++-- | In a streaming response, send a flush command, causing all buffered data+-- to be immediately sent to the client.+--+-- @since 1.2.0+sendFlush :: Monad m => ConduitT i (Flush Builder) m ()+sendFlush = yield Flush++-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.+--+-- @since 1.2.0+sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()+sendChunkBS = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.+--+-- @since 1.2.0+sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()+sendChunkLBS = sendChunk++-- | Type-specialized version of 'sendChunk' for strict @Text@s.+--+-- @since 1.2.0+sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()+sendChunkText = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @Text@s.+--+-- @since 1.2.0+sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()+sendChunkLazyText = sendChunk++-- | Type-specialized version of 'sendChunk' for @Html@s.+--+-- @since 1.2.0+sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()+sendChunkHtml = sendChunk++-- $ajaxCSRFOverview+-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.+-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.+-- This is known as a <https://en.wikipedia.org/wiki/Cross-site_request_forgery Cross Site Request Forgery> (CSRF) attack.+--+-- To combat this attack, you need a way to verify that the request is valid.+-- This is achieved by generating a random string ("token"), storing it in your encrypted session so that the server can look it up (see 'reqToken'), and adding the token to HTTP requests made to your server.+-- When a request comes in, the token in the request is compared to the one from the encrypted session. If they match, you can be sure the request is valid.+--+-- Yesod implements this behavior in two ways:+--+-- (1) The yesod-form package <http://www.yesodweb.com/book/forms#forms_running_forms stores the CSRF token in a hidden field> in the form, then validates it with functions like 'Yesod.Form.Functions.runFormPost'.+--+-- (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session.+--+-- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam').+--+-- The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware.+--+-- === Opting-out of CSRF checking for specific routes+--+-- (Note: this code is generic to opting out of any Yesod middleware)+--+-- @+-- 'yesodMiddleware' app = do+-- maybeRoute <- 'getCurrentRoute'+-- let dontCheckCsrf = case maybeRoute of+-- Just HomeR -> True -- Don't check HomeR+-- Nothing -> True -- Don't check for 404s+-- _ -> False -- Check other routes+--+-- 'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app+-- @+--+-- This can also be implemented using the 'csrfCheckMiddleware' function.++-- | The default cookie name for the CSRF token ("XSRF-TOKEN").+--+-- @since 1.4.14+defaultCsrfCookieName :: S8.ByteString+defaultCsrfCookieName = "XSRF-TOKEN"++-- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name.+--+-- The cookie's path is set to @/@, making it valid for your whole website.+--+-- @since 1.4.14+setCsrfCookie :: MonadHandler m => m ()+setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie+ { setCookieName = defaultCsrfCookieName+ , setCookiePath = Just "/"+ }++-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.+--+-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.+--+-- @since 1.4.14+setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()+setCsrfCookieWithCookie cookie = do+ mCsrfToken <- reqToken <$> getRequest+ Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token })++-- | The default header name for the CSRF token ("X-XSRF-TOKEN").+--+-- @since 1.4.14+defaultCsrfHeaderName :: CI S8.ByteString+defaultCsrfHeaderName = "X-XSRF-TOKEN"++-- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,+-- this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()+checkCsrfHeaderNamed headerName = do+ (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName+ unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])++-- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.+--+-- @since 1.4.14+hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool+hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName++-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.+hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)+hasValidCsrfHeaderNamed' headerName = do+ mCsrfToken <- reqToken <$> getRequest+ mXsrfHeader <- lookupHeader headerName++ return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)++-- CSRF Parameter checking++-- | The default parameter name for the CSRF token ("_token")+--+-- @since 1.4.14+defaultCsrfParamName :: Text+defaultCsrfParamName = "_token"++-- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,+-- this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfParamNamed :: MonadHandler m => Text -> m ()+checkCsrfParamNamed paramName = do+ (valid, mParam) <- hasValidCsrfParamNamed' paramName+ unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])++-- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.+--+-- @since 1.4.14+hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool+hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName++-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.+hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)+hasValidCsrfParamNamed' paramName = do+ mCsrfToken <- reqToken <$> getRequest+ mCsrfParam <- lookupPostParam paramName++ return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)++-- | Checks that a valid CSRF token is present in either the request headers or POST parameters.+-- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.+--+-- @since 1.4.14+checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)+ => CI S8.ByteString -- ^ The header name to lookup the CSRF token+ -> Text -- ^ The POST parameter name to lookup the CSRF token+ -> m ()+checkCsrfHeaderOrParam headerName paramName = do+ (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName+ (validParam, mParam) <- hasValidCsrfParamNamed' paramName+ unless (validHeader || validParam) $ do+ let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam]+ $logWarnS "yesod-core" errorMessage+ permissionDenied errorMessage++validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool+-- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.+validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param+validCsrf Nothing _param = True+validCsrf (Just _token) Nothing = False++data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value+ | CSRFParam Text (Maybe Text) -- Key/Value++csrfErrorMessage :: [CSRFExpectation]+ -> Text -- ^ Error message+csrfErrorMessage expectedLocations = T.intercalate "\n"+ [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."+ , "If you're a developer of this site, these tips will help you debug the issue:"+ , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."+ , "- Check that your HTTP client is persisting cookies between requests, like a browser does."+ , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "."+ , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations)+ ]++ where csrfLocation expected = case expected of+ CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)]+ CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)]++ formatValue :: Maybe Text -> Text+ formatValue maybeText = case maybeText of+ Nothing -> "(which is not currently set)"+ Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]++getSubYesod :: MonadHandler m => m (SubHandlerSite m)+getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv++getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))+getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv++getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))+getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv
+ src/Yesod/Core/Internal.hs view
@@ -0,0 +1,8 @@+-- | Exposed mostly for testing. These functions provide an unstable API and+-- should not be relied upon.+module Yesod.Core.Internal+ ( module X+ ) where++import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)+import Yesod.Core.Internal.TH as X (mkYesodGeneral)
+ src/Yesod/Core/Internal/LiteApp.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}+module Yesod.Core.Internal.LiteApp where++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Yesod.Routes.Class+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Types+import Yesod.Core.Content+import Data.Text (Text)+import Web.PathPieces+import Network.Wai+import Yesod.Core.Handler+import Yesod.Core.Internal.Run+import Network.HTTP.Types (Method)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<|>))+import Control.Monad.Trans.Writer++newtype LiteApp = LiteApp+ { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)+ }++instance Yesod LiteApp++instance YesodDispatch LiteApp where+ yesodDispatch yre req =+ yesodRunner+ (fromMaybe notFound $ f (requestMethod req) (pathInfo req))+ yre+ (Just $ LiteAppRoute $ pathInfo req)+ req+ where+ LiteApp f = yreSite yre++instance RenderRoute LiteApp where+ data Route LiteApp = LiteAppRoute [Text]+ deriving (Show, Eq, Read, Ord)+ renderRoute (LiteAppRoute x) = (x, [])+instance ParseRoute LiteApp where+ parseRoute (x, _) = Just $ LiteAppRoute x++instance Semigroup LiteApp where+ LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps++instance Monoid LiteApp where+ mempty = LiteApp $ \_ _ -> Nothing+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif++type LiteHandler = HandlerFor LiteApp+type LiteWidget = WidgetFor LiteApp++liteApp :: Writer LiteApp () -> LiteApp+liteApp = execWriter++dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()+dispatchTo handler = tell $ LiteApp $ \_ ps ->+ if null ps+ then Just $ fmap toTypedContent handler+ else Nothing++onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()+onMethod method f = tell $ LiteApp $ \m ps ->+ if method == m+ then unLiteApp (liteApp f) m ps+ else Nothing++onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()+onStatic p0 f = tell $ LiteApp $ \m ps0 ->+ case ps0 of+ p:ps | p == p0 -> unLiteApp (liteApp f) m ps+ _ -> Nothing++withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamic f = tell $ LiteApp $ \m ps0 ->+ case ps0 of+ p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps+ _ -> Nothing++withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamicMulti f = tell $ LiteApp $ \m ps ->+ case fromPathMultiPiece ps of+ Nothing -> Nothing+ Just v -> unLiteApp (liteApp $ f v) m []
+ src/Yesod/Core/Internal/Request.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Yesod.Core.Internal.Request+ ( parseWaiRequest+ , RequestBodyContents+ , FileInfo+ , fileName+ , fileContentType+ , fileMove+ , mkFileInfoLBS+ , mkFileInfoFile+ , mkFileInfoSource+ , FileUpload (..)+ , tooLargeResponse+ , tokenKey+ , langKey+ , textQueryString+ -- The below are exported for testing.+ , randomString+ ) where++import Data.String (IsString)+import Control.Arrow (second)+import qualified Network.Wai.Parse as NWP+import qualified Network.Wai as W+import Web.Cookie (parseCookiesText)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as LS8+import Data.Text (Text, pack)+import Network.HTTP.Types (queryToQueryText, Status (Status))+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.ByteString.Lazy as L+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, decodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Conduit+import Data.Word (Word8, Word64)+import Control.Exception (throwIO)+import Control.Monad ((<=<), liftM)+import Yesod.Core.Types+import qualified Data.Map as Map+import Data.IORef+import qualified Data.Vector.Storable as V+import Data.ByteString.Internal (ByteString (PS))+import qualified Data.Word8 as Word8++-- | Impose a limit on the size of the request body.+limitRequestBody :: Word64 -> W.Request -> IO W.Request+limitRequestBody maxLen req = do+ ref <- newIORef maxLen+ return req+ { W.requestBody = do+ bs <- W.requestBody req+ remaining <- readIORef ref+ let len = fromIntegral $ S8.length bs+ remaining' = remaining - len+ if remaining < len+ then throwIO $ HCWai $ tooLargeResponse maxLen len+ else do+ writeIORef ref remaining'+ return bs+ }++tooLargeResponse :: Word64 -> Word64 -> W.Response+tooLargeResponse maxLen bodyLen = W.responseLBS+ (Status 413 "Too Large")+ [("Content-Type", "text/plain")]+ (L.concat + [ "Request body too large to be processed. The maximum size is "+ , (LS8.pack (show maxLen))+ , " bytes; your request body was "+ , (LS8.pack (show bodyLen))+ , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."+ ])++parseWaiRequest :: W.Request+ -> SessionMap+ -> Bool+ -> Maybe Word64 -- ^ max body size+ -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)+parseWaiRequest env session useToken mmaxBodySize =+ -- In most cases, we won't need to generate any random values. Therefore,+ -- we split our results: if we need a random generator, return a Right+ -- value, otherwise return a Left and avoid the relatively costly generator+ -- acquisition.+ case etoken of+ Left token -> Left $ mkRequest token+ Right mkToken -> Right $ mkRequest <=< mkToken+ where+ mkRequest token' = do+ envLimited <- maybe return limitRequestBody mmaxBodySize env+ return YesodRequest+ { reqGetParams = gets+ , reqCookies = cookies+ , reqWaiRequest = envLimited+ , reqLangs = langs''+ , reqToken = token'+ , reqSession = if useToken+ then Map.delete tokenKey session+ else session+ , reqAccept = httpAccept env+ }+ gets = textQueryString env+ reqCookie = lookup "Cookie" $ W.requestHeaders env+ cookies = maybe [] parseCookiesText reqCookie+ acceptLang = lookup "Accept-Language" $ W.requestHeaders env+ langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang++ lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k++ -- The language preferences are prioritized as follows:+ langs' = catMaybes [ lookup langKey gets -- Query _LANG+ , lookup langKey cookies -- Cookie _LANG+ , lookupText langKey session -- Session _LANG+ ] ++ langs -- Accept-Language(s)++ -- Github issue #195. We want to add an extra two-letter version of any+ -- language in the list.+ langs'' = addTwoLetters (id, Set.empty) langs'++ -- If sessions are disabled tokens should not be used (any+ -- tokenKey present in the session is ignored). If sessions+ -- are enabled and a session has no tokenKey a new one is+ -- generated.+ etoken+ | useToken =+ case Map.lookup tokenKey session of+ -- Already have a token, use it.+ Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs+ -- Don't have a token, get a random generator and make a new one.+ Nothing -> Right $ fmap Just . randomString 10+ | otherwise = Left Nothing++textQueryString :: W.Request -> [(Text, Text)]+textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString++-- | Get the list of accepted content types from the WAI Request\'s Accept+-- header.+--+-- Since 1.2.0+httpAccept :: W.Request -> [ContentType]+httpAccept = NWP.parseHttpAccept+ . fromMaybe S8.empty+ . lookup "Accept"+ . W.requestHeaders++addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]+addTwoLetters (toAdd, exist) [] =+ filter (`Set.notMember` exist) $ toAdd []+addTwoLetters (toAdd, exist) (l:ls) =+ l : addTwoLetters (toAdd', exist') ls+ where+ (toAdd', exist')+ | T.length l > 2 = (toAdd . (T.take 2 l:), exist)+ | otherwise = (toAdd, Set.insert l exist)++-- | Generate a random String of alphanumerical characters+-- (a-z, A-Z, and 0-9) of the given length using the given+-- random number generator.+randomString :: Monad m => Int -> m Int -> m Text+randomString len gen =+ liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar+ where+ asciiChar =+ let loop = do+ x <- gen+ let y = fromIntegral $ x `mod` 64+ case () of+ ()+ | y < 26 -> return $ y + Word8._A+ | y < 52 -> return $ y + Word8._a - 26+ | y < 62 -> return $ y + Word8._0 - 52+ | otherwise -> loop+ in loop++fromByteVector :: V.Vector Word8 -> ByteString+fromByteVector v =+ PS fptr offset idx+ where+ (fptr, offset, idx) = V.unsafeToForeignPtr v+{-# INLINE fromByteVector #-}++mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo+mkFileInfoLBS name ct lbs =+ FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)++mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)++mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)++tokenKey :: IsString a => a+tokenKey = "_TOKEN"++langKey :: IsString a => a+langKey = "_LANG"
+ src/Yesod/Core/Internal/Response.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Yesod.Core.Internal.Response where++import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive (CI)+import Network.Wai+import Control.Monad (mplus)+import Control.Monad.Trans.Resource (runInternalState, InternalState)+import Network.Wai.Internal+import Web.Cookie (renderSetCookie)+import Yesod.Core.Content+import Yesod.Core.Types+import qualified Network.HTTP.Types as H+import qualified Data.Text as T+import Control.Exception (SomeException, handle)+import Data.ByteString.Builder (lazyByteString, toLazyByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import Yesod.Core.Internal.Request (tokenKey)+import Data.Text.Encoding (encodeUtf8)+import Conduit++yarToResponse :: YesodResponse+ -> (SessionMap -> IO [Header]) -- ^ save session+ -> YesodRequest+ -> Request+ -> InternalState+ -> (Response -> IO ResponseReceived)+ -> IO ResponseReceived+yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a+yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do+ extraHeaders <- do+ let nsToken = maybe+ newSess+ (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)+ (reqToken yreq)+ sessionHeaders <- saveSession nsToken+ return $ ("Content-Type", ct) : map headerToPair sessionHeaders+ let finalHeaders = extraHeaders ++ map headerToPair hs+ finalHeaders' len = ("Content-Length", S8.pack $ show len)+ : finalHeaders++ let go (ContentBuilder b mlen) = do+ let hs' = maybe finalHeaders finalHeaders' mlen+ sendResponse $ ResponseBuilder s hs' b+ go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p+ go (ContentSource body) = sendResponse $ responseStream s finalHeaders+ $ \sendChunk flush -> runConduit $+ transPipe (`runInternalState` is) body+ .| mapM_C (\mchunk ->+ case mchunk of+ Flush -> flush+ Chunk builder -> sendChunk builder)+ go (ContentDontEvaluate c') = go c'+ go c+ where+ s+ | s' == defaultStatus = H.status200+ | otherwise = s'++-- | Indicates that the user provided no specific status code to be used, and+-- therefore the default status code should be used. For normal responses, this+-- would be a 200 response, whereas for error responses this would be an+-- appropriate status code.+--+-- For more information on motivation for this, see:+--+-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ+--+-- Since 1.2.3.1+defaultStatus :: H.Status+defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"++-- | Convert Header to a key/value pair.+headerToPair :: Header+ -> (CI ByteString, ByteString)+headerToPair (AddCookie sc) =+ ("Set-Cookie", BL.toStrict $ toLazyByteString $ 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) = (key, value)++evaluateContent :: Content -> IO (Either ErrorResponse Content)+evaluateContent (ContentBuilder b mlen) = handle f $ do+ let lbs = toLazyByteString b+ len = L.length lbs+ mlen' = mlen `mplus` Just (fromIntegral len)+ len `seq` return (Right $ ContentBuilder (lazyByteString 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 NotAuthenticated = H.status401+getStatus (PermissionDenied _) = H.status403+getStatus (BadMethod _) = H.status405
+ src/Yesod/Core/Internal/Run.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Core.Internal.Run where+++import Yesod.Core.Internal.Response+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as BL+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (LogLevel (LevelError), LogSource,+ liftLoc)+import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.IORef as I+import qualified Data.Map as Map+import Data.Maybe (isJust, fromMaybe)+import Data.Monoid (appEndo)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Language.Haskell.TH.Syntax (Loc, qLocation)+import qualified Network.HTTP.Types as H+import Network.Wai+import Network.Wai.Internal+import System.Log.FastLogger (LogStr, toLogStr)+import Yesod.Core.Content+import Yesod.Core.Class.Yesod+import Yesod.Core.Types+import Yesod.Core.Internal.Request (parseWaiRequest,+ tooLargeResponse)+import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)+import Yesod.Routes.Class (Route, renderRoute)+import Control.DeepSeq (($!!), NFData)+import UnliftIO.Exception++-- | Convert a synchronous exception into an ErrorResponse+toErrorHandler :: SomeException -> IO ErrorResponse+toErrorHandler e0 = handleAny errFromShow $+ case fromException e0 of+ Just (HCError x) -> evaluate $!! x+ _ -> errFromShow e0++-- | Generate an @ErrorResponse@ based on the shown version of the exception+errFromShow :: SomeException -> IO ErrorResponse+errFromShow x = do+ text <- evaluate (T.pack $ show x) `catchAny` \_ ->+ return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")+ return $ InternalError text++-- | Do a basic run of a handler, getting some contents and the final+-- @GHState@. The @GHState@ unfortunately may contain some impure+-- exceptions, but all other synchronous exceptions will be caught and+-- represented by the @HandlerContents@.+basicRunHandler :: ToTypedContent c+ => RunHandlerEnv site site+ -> HandlerFor site c+ -> YesodRequest+ -> InternalState+ -> IO (GHState, HandlerContents)+basicRunHandler rhe handler yreq resState = do+ -- Create a mutable ref to hold the state. We use mutable refs so+ -- that the updates will survive runtime exceptions.+ istate <- I.newIORef defState++ -- Run the handler itself, capturing any runtime exceptions and+ -- converting them into a @HandlerContents@+ contents' <- catchAny+ (do+ res <- unHandlerFor handler (hd istate)+ tc <- evaluate (toTypedContent res)+ -- Success! Wrap it up in an @HCContent@+ return (HCContent defaultStatus tc))+ (\e ->+ case fromException e of+ Just e' -> return e'+ Nothing -> HCError <$> toErrorHandler e)++ -- Get the raw state and return+ state <- I.readIORef istate+ return (state, contents')+ where+ defState = GHState+ { ghsSession = reqSession yreq+ , ghsRBC = Nothing+ , ghsIdent = 1+ , ghsCache = mempty+ , ghsCacheBy = mempty+ , ghsHeaders = mempty+ }+ hd istate = HandlerData+ { handlerRequest = yreq+ , handlerEnv = rhe+ , handlerState = istate+ , handlerResource = resState+ }++-- | Convert an @ErrorResponse@ into a @YesodResponse@+handleError :: RunHandlerEnv sub site+ -> YesodRequest+ -> InternalState+ -> Map.Map Text S8.ByteString+ -> [Header]+ -> ErrorResponse+ -> IO YesodResponse+handleError rhe yreq resState finalSession headers e0 = do+ -- Find any evil hidden impure exceptions+ e <- (evaluate $!! e0) `catchAny` errFromShow++ -- Generate a response, leveraging the updated session and+ -- response headers+ flip runInternalState resState $ do+ yar <- rheOnError rhe e yreq+ { reqSession = finalSession+ }+ case yar of+ YRPlain status' hs ct c sess ->+ let hs' = headers ++ hs+ status+ | status' == defaultStatus = getStatus e+ | otherwise = status'+ in return $ YRPlain status hs' ct c sess+ YRWai _ -> return yar+ YRWaiApp _ -> return yar++-- | Convert a @HandlerContents@ into a @YesodResponse@+handleContents :: (ErrorResponse -> IO YesodResponse)+ -> Map.Map Text S8.ByteString+ -> [Header]+ -> HandlerContents+ -> IO YesodResponse+handleContents handleError' finalSession headers contents =+ case contents of+ HCContent status (TypedContent ct c) -> do+ -- Check for impure exceptions hiding in the contents+ ec' <- evaluateContent c+ case ec' of+ Left e -> handleError' e+ Right c' -> return $ YRPlain status headers ct c' finalSession+ HCError e -> handleError' e+ HCRedirect status loc -> do+ let disable_caching x =+ Header "Cache-Control" "no-cache, must-revalidate"+ : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"+ : x+ hs = (if status /= H.movedPermanently301 then disable_caching else id)+ $ Header "Location" (encodeUtf8 loc) : headers+ return $ YRPlain+ status hs typePlain emptyContent+ finalSession+ HCSendFile ct fp p -> return $ YRPlain+ H.status200+ headers+ ct+ (ContentFile fp p)+ finalSession+ HCCreated loc -> return $ YRPlain+ H.status201+ (Header "Location" (encodeUtf8 loc) : headers)+ typePlain+ emptyContent+ finalSession+ HCWai r -> return $ YRWai r+ HCWaiApp a -> return $ YRWaiApp a++-- | Evaluate the given value. If an exception is thrown, use it to+-- replace the provided contents and then return @mempty@ in place of the+-- evaluated value.+evalFallback :: (Monoid w, NFData w)+ => HandlerContents+ -> w+ -> IO (w, HandlerContents)+evalFallback contents val = catchAny+ (fmap (, contents) (evaluate $!! val))+ (fmap ((mempty, ) . HCError) . toErrorHandler)++-- | Function used internally by Yesod in the process of converting a+-- 'HandlerT' into an 'Application'. Should not be needed by users.+runHandler :: ToTypedContent c+ => RunHandlerEnv site site+ -> HandlerFor site c+ -> YesodApp+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do+ -- Get the raw state and original contents+ (state, contents0) <- basicRunHandler rhe handler yreq resState++ -- Evaluate the unfortunately-lazy session and headers,+ -- propagating exceptions into the contents+ (finalSession, contents1) <- evalFallback contents0 (ghsSession state)+ (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])+ contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)++ -- Convert the HandlerContents into the final YesodResponse+ handleContents+ (handleError rhe yreq resState finalSession headers)+ finalSession+ headers+ contents3++safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())+ -> ErrorResponse+ -> YesodApp+safeEh log' er req = do+ liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError+ $ toLogStr $ "Error handler errored out: " ++ show er+ return $ YRPlain+ H.status500+ []+ typePlain+ (toContent ("Internal Server Error" :: S.ByteString))+ (reqSession req)++-- | Run a 'HandlerT' 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 'HandlerT'+-- 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+-- @HandlerT@. The only useful information the @HandlerT@ 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+-- @HandlerT@ is completely ignored, including changes to the+-- session, cookies or headers. We only return you the+-- @HandlerT@'s return value.+runFakeHandler :: (Yesod site, MonadIO m) =>+ SessionMap+ -> (site -> Logger)+ -> site+ -> HandlerFor site a+ -> m (Either ErrorResponse a)+runFakeHandler fakeSessionMap logger site handler = liftIO $ do+ ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")+ maxExpires <- getCurrentMaxExpiresRFC1123+ let handler' = liftIO . I.writeIORef ret . Right =<< handler+ let yapp = runHandler+ RunHandlerEnv+ { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest+ , rheRoute = Nothing+ , rheRouteToMaster = id+ , rheChild = site+ , rheSite = site+ , rheUpload = fileUpload site+ , rheLog = messageLoggerSource site $ logger site+ , rheOnError = errHandler+ , rheMaxExpires = maxExpires+ }+ handler'+ errHandler err req = do+ liftIO $ I.writeIORef ret (Left err)+ return $ YRPlain+ H.status500+ []+ typePlain+ (toContent ("runFakeHandler: errHandler" :: S8.ByteString))+ (reqSession req)+ fakeWaiRequest = Request+ { requestMethod = "POST"+ , httpVersion = H.http11+ , rawPathInfo = "/runFakeHandler/pathInfo"+ , rawQueryString = ""+ , requestHeaderHost = Nothing+ , requestHeaders = []+ , isSecure = False+ , remoteHost = error "runFakeHandler-remoteHost"+ , pathInfo = ["runFakeHandler", "pathInfo"]+ , queryString = []+ , requestBody = return mempty+ , vault = mempty+ , requestBodyLength = KnownLength 0+ , requestHeaderRange = Nothing+ , requestHeaderReferer = Nothing+ , requestHeaderUserAgent = Nothing+ }+ fakeRequest =+ YesodRequest+ { reqGetParams = []+ , reqCookies = []+ , reqWaiRequest = fakeWaiRequest+ , reqLangs = []+ , reqToken = Just "NaN" -- not a nonce =)+ , reqAccept = []+ , reqSession = fakeSessionMap+ }+ _ <- runResourceT $ yapp fakeRequest+ I.readIORef ret++yesodRunner :: (ToTypedContent res, Yesod site)+ => HandlerFor site res+ -> YesodRunnerEnv site+ -> Maybe (Route site)+ -> Application+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do+ mmaxLen <- maximumContentLengthIO yreSite route+ case (mmaxLen, requestBodyLength req) of+ (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)+ _ -> do+ let dontSaveSession _ = return []+ (session, saveSession) <- liftIO $+ maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend+ maxExpires <- yreGetMaxExpires+ let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen+ let yreq =+ case mkYesodReq of+ Left yreq' -> yreq'+ Right needGen -> needGen yreGen+ let ra = resolveApproot yreSite req+ let log' = messageLoggerSource yreSite yreLogger+ -- We set up two environments: the first one has a "safe" error handler+ -- which will never throw an exception. The second one uses the+ -- user-provided errorHandler function. If that errorHandler function+ -- errors out, it will use the safeEh below to recover.+ rheSafe = RunHandlerEnv+ { rheRender = yesodRender yreSite ra+ , rheRoute = route+ , rheRouteToMaster = id+ , rheChild = yreSite+ , rheSite = yreSite+ , rheUpload = fileUpload yreSite+ , rheLog = log'+ , rheOnError = safeEh log'+ , rheMaxExpires = maxExpires+ }+ rhe = rheSafe+ { rheOnError = runHandler rheSafe . errorHandler+ }++ yesodWithInternalState yreSite route $ \is -> do+ yreq' <- yreq+ yar <- runInternalState (runHandler rhe handler yreq') is+ yarToResponse yar saveSession yreq' req is sendResponse+ where+ mmaxLen = maximumContentLength yreSite route+ handler = yesodMiddleware handler'++yesodRender :: Yesod y+ => y+ -> ResolvedApproot+ -> Route y+ -> [(Text, Text)] -- ^ url query string+ -> Text+yesodRender y ar url params =+ decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $+ fromMaybe+ (joinPath y ar ps+ $ params ++ params')+ (urlParamRenderOverride y url params)+ where+ (ps, params') = renderRoute url++resolveApproot :: Yesod master => master -> Request -> ResolvedApproot+resolveApproot master req =+ case approot of+ ApprootRelative -> ""+ ApprootStatic t -> t+ ApprootMaster f -> f master+ ApprootRequest f -> f master req
+ src/Yesod/Core/Internal/Session.hs view
@@ -0,0 +1,70 @@+module Yesod.Core.Internal.Session+ ( encodeClientSession+ , decodeClientSession+ , clientSessionDateCacher+ , ClientSessionDateCache(..)+ , SaveSession+ , SessionBackend(..)+ ) where++import qualified Web.ClientSession as CS+import Data.Serialize+import Data.Time+import Data.ByteString (ByteString)+import Control.Monad (guard)+import Yesod.Core.Types+import Yesod.Core.Internal.Util+import Control.AutoUpdate++encodeClientSession :: CS.Key+ -> CS.IV+ -> ClientSessionDateCache -- ^ expire time+ -> ByteString -- ^ remote host+ -> SessionMap -- ^ session+ -> ByteString -- ^ cookie value+encodeClientSession key iv date rhost session' =+ CS.encrypt key iv $ encode $ SessionCookie expires rhost session'+ where expires = Right (csdcExpiresSerialized date)++decodeClientSession :: CS.Key+ -> ClientSessionDateCache -- ^ current time+ -> ByteString -- ^ remote host field+ -> ByteString -- ^ cookie value+ -> Maybe SessionMap+decodeClientSession key date rhost encrypted = do+ decrypted <- CS.decrypt key encrypted+ SessionCookie (Left expire) rhost' session' <-+ either (const Nothing) Just $ decode decrypted+ guard $ expire > csdcNow date+ guard $ rhost' == rhost+ return session'+++----------------------------------------------------------------------+++-- Originally copied from Kazu's date-cache, but now using mkAutoUpdate.+--+-- The cached date is updated every 10s, we don't need second+-- resolution for session expiration times.+--+-- The second component of the returned tuple used to be an action that+-- killed the updater thread, but is now a no-op that's just there+-- to preserve the type.++clientSessionDateCacher ::+ NominalDiffTime -- ^ Inactive session validity.+ -> IO (IO ClientSessionDateCache, IO ())+clientSessionDateCacher validity = do+ getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings+ { updateAction = getUpdated+ , updateFreq = 10000000 -- 10s+ }++ return (getClientSessionDateCache, return ())+ where+ getUpdated = do+ now <- getCurrentTime+ let expires = validity `addUTCTime` now+ expiresS = runPut (putTime expires)+ return $! ClientSessionDateCache now expires expiresS
+ src/Yesod/Core/Internal/TH.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Core.Internal.TH where++import Prelude hiding (exp)+import Yesod.Core.Handler++import Language.Haskell.TH hiding (cxt, instanceD)+import Language.Haskell.TH.Syntax++import qualified Network.Wai as W++import Data.ByteString.Lazy.Char8 ()+import Data.List (foldl')+import Control.Monad (replicateM, void)+import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)++import Yesod.Routes.TH+import Yesod.Routes.Parse+import Yesod.Core.Types+import Yesod.Core.Class.Dispatch+import Yesod.Core.Internal.Run++-- | Generates URL datatype and site function for the given 'Resource's. This+-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.+-- Use 'parseRoutes' to create the 'Resource's.+--+-- Contexts and type variables in the name of the datatype are parsed. +-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.+mkYesod :: String -- ^ name of the argument datatype+ -> [ResourceTree String]+ -> Q [Dec]+mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return++{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}+-- | Similar to 'mkYesod', except contexts and type variables are not parsed. +-- Instead, they are explicitly provided. +-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.+mkYesodWith :: [[String]] -- ^ list of contexts+ -> String -- ^ name of the argument datatype+ -> [String] -- ^ list of type variables+ -> [ResourceTree String]+ -> Q [Dec]+mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return++-- | Sometimes, you will want to declare your routes in one file and define+-- your handlers elsewhere. For example, this is the only way to break up a+-- monolithic file into smaller parts. Use this function, paired with+-- 'mkYesodDispatch', to do just that.+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodData name resS = fst <$> mkYesodWithParser name False return resS++mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS++-- | Parses contexts and type arguments out of name before generating TH.+mkYesodWithParser :: String -- ^ foundation type+ -> Bool -- ^ is this a subsite+ -> (Exp -> Q Exp) -- ^ unwrap handler+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodWithParser name isSub f resS = do+ let (name', rest, cxt) = case parse parseName "" name of+ Left err -> error $ show err+ Right a -> a+ mkYesodGeneral cxt name' rest isSub f resS++ where+ parseName = do+ cxt <- option [] parseContext+ name' <- parseWord+ args <- many parseWord+ spaces+ eof+ return ( name', args, cxt)++ parseWord = do+ spaces+ many1 alphaNum++ parseContext = try $ do+ cxts <- parseParen parseContexts+ spaces+ _ <- string "=>"+ return cxts++ parseParen p = do+ spaces+ _ <- char '('+ r <- p+ spaces+ _ <- char ')'+ return r++ parseContexts = + sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())++-- | See 'mkYesodData'.+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]+mkYesodDispatch name = fmap snd . mkYesodWithParser name False return++-- | Get the Handler and Widget type synonyms for the given site.+masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?+masterTypeSyns vs site =+ [ TySynD (mkName "Handler") (fmap PlainTV vs)+ $ ConT ''HandlerFor `AppT` site+ , TySynD (mkName "Widget") (fmap PlainTV vs)+ $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()+ ]++mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+ -> String -- ^ foundation type+ -> [String] -- ^ arguments for the type+ -> Bool -- ^ is this a subsite+ -> (Exp -> Q Exp) -- ^ unwrap handler+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodGeneral appCxt' namestr mtys isSub f resS = do+ let appCxt = fmap (\(c:rest) -> + foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest+ ) appCxt'+ mname <- lookupTypeName namestr+ arity <- case mname of+ Just name -> do+ info <- reify name+ return $+ case info of+ TyConI dec ->+ case dec of+ DataD _ _ vs _ _ _ -> length vs+ NewtypeD _ _ vs _ _ _ -> length vs+ TySynD _ vs _ -> length vs+ _ -> 0+ _ -> 0+ _ -> return 0+ let name = mkName namestr+ -- Generate as many variable names as the arity indicates+ vns <- replicateM (arity - length mtys) $ newName "t"+ -- Base type (site type with variables)+ let argtypes = fmap nameToType mtys ++ fmap VarT vns+ site = foldl' AppT (ConT name) argtypes+ res = map (fmap (parseType . dropBracket)) resS+ renderRouteDec <- mkRenderRouteInstance appCxt site res+ routeAttrsDec <- mkRouteAttrsInstance appCxt site res+ dispatchDec <- mkDispatchInstance site appCxt f res+ parseRoute <- mkParseRouteInstance appCxt site res+ let rname = mkName $ "resources" ++ namestr+ eres <- lift resS+ let resourcesDec =+ [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+ , FunD rname [Clause [] (NormalB eres) []]+ ]+ let dataDec = concat+ [ [parseRoute]+ , renderRouteDec+ , [routeAttrsDec]+ , resourcesDec+ , if isSub then [] else masterTypeSyns vns site+ ]+ return (dataDec, dispatchDec)++mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b+mkMDS f rh = MkDispatchSettings+ { mdsRunHandler = rh+ , mdsSubDispatcher =+ [|\parentRunner getSub toParent env -> yesodSubDispatch+ YesodSubRunnerEnv+ { ysreParentRunner = parentRunner+ , ysreGetSub = getSub+ , ysreToParentRoute = toParent+ , ysreParentEnv = env+ }+ |]+ , mdsGetPathInfo = [|W.pathInfo|]+ , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]+ , mdsMethod = [|W.requestMethod|]+ , mds404 = [|void notFound|]+ , mds405 = [|void badMethod|]+ , mdsGetHandler = defaultGetHandler+ , mdsUnwrapper = f+ }++-- | If the generation of @'YesodDispatch'@ instance require finer+-- control of the types, contexts etc. using this combinator. You will+-- hardly need this generality. However, in certain situations, like+-- when writing library/plugin for yesod, this combinator becomes+-- handy.+mkDispatchInstance :: Type -- ^ The master site type+ -> Cxt -- ^ Context of the instance+ -> (Exp -> Q Exp) -- ^ Unwrap handler+ -> [ResourceTree c] -- ^ The resource+ -> DecsQ+mkDispatchInstance master cxt f res = do+ clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res+ let thisDispatch = FunD 'yesodDispatch [clause']+ return [instanceD cxt yDispatch [thisDispatch]]+ where+ yDispatch = ConT ''YesodDispatch `AppT` master++mkYesodSubDispatch :: [ResourceTree a] -> Q Exp+mkYesodSubDispatch res = do+ clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res+ inner <- newName "inner"+ let innerFun = FunD inner [clause']+ helper <- newName "helper"+ let fun = FunD helper+ [ Clause+ []+ (NormalB $ VarE inner)+ [innerFun]+ ]+ return $ LetE [fun] (VarE helper)++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing
+ src/Yesod/Core/Internal/Util.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+module Yesod.Core.Internal.Util+ ( putTime+ , getTime+ , formatW3+ , formatRFC1123+ , formatRFC822+ , getCurrentMaxExpiresRFC1123+ ) where++import Data.Int (Int64)+import Data.Serialize (Get, Put, Serialize (..))+import qualified Data.Text as T+import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),+ DiffTime, UTCTime (..), formatTime,+ getCurrentTime, addUTCTime, defaultTimeLocale)++putTime :: UTCTime -> Put+putTime (UTCTime d t) =+ let d' = fromInteger $ toModifiedJulianDay d+ t' = fromIntegral $ fromEnum (t / diffTimeScale)+ in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')++getTime :: Get UTCTime+getTime = do+ val <- get+ let (d, t) = val `divMod` posixDayLength_int64+ d' = ModifiedJulianDay $! fromIntegral d+ t' = fromIntegral t+ d' `seq` t' `seq` return (UTCTime d' t')++posixDayLength_int64 :: Int64+posixDayLength_int64 = 86400++diffTimeScale :: DiffTime+diffTimeScale = 1e12++-- | Format a 'UTCTime' in W3 format.+formatW3 :: UTCTime -> T.Text+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"++-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++-- | Format as per RFC 822.+formatRFC822 :: UTCTime -> T.Text+formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"++{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry+date on a resource that never expires. See RFC 2616 section 14.21 for details.+-}+getCurrentMaxExpiresRFC1123 :: IO T.Text+getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
+ src/Yesod/Core/Json.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Yesod.Core.Json+ ( -- * Convert from a JSON value+ defaultLayoutJson+ , jsonToRepJson+ , returnJson+ , returnJsonEncoding+ , provideJson++ -- * Convert to a JSON value+ , parseCheckJsonBody+ , parseInsecureJsonBody+ , requireCheckJsonBody+ , requireInsecureJsonBody+ -- ** Deprecated JSON conversion+ , parseJsonBody+ , parseJsonBody_+ , requireJsonBody++ -- * Produce JSON values+ , J.Value (..)+ , J.ToJSON (..)+ , J.FromJSON (..)+ , array+ , object+ , (.=)+ , (J..:)++ -- * Convenience functions+ , jsonOrRedirect+ , jsonEncodingOrRedirect+ , acceptsJson+ ) where++import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)+import Control.Monad.Trans.Writer (Writer)+import Data.Monoid (Endo)+import Yesod.Core.Content (TypedContent)+import Yesod.Core.Types (reqAccept)+import Yesod.Core.Class.Yesod (defaultLayout, Yesod)+import Yesod.Core.Class.Handler+import Yesod.Core.Widget (WidgetFor)+import Yesod.Routes.Class+import qualified Data.Aeson as J+import qualified Data.Aeson.Parser as JP+import Data.Aeson ((.=), object)+import Data.Conduit.Attoparsec (sinkParser)+import Data.Text (pack)+import qualified Data.Vector as V+import Data.Conduit+import Data.Conduit.Lift+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (listToMaybe)+import Control.Monad (liftM)++-- | Provide both an HTML and JSON representation for a piece of+-- data, using the default layout for the HTML output+-- ('defaultLayout').+--+-- @since 0.3.0+defaultLayoutJson :: (Yesod site, J.ToJSON a)+ => WidgetFor site () -- ^ HTML+ -> HandlerFor site a -- ^ JSON+ -> HandlerFor site TypedContent+defaultLayoutJson w json = selectRep $ do+ provideRep $ defaultLayout w+ provideRep $ fmap J.toEncoding json++-- | Wraps a data type in a 'RepJson'. The data type must+-- support conversion to JSON via 'J.ToJSON'.+--+-- @since 0.3.0+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value+jsonToRepJson = return . J.toJSON+{-# DEPRECATED jsonToRepJson "Use returnJson instead" #-}++-- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function.+--+-- @since 1.2.1+returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value+returnJson = return . J.toJSON++-- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.+--+-- @since 1.4.21+returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding+returnJsonEncoding = return . J.toEncoding++-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s+-- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.+--+-- @since 1.2.1+provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()+provideJson = provideRep . return . J.toEncoding++-- | Same as 'parseInsecureJsonBody'+--+-- @since 0.3.0+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseJsonBody = parseInsecureJsonBody+{-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-}++-- | Same as 'parseCheckJsonBody', but does not check that the mime type+-- indicates JSON content.+--+-- Note: This function is vulnerable to CSRF attacks.+--+-- @since 1.6.11+parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseInsecureJsonBody = do+ eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')+ return $ case eValue of+ Left e -> J.Error $ show e+ Right value -> J.fromJSON value++-- | Parse the request body to a data type as a JSON value. The+-- data type must support conversion from JSON via 'J.FromJSON'.+-- If you want the raw JSON value, just ask for a @'J.Result'+-- 'J.Value'@.+--+-- The MIME type must indicate JSON content. Requiring a JSON+-- content-type helps secure your site against CSRF attacks+-- (browsers will perform POST requests for form and text/plain+-- content-types without doing a CORS check, and those content-types+-- can easily contain valid JSON).+--+-- Note that this function will consume the request body. As such, calling it+-- twice will result in a parse error on the second call, since the request+-- body will no longer be available.+--+-- @since 0.3.0+parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseCheckJsonBody = do+ mct <- lookupHeader "content-type"+ case fmap (B8.takeWhile (/= ';')) mct of+ Just "application/json" -> parseInsecureJsonBody+ _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a+parseJsonBody_ = requireInsecureJsonBody+{-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireJsonBody = requireInsecureJsonBody+{-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-}++-- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse+-- error.+--+-- @since 1.6.11+requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireInsecureJsonBody = do+ ra <- parseInsecureJsonBody+ case ra of+ J.Error s -> invalidArgs [pack s]+ J.Success a -> return a++-- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse+-- error.+requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireCheckJsonBody = do+ ra <- parseCheckJsonBody+ case ra of+ J.Error s -> invalidArgs [pack s]+ J.Success a -> return a++-- | Convert a list of values to an 'J.Array'.+array :: J.ToJSON a => [a] -> J.Value+array = J.Array . V.fromList . map J.toJSON++-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different+-- response based on Accept headers:+--+-- 1. 200 with JSON data if the client prefers+-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').+--+-- 2. 3xx otherwise, following the PRG pattern.+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)+ => Route (HandlerSite m) -- ^ Redirect target+ -> a -- ^ Data to send via JSON+ -> m J.Value+jsonOrRedirect = jsonOrRedirect' J.toJSON++-- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different+-- response based on Accept headers:+--+-- 1. 200 with JSON data if the client prefers+-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').+--+-- 2. 3xx otherwise, following the PRG pattern.+-- @since 1.4.21+jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)+ => Route (HandlerSite m) -- ^ Redirect target+ -> a -- ^ Data to send via JSON+ -> m J.Encoding+jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding++jsonOrRedirect' :: MonadHandler m+ => (a -> b)+ -> Route (HandlerSite m) -- ^ Redirect target+ -> a -- ^ Data to send via JSON+ -> m b+jsonOrRedirect' f r j = do+ q <- acceptsJson+ if q then return (f j)+ else redirect r++-- | Returns @True@ if the client prefers @application\/json@ as+-- indicated by the @Accept@ HTTP header.+acceptsJson :: MonadHandler m => m Bool+acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))+ . listToMaybe+ . reqAccept)+ `liftM` getRequest
+ src/Yesod/Core/TypeCache.hs view
@@ -0,0 +1,96 @@+-- | a module for caching a monadic action based on its return type+--+-- The cache is a HashMap where the key uses the TypeReP from Typeable.+-- The value stored is toDyn from Dynamic to support arbitrary value types in the same Map.+--+-- un-exported newtype wrappers should be used to maintain unique keys in the cache.+-- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.+--+-- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'+module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where++import Prelude hiding (lookup)+import Data.Typeable (Typeable, TypeRep, typeOf)+import Data.HashMap.Strict+import Data.ByteString (ByteString)+import Data.Dynamic (Dynamic, toDyn, fromDynamic)++type TypeMap = HashMap TypeRep Dynamic+type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic++-- | avoid performing the same action multiple times.+-- Values are stored by their TypeRep from Typeable.+-- Therefore, you should use un-exported newtype wrappers for each cache.+--+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.+--+-- In Yesod, this is used for a request-local cache that is cleared at the end of every request.+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>+--+-- Since 1.4.0+cached :: (Monad m, Typeable a)+ => TypeMap+ -> m a -- ^ cache the result of this action+ -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit+cached cache action = case cacheGet cache of+ Just val -> return $ Right val+ Nothing -> do+ val <- action+ return $ Left (cacheSet val cache, val)++-- | Retrieves a value from the cache+--+-- @since 1.6.10+cacheGet :: Typeable a => TypeMap -> Maybe a+cacheGet cache = res+ where+ res = lookup (typeOf $ fromJust res) cache >>= fromDynamic+ fromJust :: Maybe a -> a+ fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"++-- | Sets a value in the cache+--+-- @since 1.6.10+cacheSet :: (Typeable a)+ => a+ -> TypeMap+ -> TypeMap+cacheSet v cache = insert (typeOf v) (toDyn v) cache++-- | similar to 'cached'.+-- 'cached' can only cache a single value per type.+-- 'cachedBy' stores multiple values per type by indexing on a ByteString key+--+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.+-- You can turn those parameters into a ByteString cache key.+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.+--+-- Since 1.4.0+cachedBy :: (Monad m, Typeable a)+ => KeyedTypeMap+ -> ByteString -- ^ a cache key+ -> m a -- ^ cache the result of this action+ -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit+cachedBy cache k action = case cacheByGet k cache of+ Just val -> return $ Right val+ Nothing -> do+ val <- action+ return $ Left (cacheBySet k val cache, val)++-- | Retrieves a value from the keyed cache+--+-- @since 1.6.10+cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a+cacheByGet key c = res+ where+ res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic+ fromJust :: Maybe a -> a+ fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"++-- | Sets a value in the keyed cache+--+-- @since 1.6.10+cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap+cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache
+ src/Yesod/Core/Types.hs view
@@ -0,0 +1,554 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Yesod.Core.Types where++import qualified Data.ByteString.Builder as BB+import Control.Arrow (first)+import Control.Exception (Exception)+import Control.Monad (ap)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Logger (LogLevel, LogSource,+ MonadLogger (..))+import Control.Monad.Primitive (PrimMonad (..))+import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.CaseInsensitive (CI)+import Data.Conduit (Flush, ConduitT)+import Data.IORef (IORef, modifyIORef')+import Data.Map (Map, unionWith)+import qualified Data.Map as Map+import Data.Monoid (Endo (..), Last (..))+import Data.Semigroup (Semigroup(..))+import Data.Serialize (Serialize (..),+ putByteString)+import Data.String (IsString (fromString))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TBuilder+import Data.Time (UTCTime)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Loc)+import qualified Network.HTTP.Types as H+import Network.Wai (FilePart,+ RequestBodyLength)+import qualified Network.Wai as W+import qualified Network.Wai.Parse as NWP+import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)+import Network.Wai.Logger (DateCacheGetter)+import Text.Blaze.Html (Html, toHtml)+import Text.Hamlet (HtmlUrl)+import Text.Julius (JavascriptUrl)+import Web.Cookie (SetCookie)+import Yesod.Core.Internal.Util (getTime, putTime)+import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))+import Control.Monad.Reader (MonadReader (..))+import Control.DeepSeq (NFData (rnf))+import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)+import Control.Monad.Logger (MonadLoggerIO (..))+import UnliftIO (MonadUnliftIO (..), UnliftIO (..))++-- Sessions+type SessionMap = Map Text ByteString++type SaveSession = SessionMap -- ^ The session contents after running the handler+ -> IO [Header]++newtype SessionBackend = SessionBackend+ { sbLoadSession :: W.Request+ -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session+ }++data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap+ deriving (Show, Read)+instance Serialize SessionCookie where+ put (SessionCookie a b c) = do+ either putTime putByteString a+ put b+ put (map (first T.unpack) $ Map.toList c)++ get = do+ a <- getTime+ b <- get+ c <- map (first T.pack) <$> get+ return $ SessionCookie (Left a) b (Map.fromList c)++data ClientSessionDateCache =+ ClientSessionDateCache {+ csdcNow :: !UTCTime+ , csdcExpires :: !UTCTime+ , csdcExpiresSerialized :: !ByteString+ } deriving (Eq, Show)++-- | The parsed request information. This type augments the standard WAI+-- 'W.Request' with additional information.+data YesodRequest = YesodRequest+ { reqGetParams :: ![(Text, Text)]+ -- ^ Same as 'W.queryString', but decoded to @Text@.+ , reqCookies :: ![(Text, Text)]+ , reqWaiRequest :: !W.Request+ , reqLangs :: ![Text]+ -- ^ Languages which the client supports. This is an ordered list by preference.+ , reqToken :: !(Maybe Text)+ -- ^ A random, session-specific token used to prevent CSRF attacks.+ , reqSession :: !SessionMap+ -- ^ Initial session sent from the client.+ --+ -- Since 1.2.0+ , reqAccept :: ![ContentType]+ -- ^ An ordered list of the accepted content types.+ --+ -- Since 1.2.0+ }++-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,+-- or a higher-level data structure which Yesod will turn into a @Response@.+data YesodResponse+ = YRWai !W.Response+ | YRWaiApp !W.Application+ | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap++-- | A tuple containing both the POST parameters and submitted files.+type RequestBodyContents =+ ( [(Text, Text)]+ , [(Text, FileInfo)]+ )++data FileInfo = FileInfo+ { fileName :: !Text+ , fileContentType :: !Text+ , fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ())+ , fileMove :: !(FilePath -> IO ())+ }++data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)+ | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)+ | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))++-- | How to determine the root of the application for constructing URLs.+--+-- Note that future versions of Yesod may add new constructors without bumping+-- the major version number. As a result, you should /not/ pattern match on+-- @Approot@ values.+data Approot master = ApprootRelative -- ^ No application root.+ | ApprootStatic !Text+ | ApprootMaster !(master -> Text)+ | ApprootRequest !(master -> W.Request -> Text)++type ResolvedApproot = Text++data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text+ deriving (Eq, Show, Read)++data ScriptLoadPosition master+ = BottomOfBody+ | BottomOfHeadBlocking+ | BottomOfHeadAsync !(BottomOfHeadAsync master)++type BottomOfHeadAsync master+ = [Text] -- ^ urls to load asynchronously+ -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion+ -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head>++type Texts = [Text]++-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized.+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }++-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.+--+-- @since 1.4.34+newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }++data RunHandlerEnv child site = RunHandlerEnv+ { rheRender :: !(Route site -> [(Text, Text)] -> Text)+ , rheRoute :: !(Maybe (Route child))+ , rheRouteToMaster :: !(Route child -> Route site)+ , rheSite :: !site+ , rheChild :: !child+ , rheUpload :: !(RequestBodyLength -> FileUpload)+ , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())+ , rheOnError :: !(ErrorResponse -> YesodApp)+ -- ^ How to respond when an error is thrown internally.+ --+ -- Since 1.2.0+ , rheMaxExpires :: !Text+ }++data HandlerData child site = HandlerData+ { handlerRequest :: !YesodRequest+ , handlerEnv :: !(RunHandlerEnv child site)+ , handlerState :: !(IORef GHState)+ , handlerResource :: !InternalState+ }++data YesodRunnerEnv site = YesodRunnerEnv+ { yreLogger :: !Logger+ , yreSite :: !site+ , yreSessionBackend :: !(Maybe SessionBackend)+ , yreGen :: !(IO Int)+ -- ^ Generate a random number+ , yreGetMaxExpires :: !(IO Text)+ }++data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv+ { ysreParentRunner :: !(ParentRunner parent)+ , ysreGetSub :: !(parent -> sub)+ , ysreToParentRoute :: !(Route sub -> Route parent)+ , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?+ }++type ParentRunner parent+ = HandlerFor parent TypedContent+ -> YesodRunnerEnv parent+ -> Maybe (Route parent)+ -> W.Application++-- | A generic handler monad, which can have a different subsite and master+-- site. We define a newtype for better error message.+newtype HandlerFor site a = HandlerFor+ { unHandlerFor :: HandlerData site site -> IO a+ }+ deriving Functor++data GHState = GHState+ { ghsSession :: !SessionMap+ , ghsRBC :: !(Maybe RequestBodyContents)+ , ghsIdent :: !Int+ , ghsCache :: !TypeMap+ , ghsCacheBy :: !KeyedTypeMap+ , ghsHeaders :: !(Endo [Header])+ }++-- | An extension of the basic WAI 'W.Application' datatype to provide extra+-- features needed by Yesod. Users should never need to use this directly, as+-- the 'HandlerT' monad and template haskell code should hide it away.+type YesodApp = YesodRequest -> ResourceT IO YesodResponse++-- | A generic widget, allowing specification of both the subsite and master+-- site datatypes. While this is simply a @WriterT@, we define a newtype for+-- better error messages.+newtype WidgetFor site a = WidgetFor+ { unWidgetFor :: WidgetData site -> IO a+ }+ deriving Functor++data WidgetData site = WidgetData+ { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))+ , wdHandler :: {-# UNPACK #-} !(HandlerData site site)+ }++instance a ~ () => Monoid (WidgetFor site a) where+ mempty = return ()+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+instance a ~ () => Semigroup (WidgetFor site a) where+ x <> y = x >> y++-- | A 'String' can be trivially promoted to a widget.+--+-- For example, in a yesod-scaffold site you could use:+--+-- @getHomeR = do defaultLayout "Widget text"@+instance a ~ () => IsString (WidgetFor site a) where+ fromString = toWidget . toHtml . T.pack+ where toWidget x = tellWidget mempty { gwdBody = Body (const x) }++tellWidget :: GWData (Route site) -> WidgetFor site ()+tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)++type RY master = Route master -> [(Text, Text)] -> Text++-- | Newtype wrapper allowing injection of arbitrary content into CSS.+--+-- Usage:+--+-- > toWidget $ CssBuilder "p { color: red }"+--+-- Since: 1.1.3+newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }++-- | Content for a web page. By providing this datatype, we can easily create+-- generic site templates, which would have the type signature:+--+-- > PageContent url -> HtmlUrl url+data PageContent url = PageContent+ { pageTitle :: !Html+ , pageHead :: !(HtmlUrl url)+ , pageBody :: !(HtmlUrl url)+ }++data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.+ | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())+ | ContentFile !FilePath !(Maybe FilePart)+ | ContentDontEvaluate !Content++data TypedContent = TypedContent !ContentType !Content++type RepHtml = Html+{-# DEPRECATED RepHtml "Please use Html instead" #-}+newtype RepJson = RepJson Content+newtype RepPlain = RepPlain Content+newtype RepXml = RepXml Content++type ContentType = ByteString -- FIXME Text?++-- | Prevents a response body from being fully evaluated before sending the+-- request.+--+-- Since 1.1.0+newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }++-- | Responses to indicate some form of an error occurred.+data ErrorResponse =+ NotFound+ | InternalError !Text+ | InvalidArgs ![Text]+ | NotAuthenticated+ | PermissionDenied !Text+ | BadMethod !H.Method+ deriving (Show, Eq, Typeable, Generic)+instance NFData ErrorResponse++----- header stuff+-- | Headers to be added to a 'Result'.+data Header =+ AddCookie !SetCookie+ | DeleteCookie !ByteString !ByteString+ -- ^ name and path+ | Header !(CI ByteString) !ByteString+ -- ^ key and value+ deriving (Eq, Show)++-- FIXME In the next major version bump, let's just add strictness annotations+-- to Header (and probably everywhere else). We can also add strictness+-- annotations to SetCookie in the cookie package.+instance NFData Header where+ rnf (AddCookie x) = rnf x+ rnf (DeleteCookie x y) = x `seq` y `seq` ()+ rnf (Header x y) = x `seq` y `seq` ()++data Location url = Local !url | Remote !Text+ deriving (Show, Eq)++-- | A diff list that does not directly enforce uniqueness.+-- When creating a widget Yesod will use nub to make it unique.+newtype UniqueList x = UniqueList ([x] -> [x])++data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }+ deriving (Show, Eq)+data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }+ deriving (Show, Eq)+newtype Title = Title { unTitle :: Html }++newtype Head url = Head (HtmlUrl url)+ deriving Monoid+instance Semigroup (Head url) where+ (<>) = mappend+newtype Body url = Body (HtmlUrl url)+ deriving Monoid+instance Semigroup (Body url) where+ (<>) = mappend++type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder++data GWData a = GWData+ { gwdBody :: !(Body a)+ , gwdTitle :: !(Last Title)+ , gwdScripts :: !(UniqueList (Script a))+ , gwdStylesheets :: !(UniqueList (Stylesheet a))+ , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type+ , gwdJavascript :: !(Maybe (JavascriptUrl a))+ , gwdHead :: !(Head a)+ }+instance Monoid (GWData a) where+ mempty = GWData mempty mempty mempty mempty mempty mempty mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+instance Semigroup (GWData a) where+ GWData a1 a2 a3 a4 a5 a6 a7 <>+ GWData b1 b2 b3 b4 b5 b6 b7 = GWData+ (mappend a1 b1)+ (mappend a2 b2)+ (mappend a3 b3)+ (mappend a4 b4)+ (unionWith mappend a5 b5)+ (mappend a6 b6)+ (mappend a7 b7)++data HandlerContents =+ HCContent !H.Status !TypedContent+ | HCError !ErrorResponse+ | HCSendFile !ContentType !FilePath !(Maybe FilePart)+ | HCRedirect !H.Status !Text+ | HCCreated !Text+ | HCWai !W.Response+ | HCWaiApp !W.Application+ deriving Typeable++instance Show HandlerContents where+ show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)+ show (HCError e) = "HCError " ++ show e+ show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)+ show (HCRedirect s t) = "HCRedirect " ++ show (s, t)+ show (HCCreated t) = "HCCreated " ++ show t+ show (HCWai _) = "HCWai"+ show (HCWaiApp _) = "HCWaiApp"+instance Exception HandlerContents++-- Instances for WidgetFor+instance Applicative (WidgetFor site) where+ pure = WidgetFor . const . pure+ (<*>) = ap+instance Monad (WidgetFor site) where+ return = pure+ WidgetFor x >>= f = WidgetFor $ \wd -> do+ a <- x wd+ unWidgetFor (f a) wd+instance MonadIO (WidgetFor site) where+ liftIO = WidgetFor . const+-- | @since 1.6.7+instance PrimMonad (WidgetFor site) where+ type PrimState (WidgetFor site) = PrimState IO+ primitive = liftIO . primitive+-- | @since 1.4.38+instance MonadUnliftIO (WidgetFor site) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = WidgetFor $ \wd ->+ return (UnliftIO (flip unWidgetFor wd))+instance MonadReader (WidgetData site) (WidgetFor site) where+ ask = WidgetFor return+ local f (WidgetFor g) = WidgetFor $ g . f++instance MonadThrow (WidgetFor site) where+ throwM = liftIO . throwM++instance MonadResource (WidgetFor site) where+ liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler++instance MonadLogger (WidgetFor site) where+ monadLoggerLog a b c d = WidgetFor $ \wd ->+ rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)++instance MonadLoggerIO (WidgetFor site) where+ askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler++-- Instances for HandlerT+instance Applicative (HandlerFor site) where+ pure = HandlerFor . const . return+ (<*>) = ap+instance Monad (HandlerFor site) where+ return = pure+ HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r+instance MonadIO (HandlerFor site) where+ liftIO = HandlerFor . const+-- | @since 1.6.7+instance PrimMonad (HandlerFor site) where+ type PrimState (HandlerFor site) = PrimState IO+ primitive = liftIO . primitive+instance MonadReader (HandlerData site site) (HandlerFor site) where+ ask = HandlerFor return+ local f (HandlerFor g) = HandlerFor $ g . f++-- | @since 1.4.38+instance MonadUnliftIO (HandlerFor site) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = HandlerFor $ \r ->+ return (UnliftIO (flip unHandlerFor r))++instance MonadThrow (HandlerFor site) where+ throwM = liftIO . throwM++instance MonadResource (HandlerFor site) where+ liftResourceT f = HandlerFor $ runInternalState f . handlerResource++instance MonadLogger (HandlerFor site) where+ monadLoggerLog a b c d = HandlerFor $ \hd ->+ rheLog (handlerEnv hd) a b c (toLogStr d)++instance MonadLoggerIO (HandlerFor site) where+ askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))++instance Monoid (UniqueList x) where+ mempty = UniqueList id+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+instance Semigroup (UniqueList x) where+ UniqueList x <> UniqueList y = UniqueList $ x . y++instance IsString Content where+ fromString = flip ContentBuilder Nothing . BB.stringUtf8++instance RenderRoute WaiSubsite where+ data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]+ deriving (Show, Eq, Read, Ord)+ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)+instance ParseRoute WaiSubsite where+ parseRoute (x, y) = Just $ WaiSubsiteRoute x y++instance RenderRoute WaiSubsiteWithAuth where+ data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]+ deriving (Show, Eq, Read, Ord)+ renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)++instance ParseRoute WaiSubsiteWithAuth where+ parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y++data Logger = Logger+ { loggerSet :: !LoggerSet+ , loggerDate :: !DateCacheGetter+ }++loggerPutStr :: Logger -> LogStr -> IO ()+loggerPutStr (Logger ls _) = pushLogStr ls++-- | A handler monad for subsite+--+-- @since 1.6.0+newtype SubHandlerFor sub master a = SubHandlerFor+ { unSubHandlerFor :: HandlerData sub master -> IO a+ }+ deriving Functor++instance Applicative (SubHandlerFor child master) where+ pure = SubHandlerFor . const . return+ (<*>) = ap+instance Monad (SubHandlerFor child master) where+ return = pure+ SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r+instance MonadIO (SubHandlerFor child master) where+ liftIO = SubHandlerFor . const+instance MonadReader (HandlerData child master) (SubHandlerFor child master) where+ ask = SubHandlerFor return+ local f (SubHandlerFor g) = SubHandlerFor $ g . f++-- | @since 1.4.38+instance MonadUnliftIO (SubHandlerFor child master) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = SubHandlerFor $ \r ->+ return (UnliftIO (flip unSubHandlerFor r))++instance MonadThrow (SubHandlerFor child master) where+ throwM = liftIO . throwM++instance MonadResource (SubHandlerFor child master) where+ liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource++instance MonadLogger (SubHandlerFor child master) where+ monadLoggerLog a b c d = SubHandlerFor $ \sd ->+ rheLog (handlerEnv sd) a b c (toLogStr d)++instance MonadLoggerIO (SubHandlerFor child master) where+ askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
+ src/Yesod/Core/Unsafe.hs view
@@ -0,0 +1,25 @@+-- | This is designed to be used as+--+-- > import qualified Yesod.Core.Unsafe as Unsafe+--+-- This serves as a reminder that the functions are unsafe to use in many situations.+module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where++import Yesod.Core.Internal.Run (runFakeHandler)++import Yesod.Core.Types+import Yesod.Core.Class.Yesod+import Control.Monad.IO.Class (MonadIO)++-- | designed to be used as+--+-- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger+fakeHandlerGetLogger :: (Yesod site, MonadIO m)+ => (site -> Logger)+ -> site+ -> HandlerFor site a+ -> m a+fakeHandlerGetLogger getLogger app f =+ runFakeHandler mempty getLogger app f+ >>= either (error . ("runFakeHandler issue: " `mappend`) . show)+ return
+ src/Yesod/Core/Widget.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier+-- generator, allowing you to create truly modular HTML components.+module Yesod.Core.Widget+ ( -- * Datatype+ WidgetT+ , WidgetFor+ , PageContent (..)+ -- * Special Hamlet quasiquoter/TH for Widgets+ , whamlet+ , whamletFile+ , ihamletToRepHtml+ , ihamletToHtml+ -- * Convert to Widget+ , ToWidget (..)+ , ToWidgetHead (..)+ , ToWidgetBody (..)+ , ToWidgetMedia (..)+ -- * Creating+ -- ** Head of page+ , setTitle+ , setTitleI+ -- ** CSS+ , addStylesheet+ , addStylesheetAttrs+ , addStylesheetRemote+ , addStylesheetRemoteAttrs+ , addStylesheetEither+ , CssBuilder (..)+ -- ** Javascript+ , addScript+ , addScriptAttrs+ , addScriptRemote+ , addScriptRemoteAttrs+ , addScriptEither+ -- * Subsites+ , handlerToWidget+ -- * Internal+ , whamletFileWithSettings+ , asWidgetT+ ) where++import Data.Monoid+import qualified Text.Blaze.Html5 as H+import Text.Hamlet+import Text.Cassius+import Text.Julius+import Yesod.Routes.Class+import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)+import Text.Shakespeare.I18N (RenderMessage)+import Data.Text (Text)+import qualified Data.Map as Map+import Language.Haskell.TH.Quote (QuasiQuoter)+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)++import qualified Text.Hamlet as NP+import Data.Text.Lazy.Builder (fromLazyText)+import Text.Blaze.Html (toHtml, preEscapedToMarkup)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB++import Yesod.Core.Types+import Yesod.Core.Class.Handler++type WidgetT site (m :: * -> *) = WidgetFor site+{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}++preEscapedLazyText :: TL.Text -> Html+preEscapedLazyText = preEscapedToMarkup++class ToWidget site a where+ toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidget site (render -> Html) where+ toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty+instance render ~ RY site => ToWidget site (render -> Css) where+ toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x+instance ToWidget site Css where+ toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x+instance render ~ RY site => ToWidget site (render -> CssBuilder) where+ toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty+instance ToWidget site CssBuilder where+ toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty+instance render ~ RY site => ToWidget site (render -> Javascript) where+ toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+instance ToWidget site Javascript where+ toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty+instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where+ toWidget = liftWidget+instance ToWidget site Html where+ toWidget = toWidget . const+-- | @since 1.4.28+instance ToWidget site Text where+ toWidget = toWidget . toHtml+-- | @since 1.4.28+instance ToWidget site TL.Text where+ toWidget = toWidget . toHtml+-- | @since 1.4.28+instance ToWidget site TB.Builder where+ toWidget = toWidget . toHtml++-- | Allows adding some CSS to the page with a specific media type.+--+-- Since 1.2+class ToWidgetMedia site a where+ -- | Add the given content to the page, but only for the given media type.+ --+ -- Since 1.2+ toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)+ => Text -- ^ media value+ -> a+ -> m ()+instance render ~ RY site => ToWidgetMedia site (render -> Css) where+ toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x+instance ToWidgetMedia site Css where+ toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x+instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where+ toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty+instance ToWidgetMedia site CssBuilder where+ toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty++class ToWidgetBody site a where+ toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetBody site (render -> Html) where+ toWidgetBody = toWidget+instance render ~ RY site => ToWidgetBody site (render -> Javascript) where+ toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetBody site Javascript where+ toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j+instance ToWidgetBody site Html where+ toWidgetBody = toWidget++class ToWidgetHead site a where+ toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetHead site (render -> Html) where+ toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head+instance render ~ RY site => ToWidgetHead site (render -> Css) where+ toWidgetHead = toWidget+instance ToWidgetHead site Css where+ toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where+ toWidgetHead = toWidget+instance ToWidgetHead site CssBuilder where+ toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> Javascript) where+ toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetHead site Javascript where+ toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j+instance ToWidgetHead site Html where+ toWidgetHead = toWidgetHead . const++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitle :: MonadWidget m => Html -> m ()+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()+setTitleI msg = do+ mr <- getMessageRender+ setTitle $ toHtml $ mr msg++-- | Link to the specified local stylesheet.+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()+addStylesheet = flip addStylesheetAttrs []++-- | Link to the specified local stylesheet.+addStylesheetAttrs :: MonadWidget m+ => Route (HandlerSite m)+ -> [(Text, Text)]+ -> m ()+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty++-- | Link to the specified remote stylesheet.+addStylesheetRemote :: MonadWidget m => Text -> m ()+addStylesheetRemote = flip addStylesheetRemoteAttrs []++-- | Link to the specified remote stylesheet.+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty++addStylesheetEither :: MonadWidget m+ => Either (Route (HandlerSite m)) Text+ -> m ()+addStylesheetEither = either addStylesheet addStylesheetRemote++addScriptEither :: MonadWidget m+ => Either (Route (HandlerSite m)) Text+ -> m ()+addScriptEither = either addScript addScriptRemote++-- | Link to the specified local script.+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()+addScript = flip addScriptAttrs []++-- | Link to the specified local script.+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()+addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty++-- | Link to the specified remote script.+addScriptRemote :: MonadWidget m => Text -> m ()+addScriptRemote = flip addScriptRemoteAttrs []++-- | Link to the specified remote script.+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty++whamlet :: QuasiQuoter+whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings++whamletFile :: FilePath -> Q Exp+whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings++whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp+whamletFileWithSettings = NP.hamletFileWithSettings rules++asWidgetT :: WidgetT site m () -> WidgetT site m ()+asWidgetT = id++rules :: Q NP.HamletRules+rules = do+ ah <- [|asWidgetT . toWidget|]+ let helper qg f = do+ x <- newName "urender"+ e <- f $ VarE x+ let e' = LamE [VarP x] e+ g <- qg+ bind <- [|(>>=)|]+ return $ InfixE (Just g) bind (Just e')+ let ur f = do+ let env = NP.Env+ (Just $ helper [|getUrlRenderParams|])+ (Just $ helper [|fmap (toHtml .) getMessageRender|])+ f env+ return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)+ => HtmlUrlI18n message (Route (HandlerSite m))+ -> m Html+ihamletToRepHtml = ihamletToHtml+{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+--+-- Since 1.2.1+ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)+ => HtmlUrlI18n message (Route (HandlerSite m))+ -> m Html+ihamletToHtml ih = do+ urender <- getUrlRenderParams+ mrender <- getMessageRender+ return $ ih (toHtml . mrender) urender++tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()+tell = liftWidget . tellWidget++toUnique :: x -> UniqueList x+toUnique = UniqueList . (:)++handlerToWidget :: HandlerFor site a -> WidgetFor site a+handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
+ src/Yesod/Routes/Class.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Routes.Class+ ( RenderRoute (..)+ , ParseRoute (..)+ , RouteAttrs (..)+ ) where++import Data.Text (Text)+import Data.Set (Set)++class Eq (Route a) => RenderRoute a where+ -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument.+ data Route a+ renderRoute :: Route a+ -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.++class RenderRoute a => ParseRoute a where+ parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.+ -> Maybe (Route a)++class RenderRoute a => RouteAttrs a where+ routeAttrs :: Route a+ -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.
+ src/Yesod/Routes/Overlap.hs view
@@ -0,0 +1,88 @@+-- | Check for overlapping routes.+module Yesod.Routes.Overlap+ ( findOverlapNames+ , Overlap (..)+ ) where++import Yesod.Routes.TH.Types+import Data.List (intercalate)++data Flattened t = Flattened+ { fNames :: [String]+ , fPieces :: [Piece t]+ , fHasSuffix :: Bool+ , fCheck :: CheckOverlap+ }++flatten :: ResourceTree t -> [Flattened t]+flatten =+ go id id True+ where+ go names pieces check (ResourceLeaf r) = return Flattened+ { fNames = names [resourceName r]+ , fPieces = pieces (resourcePieces r)+ , fHasSuffix = hasSuffix $ ResourceLeaf r+ , fCheck = check && resourceCheck r+ }+ go names pieces check (ResourceParent newname check' newpieces children) =+ concatMap (go names' pieces' (check && check')) children+ where+ names' = names . (newname:)+ pieces' = pieces . (newpieces ++)++data Overlap t = Overlap+ { overlapParents :: [String] -> [String] -- ^ parent resource trees+ , overlap1 :: ResourceTree t+ , overlap2 :: ResourceTree t+ }++data OverlapF = OverlapF+ { _overlapF1 :: [String]+ , _overlapF2 :: [String]+ }++overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool++-- No pieces on either side, will overlap regardless of suffix+overlaps [] [] _ _ = True++-- No pieces on the left, will overlap if the left side has a suffix+overlaps [] _ suffixX _ = suffixX++-- Ditto for the right+overlaps _ [] _ suffixY = suffixY++-- Compare the actual pieces+overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =+ piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY++piecesOverlap :: Piece t -> Piece t -> Bool+-- Statics only match if they equal. Dynamics match with anything+piecesOverlap (Static x) (Static y) = x == y+piecesOverlap _ _ = True++findOverlapNames :: [ResourceTree t] -> [(String, String)]+findOverlapNames =+ map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten+ where+ go (OverlapF x y) =+ (go' x, go' y)+ where+ go' = intercalate "/"++findOverlapsF :: [Flattened t] -> [OverlapF]+findOverlapsF [] = []+findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs++findOverlapF :: Flattened t -> Flattened t -> [OverlapF]+findOverlapF x y+ | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]+ | otherwise = []++hasSuffix :: ResourceTree t -> Bool+hasSuffix (ResourceLeaf r) =+ case resourceDispatch r of+ Subsite{} -> True+ Methods Just{} _ -> True+ Methods Nothing _ -> False+hasSuffix ResourceParent{} = True
+ src/Yesod/Routes/Parse.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module Yesod.Routes.Parse+ ( parseRoutes+ , parseRoutesFile+ , parseRoutesNoCheck+ , parseRoutesFileNoCheck+ , parseType+ , parseTypeTree+ , TypeTree (..)+ , dropBracket+ , nameToType+ ) where++import Language.Haskell.TH.Syntax+import Data.Char (isUpper, isLower, isSpace)+import Language.Haskell.TH.Quote+import qualified System.IO as SIO+import Yesod.Routes.TH+import Yesod.Routes.Overlap (findOverlapNames)+import Data.List (foldl', isPrefixOf)+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set++-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the+-- checking. See documentation site for details on syntax.+parseRoutes :: QuasiQuoter+parseRoutes = QuasiQuoter { quoteExp = x }+ where+ x s = do+ let res = resourcesFromString s+ case findOverlapNames res of+ [] -> lift res+ z -> error $ unlines $ "Overlapping routes: " : map show z++parseRoutesFile :: FilePath -> Q Exp+parseRoutesFile = parseRoutesFileWith parseRoutes++parseRoutesFileNoCheck :: FilePath -> Q Exp+parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck++parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp+parseRoutesFileWith qq fp = do+ qAddDependentFile fp+ s <- qRunIO $ readUtf8File fp+ quoteExp qq s++readUtf8File :: FilePath -> IO String+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ SIO.hGetContents h++-- | Same as 'parseRoutes', but performs no overlap checking.+parseRoutesNoCheck :: QuasiQuoter+parseRoutesNoCheck = QuasiQuoter+ { quoteExp = lift . resourcesFromString+ }++-- | Converts a multi-line string to a set of resources. See documentation for+-- the format of this string. This is a partial function which calls 'error' on+-- invalid input.+resourcesFromString :: String -> [ResourceTree String]+resourcesFromString =+ fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')+ where+ parse _ [] = ([], [])+ parse indent (thisLine:otherLines)+ | length spaces < indent = ([], thisLine : otherLines)+ | otherwise = (this others, remainder)+ where+ parseAttr ('!':x) = Just x+ parseAttr _ = Nothing++ stripColonLast =+ go id+ where+ go _ [] = Nothing+ go front [x]+ | null x = Nothing+ | last x == ':' = Just $ front [init x]+ | otherwise = Nothing+ go front (x:xs) = go (front . (x:)) xs++ spaces = takeWhile (== ' ') thisLine+ (others, remainder) = parse indent otherLines'+ (this, otherLines') =+ case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of+ (pattern:rest0)+ | Just (constr:rest) <- stripColonLast rest0+ , Just attrs <- mapM parseAttr rest ->+ let (children, otherLines'') = parse (length spaces + 1) otherLines+ children' = addAttrs attrs children+ (pieces, Nothing, check) = piecesFromStringCheck pattern+ in ((ResourceParent constr check pieces children' :), otherLines'')+ (pattern:constr:rest) ->+ let (pieces, mmulti, check) = piecesFromStringCheck pattern+ (attrs, rest') = takeAttrs rest+ disp = dispatchFromString rest' mmulti+ in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)+ [] -> (id, otherLines)+ _ -> error $ "Invalid resource line: " ++ thisLine++-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).+splitSpaces :: String -> [String]+splitSpaces "" = []+splitSpaces str = + let (rest, piece) = parse $ dropWhile isSpace str in+ piece:(splitSpaces rest)++ where + parse :: String -> ( String, String)+ parse ('{':s) = fmap ('{':) $ parseBracket s+ parse (c:s) | isSpace c = (s, [])+ parse (c:s) = fmap (c:) $ parse s+ parse "" = ("", "")++ parseBracket :: String -> ( String, String)+ parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str+ parseBracket ('}':s) = fmap ('}':) $ parse s+ parseBracket (c:s) = fmap (c:) $ parseBracket s+ parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str++piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)+piecesFromStringCheck s0 =+ (pieces, mmulti, check)+ where+ (s1, check1) = stripBang s0+ (pieces', mmulti') = piecesFromString $ drop1Slash s1+ pieces = map snd pieces'+ mmulti = fmap snd mmulti'+ check = check1 && all fst pieces' && maybe True fst mmulti'++ stripBang ('!':rest) = (rest, False)+ stripBang x = (x, True)++addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]+addAttrs attrs =+ map goTree+ where+ goTree (ResourceLeaf res) = ResourceLeaf (goRes res)+ goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z)++ goRes res =+ res { resourceAttrs = noDupes ++ resourceAttrs res }+ where+ usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res+ used attr =+ case toPair attr of+ Nothing -> False+ Just (key, _) -> key `Set.member` usedKeys+ noDupes = filter (not . used) attrs++ toPair s =+ case break (== '=') s of+ (x, '=':y) -> Just (x, y)+ _ -> Nothing++-- | Take attributes out of the list and put them in the first slot in the+-- result tuple.+takeAttrs :: [String] -> ([String], [String])+takeAttrs =+ go id id+ where+ go x y [] = (x [], y [])+ go x y (('!':attr):rest) = go (x . (attr:)) y rest+ go x y (z:rest) = go x (y . (z:)) rest++dispatchFromString :: [String] -> Maybe String -> Dispatch String+dispatchFromString rest mmulti+ | null rest = Methods mmulti []+ | all (all isUpper) rest = Methods mmulti rest+dispatchFromString [subTyp, subFun] Nothing =+ Subsite subTyp subFun+dispatchFromString [_, _] Just{} =+ error "Subsites cannot have a multipiece"+dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x++piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))+piecesFromString "" = ([], Nothing)+piecesFromString x =+ case (this, rest) of+ (Left typ, ([], Nothing)) -> ([], Just typ)+ (Left _, _) -> error "Multipiece must be last piece"+ (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)+ where+ (y, z) = break (== '/') x+ this = pieceFromString y+ rest = piecesFromString $ drop 1 z++parseType :: String -> Type+parseType orig =+ maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig++parseTypeTree :: String -> Maybe TypeTree+parseTypeTree orig =+ toTypeTree pieces+ where+ pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig+ addDashes [] = []+ addDashes (x:xs) =+ front $ addDashes xs+ where+ front rest+ | x `elem` "()[]" = '-' : x : '-' : rest+ | otherwise = x : rest+ splitOn c s =+ case y' of+ _:y -> x : splitOn c y+ [] -> [x]+ where+ (x, y') = break c s++data TypeTree = TTTerm String+ | TTApp TypeTree TypeTree+ | TTList TypeTree+ deriving (Show, Eq)++toTypeTree :: [String] -> Maybe TypeTree+toTypeTree orig = do+ (x, []) <- gos orig+ return x+ where+ go [] = Nothing+ go ("(":xs) = do+ (x, rest) <- gos xs+ case rest of+ ")":rest' -> Just (x, rest')+ _ -> Nothing+ go ("[":xs) = do+ (x, rest) <- gos xs+ case rest of+ "]":rest' -> Just (TTList x, rest')+ _ -> Nothing+ go (x:xs) = Just (TTTerm x, xs)++ gos xs1 = do+ (t, xs2) <- go xs1+ (ts, xs3) <- gos' id xs2+ Just (foldl' TTApp t ts, xs3)++ gos' front [] = Just (front [], [])+ gos' front (x:xs)+ | x `elem` words ") ]" = Just (front [], x:xs)+ | otherwise = do+ (t, xs') <- go $ x:xs+ gos' (front . (t:)) xs'++ttToType :: TypeTree -> Type+ttToType (TTTerm s) = nameToType s+ttToType (TTApp x y) = ttToType x `AppT` ttToType y+ttToType (TTList t) = ListT `AppT` ttToType t++nameToType :: String -> Type+nameToType t@(h:_) | isLower h = VarT $ mkName t+nameToType t = ConT $ mkName t++pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)+pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)+pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652+pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)++pieceFromString ('*':'!':x) = Left (False, x)+pieceFromString ('+':'!':x) = Left (False, x)++pieceFromString ('!':'*':x) = Left (False, x)+pieceFromString ('!':'+':x) = Left (False, x)++pieceFromString ('*':x) = Left (True, x)+pieceFromString ('+':x) = Left (True, x)++pieceFromString ('!':x) = Right $ (False, Static x)+pieceFromString x = Right $ (True, Static x)++dropBracket :: String -> String+dropBracket str@('{':x) = case break (== '}') x of+ (s, "}") -> s+ _ -> error $ "Unclosed bracket ('{'): " ++ str+dropBracket x = x++-- | If this line ends with a backslash, concatenate it together with the next line.+--+-- @since 1.6.8+lineContinuations :: String -> [String] -> [String]+lineContinuations this [] = [this]+lineContinuations this below@(next:rest) = case unsnoc this of+ Just (this', '\\') -> (this'++next):rest+ _ -> this:below+ where unsnoc s = if null s then Nothing else Just (init s, last s)
+ src/Yesod/Routes/TH.hs view
@@ -0,0 +1,15 @@+module Yesod.Routes.TH+ ( module Yesod.Routes.TH.Types+ -- * Functions+ , module Yesod.Routes.TH.RenderRoute+ , module Yesod.Routes.TH.ParseRoute+ , module Yesod.Routes.TH.RouteAttrs+ -- ** Dispatch+ , module Yesod.Routes.TH.Dispatch+ ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute+import Yesod.Routes.TH.ParseRoute+import Yesod.Routes.TH.RouteAttrs+import Yesod.Routes.TH.Dispatch
+ src/Yesod/Routes/TH/Dispatch.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}+module Yesod.Routes.TH.Dispatch+ ( MkDispatchSettings (..)+ , mkDispatchClause+ , defaultGetHandler+ ) where++import Prelude hiding (exp)+import Language.Haskell.TH.Syntax+import Web.PathPieces+import Data.Maybe (catMaybes)+import Control.Monad (forM)+import Data.List (foldl')+import Control.Arrow (second)+import System.Random (randomRIO)+import Yesod.Routes.TH.Types+import Data.Char (toLower)++data MkDispatchSettings b site c = MkDispatchSettings+ { mdsRunHandler :: Q Exp+ , mdsSubDispatcher :: Q Exp+ , mdsGetPathInfo :: Q Exp+ , mdsSetPathInfo :: Q Exp+ , mdsMethod :: Q Exp+ , mds404 :: Q Exp+ , mds405 :: Q Exp+ , mdsGetHandler :: Maybe String -> String -> Q Exp+ , mdsUnwrapper :: Exp -> Q Exp+ }++data SDC = SDC+ { clause404 :: Clause+ , extraParams :: [Exp]+ , extraCons :: [Exp]+ , envExp :: Exp+ , reqExp :: Exp+ }++-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- Since 1.4.0+mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause+mkDispatchClause MkDispatchSettings {..} resources = do+ suffix <- qRunIO $ randomRIO (1000, 9999 :: Int)+ envName <- newName $ "env" ++ show suffix+ reqName <- newName $ "req" ++ show suffix+ helperName <- newName $ "helper" ++ show suffix++ let envE = VarE envName+ reqE = VarE reqName+ helperE = VarE helperName++ clause404' <- mkClause404 envE reqE+ getPathInfo <- mdsGetPathInfo+ let pathInfo = getPathInfo `AppE` reqE++ let sdc = SDC+ { clause404 = clause404'+ , extraParams = []+ , extraCons = []+ , envExp = envE+ , reqExp = reqE+ }+ clauses <- mapM (go sdc) resources++ return $ Clause+ [VarP envName, VarP reqName]+ (NormalB $ helperE `AppE` pathInfo)+ [FunD helperName $ clauses ++ [clause404']]+ where+ handlePiece :: Piece a -> Q (Pat, Maybe Exp)+ handlePiece (Static str) = return (LitP $ StringL str, Nothing)+ handlePiece (Dynamic _) = do+ x <- newName "dyn"+ let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])+ return (pat, Just $ VarE x)++ handlePieces :: [Piece a] -> Q ([Pat], [Exp])+ handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece++ mkCon :: String -> [Exp] -> Exp+ mkCon name = foldl' AppE (ConE $ mkName name)++ mkPathPat :: Pat -> [Pat] -> Pat+ mkPathPat final =+ foldr addPat final+ where+ addPat x y = ConP '(:) [x, y]++ go :: SDC -> ResourceTree a -> Q Clause+ go sdc (ResourceParent name _check pieces children) = do+ (pats, dyns) <- handlePieces pieces+ let sdc' = sdc+ { extraParams = extraParams sdc ++ dyns+ , extraCons = extraCons sdc ++ [mkCon name dyns]+ }+ childClauses <- mapM (go sdc') children++ restName <- newName "rest"+ let restE = VarE restName+ restP = VarP restName++ helperName <- newName $ "helper" ++ name+ let helperE = VarE helperName++ return $ Clause+ [mkPathPat restP pats]+ (NormalB $ helperE `AppE` restE)+ [FunD helperName $ childClauses ++ [clause404 sdc]]+ go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+ (pats, dyns) <- handlePieces pieces++ (chooseMethod, finalPat) <- handleDispatch dispatch dyns++ return $ Clause+ [mkPathPat finalPat pats]+ (NormalB chooseMethod)+ []+ where+ handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)+ handleDispatch dispatch' dyns =+ case dispatch' of+ Methods multi methods -> do+ (finalPat, mfinalE) <-+ case multi of+ Nothing -> return (ConP '[] [], Nothing)+ Just _ -> do+ multiName <- newName "multi"+ let pat = ViewP (VarE 'fromPathMultiPiece)+ (ConP 'Just [VarP multiName])+ return (pat, Just $ VarE multiName)++ let dynsMulti =+ case mfinalE of+ Nothing -> dyns+ Just e -> dyns ++ [e]+ route' = foldl' AppE (ConE (mkName name)) dynsMulti+ route = foldr AppE route' extraCons+ jroute = ConE 'Just `AppE` route+ allDyns = extraParams ++ dynsMulti+ mkRunExp mmethod = do+ runHandlerE <- mdsRunHandler+ handlerE' <- mdsGetHandler mmethod name+ handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns+ return $ runHandlerE+ `AppE` handlerE+ `AppE` envExp+ `AppE` jroute+ `AppE` reqExp++ func <-+ case methods of+ [] -> mkRunExp Nothing+ _ -> do+ getMethod <- mdsMethod+ let methodE = getMethod `AppE` reqExp+ matches <- forM methods $ \method -> do+ exp <- mkRunExp (Just method)+ return $ Match (LitP $ StringL method) (NormalB exp) []+ match405 <- do+ runHandlerE <- mdsRunHandler+ handlerE <- mds405+ let exp = runHandlerE+ `AppE` handlerE+ `AppE` envExp+ `AppE` jroute+ `AppE` reqExp+ return $ Match WildP (NormalB exp) []+ return $ CaseE methodE $ matches ++ [match405]++ return (func, finalPat)+ Subsite _ getSub -> do+ restPath <- newName "restPath"+ setPathInfoE <- mdsSetPathInfo+ subDispatcherE <- mdsSubDispatcher+ runHandlerE <- mdsRunHandler+ sub <- newName "sub"+ let allDyns = extraParams ++ dyns+ sroute <- newName "sroute"+ let sub2 = LamE [VarP sub]+ (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)+ let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp+ route' = foldl' AppE (ConE (mkName name)) dyns+ route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons+ exp = subDispatcherE+ `AppE` runHandlerE+ `AppE` sub2+ `AppE` route+ `AppE` envExp+ `AppE` reqExp'+ return (exp, VarP restPath)++ mkClause404 envE reqE = do+ handler <- mds404+ runHandler <- mdsRunHandler+ let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE+ return $ Clause [WildP] (NormalB exp) []++defaultGetHandler :: Maybe String -> String -> Q Exp+defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s+defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
+ src/Yesod/Routes/TH/ParseRoute.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH.ParseRoute+ ( -- ** ParseRoute+ mkParseRouteInstance+ ) where++import Yesod.Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import Yesod.Routes.Class+import Yesod.Routes.TH.Dispatch++mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec+mkParseRouteInstance cxt typ ress = do+ cls <- mkDispatchClause+ MkDispatchSettings+ { mdsRunHandler = [|\_ _ x _ -> x|]+ , mds404 = [|error "mds404"|]+ , mds405 = [|error "mds405"|]+ , mdsGetPathInfo = [|fst|]+ , mdsMethod = [|error "mdsMethod"|]+ , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]+ , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]+ , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]+ , mdsUnwrapper = return+ }+ (map removeMethods ress)+ helper <- newName "helper"+ fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]+ return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)+ [ FunD 'parseRoute $ return $ Clause+ []+ (NormalB $ fixer `AppE` VarE helper)+ [FunD helper [cls]]+ ]+ where+ -- We do this in order to ski the unnecessary method parsing+ removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res+ removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z++ removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res }++ fixDispatch (Methods x _) = Methods x []+ fixDispatch x = x++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing
+ src/Yesod/Routes/TH/RenderRoute.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Yesod.Routes.TH.RenderRoute+ ( -- ** RenderRoute+ mkRenderRouteInstance+ , mkRouteCons+ , mkRenderRouteClauses+ ) where++import Yesod.Routes.TH.Types+import Language.Haskell.TH (conT)+import Language.Haskell.TH.Syntax+import Data.Bits (xor)+import Data.Maybe (maybeToList)+import Control.Monad (replicateM)+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Yesod.Routes.Class++-- | Generate the constructors of a route data type.+mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteCons rttypes =+ mconcat <$> mapM mkRouteCon rttypes+ where+ mkRouteCon (ResourceLeaf res) =+ return ([con], [])+ where+ con = NormalC (mkName $ resourceName res)+ $ map (\x -> (notStrict, x))+ $ concat [singles, multi, sub]+ singles = concatMap toSingle $ resourcePieces res+ toSingle Static{} = []+ toSingle (Dynamic typ) = [typ]++ multi = maybeToList $ resourceMulti res++ sub =+ case resourceDispatch res of+ Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]+ _ -> []++ mkRouteCon (ResourceParent name _check pieces children) = do+ (cons, decs) <- mkRouteCons children+#if MIN_VERSION_template_haskell(2,12,0)+ dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])+#else+ dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]+#endif+ return ([con], dec : decs)+ where+ con = NormalC (mkName name)+ $ map (\x -> (notStrict, x))+ $ singles ++ [ConT $ mkName name]++ singles = concatMap toSingle pieces+ toSingle Static{} = []+ toSingle (Dynamic typ) = [typ]++-- | Clauses for the 'renderRoute' method.+mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]+mkRenderRouteClauses =+ mapM go+ where+ isDynamic Dynamic{} = True+ isDynamic _ = False++ go (ResourceParent name _check pieces children) = do+ let cnt = length $ filter isDynamic pieces+ dyns <- replicateM cnt $ newName "dyn"+ child <- newName "child"+ let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]++ pack' <- [|pack|]+ tsp <- [|toPathPiece|]+ let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns++ childRender <- newName "childRender"+ let rr = VarE childRender+ childClauses <- mkRenderRouteClauses children++ a <- newName "a"+ b <- newName "b"++ colon <- [|(:)|]+ let cons y ys = InfixE (Just y) colon (Just ys)+ let pieces' = foldr cons (VarE a) piecesSingle++ let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)++ return $ Clause [pat] (NormalB body) [FunD childRender childClauses]++ go (ResourceLeaf res) = do+ let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+ dyns <- replicateM cnt $ newName "dyn"+ sub <-+ case resourceDispatch res of+ Subsite{} -> return <$> newName "sub"+ _ -> return []+ let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub++ pack' <- [|pack|]+ tsp <- [|toPathPiece|]+ let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++ piecesMulti <-+ case resourceMulti res of+ Nothing -> return $ ListE []+ Just{} -> do+ tmp <- [|toPathMultiPiece|]+ return $ tmp `AppE` VarE (last dyns)++ body <-+ case sub of+ [x] -> do+ rr <- [|renderRoute|]+ a <- newName "a"+ b <- newName "b"++ colon <- [|(:)|]+ let cons y ys = InfixE (Just y) colon (Just ys)+ let pieces = foldr cons (VarE a) piecesSingle++ return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)+ _ -> do+ colon <- [|(:)|]+ let cons a b = InfixE (Just a) colon (Just b)+ return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]++ return $ Clause [pat] (NormalB body) []++ mkPieces _ _ [] _ = []+ mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns+ mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns+ mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"++-- | Generate the 'RenderRoute' instance.+--+-- This includes both the 'Route' associated type and the+-- 'renderRoute' method. This function uses both 'mkRouteCons' and+-- 'mkRenderRouteClasses'.+mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstance cxt typ ress = do+ cls <- mkRenderRouteClauses ress+ (cons, decs) <- mkRouteCons ress+#if MIN_VERSION_template_haskell(2,12,0)+ did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))+ let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)+#else+ did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)+ let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)+#endif+ return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)+ [ did+ , FunD (mkName "renderRoute") cls+ ]+ : sds ++ decs+ where+ clazzes standalone = if standalone `xor` null cxt then+ clazzes'+ else+ []+ clazzes' = [''Show, ''Eq, ''Read]++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing
+ src/Yesod/Routes/TH/RouteAttrs.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+module Yesod.Routes.TH.RouteAttrs+ ( mkRouteAttrsInstance+ ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.Class+import Language.Haskell.TH.Syntax+import Data.Set (fromList)+import Data.Text (pack)++mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec+mkRouteAttrsInstance cxt typ ress = do+ clauses <- mapM (goTree id) ress+ return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)+ [ FunD 'routeAttrs $ concat clauses+ ]++goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]+goTree front (ResourceLeaf res) = return <$> goRes front res+goTree front (ResourceParent name _check pieces trees) =+ concat <$> mapM (goTree front') trees+ where+ ignored = (replicate toIgnore WildP ++) . return+ toIgnore = length $ filter isDynamic pieces+ isDynamic Dynamic{} = True+ isDynamic Static{} = False+ front' = front . ConP (mkName name) . ignored++goRes :: (Pat -> Pat) -> Resource a -> Q Clause+goRes front Resource {..} =+ return $ Clause+ [front $ RecP (mkName resourceName) []]+ (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))+ []+ where+ toText s = VarE 'pack `AppE` LitE (StringL s)++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing
+ src/Yesod/Routes/TH/Types.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Warning! This module is considered internal and may have breaking changes+module Yesod.Routes.TH.Types+ ( -- * Data types+ Resource (..)+ , ResourceTree (..)+ , Piece (..)+ , Dispatch (..)+ , CheckOverlap+ , FlatResource (..)+ -- ** Helper functions+ , resourceMulti+ , resourceTreePieces+ , resourceTreeName+ , flatten+ ) where++import Language.Haskell.TH.Syntax++data ResourceTree typ+ = ResourceLeaf (Resource typ)+ | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]+ deriving (Show, Functor)++resourceTreePieces :: ResourceTree typ -> [Piece typ]+resourceTreePieces (ResourceLeaf r) = resourcePieces r+resourceTreePieces (ResourceParent _ _ x _) = x++resourceTreeName :: ResourceTree typ -> String+resourceTreeName (ResourceLeaf r) = resourceName r+resourceTreeName (ResourceParent x _ _ _) = x++instance Lift t => Lift (ResourceTree t) where+ lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]+ lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]++data Resource typ = Resource+ { resourceName :: String+ , resourcePieces :: [Piece typ]+ , resourceDispatch :: Dispatch typ+ , resourceAttrs :: [String]+ , resourceCheck :: CheckOverlap+ }+ deriving (Show, Functor)++type CheckOverlap = Bool++instance Lift t => Lift (Resource t) where+ lift (Resource a b c d e) = [|Resource a b c d e|]++data Piece typ = Static String | Dynamic typ+ deriving Show++instance Functor Piece where+ fmap _ (Static s) = Static s+ fmap f (Dynamic t) = Dynamic (f t)++instance Lift t => Lift (Piece t) where+ lift (Static s) = [|Static $(lift s)|]+ lift (Dynamic t) = [|Dynamic $(lift t)|]++data Dispatch typ =+ Methods+ { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end+ , methodsMethods :: [String] -- ^ supported request methods+ }+ | Subsite+ { subsiteType :: typ+ , subsiteFunc :: String+ }+ deriving Show++instance Functor Dispatch where+ fmap f (Methods a b) = Methods (fmap f a) b+ fmap f (Subsite a b) = Subsite (f a) b++instance Lift t => Lift (Dispatch t) where+ lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]+ lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]+ lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]++resourceMulti :: Resource typ -> Maybe typ+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t+resourceMulti _ = Nothing++data FlatResource a = FlatResource+ { frParentPieces :: [(String, [Piece a])]+ , frName :: String+ , frPieces :: [Piece a]+ , frDispatch :: Dispatch a+ , frCheck :: Bool+ } deriving (Show)++flatten :: [ResourceTree a] -> [FlatResource a]+flatten =+ concatMap (go id True)+ where+ go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]+ go front check' (ResourceParent name check pieces children) =+ concatMap (go (front . ((name, pieces):)) (check && check')) children
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.6.12+version: 1.6.13 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -22,12 +22,13 @@ README.md library+ hs-source-dirs: src+ build-depends: base >= 4.9 && < 5 , aeson >= 1.0 , auto-update , blaze-html >= 0.5 , blaze-markup >= 0.7.1- , byteable , bytestring >= 0.10.2 , case-insensitive >= 0.2 , cereal >= 0.3@@ -39,6 +40,7 @@ , deepseq >= 1.3 , fast-logger >= 2.2 , http-types >= 0.7+ , memory , monad-logger >= 0.3.10 && < 0.4 , mtl , parsec >= 2 && < 3.2@@ -106,7 +108,7 @@ test-suite test-routes type: exitcode-stdio-1.0 main-is: RouteSpec.hs- hs-source-dirs: test, .+ hs-source-dirs: test, src other-modules: Hierarchy Yesod.Routes.Class