yesod-core-1.2.3/0000755000000000000000000000000012162030273011750 5ustar0000000000000000yesod-core-1.2.3/LICENSE0000644000000000000000000000207512162030273012761 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-core-1.2.3/yesod-core.cabal0000644000000000000000000001226612162030273015014 0ustar0000000000000000name: yesod-core version: 1.2.3 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Creation of type-safe, RESTful web applications. description: Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . The Yesod documentation site has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent. category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: test.hs test/YesodCoreTest.hs test/YesodCoreTest/*.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs test/en.msg test/test.hs library build-depends: base >= 4.3 && < 5 , time >= 1.1.4 , yesod-routes >= 1.2 && < 1.3 , wai >= 1.4 && < 1.5 , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12 , template-haskell , path-pieces >= 0.1.2 && < 0.2 , hamlet >= 1.1 && < 1.2 , shakespeare >= 1.0 && < 1.1 , shakespeare-js >= 1.0.2 && < 1.2 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-i18n >= 1.0 && < 1.1 , blaze-builder >= 0.2.1.4 && < 0.4 , transformers >= 0.2.2 && < 0.4 , clientsession >= 0.9 && < 0.10 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.3 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1 , failure >= 0.2 && < 0.3 , containers >= 0.2 , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4 , cookie >= 0.4 && < 0.5 , http-types >= 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5 , resourcet >= 0.4.6 && < 0.5 , lifted-base >= 0.1.2 , attoparsec-conduit , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , data-default , safe , warp >= 1.3.8 exposed-modules: Yesod.Core Yesod.Core.Content Yesod.Core.Dispatch Yesod.Core.Handler Yesod.Core.Json Yesod.Core.Widget Yesod.Core.Internal Yesod.Core.Types other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler Yesod.Core.Internal.Util Yesod.Core.Internal.Response Yesod.Core.Internal.Run Yesod.Core.Internal.TH Yesod.Core.Internal.LiteApp Yesod.Core.Class.Yesod Yesod.Core.Class.Dispatch Yesod.Core.Class.Breadcrumbs Paths_yesod_core ghc-options: -Wall -- Following line added due to: https://github.com/yesodweb/yesod/issues/545 -- This looks like a GHC bug extensions: MultiParamTypeClasses test-suite tests type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test cpp-options: -DTEST build-depends: base ,hspec >= 1.3 ,wai-test >= 1.3.0.5 ,wai ,yesod-core ,bytestring ,hamlet ,shakespeare-css ,shakespeare-js ,text ,http-types , random , blaze-builder ,HUnit ,QuickCheck >= 2 && < 3 ,transformers , conduit , containers , lifted-base , resourcet ghc-options: -Wall source-repository head type: git location: https://github.com/yesodweb/yesod yesod-core-1.2.3/test.hs0000644000000000000000000000014112162030273013257 0ustar0000000000000000import Test.Hspec import qualified YesodCoreTest main :: IO () main = hspec YesodCoreTest.specs yesod-core-1.2.3/Setup.lhs0000644000000000000000000000016212162030273013557 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-core-1.2.3/Yesod/0000755000000000000000000000000012162030273013033 5ustar0000000000000000yesod-core-1.2.3/Yesod/Core.hs0000644000000000000000000001133112162030273014256 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# 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 (..) -- * Utitlities , maybeAuthorized , widgetToPageContent -- * Defaults , defaultErrorHandler -- * Data types , AuthResult (..) , unauthorizedI -- * Logging , LogLevel (..) , logDebug , logInfo , logWarn , logError , logOther , logDebugS , logInfoS , logWarnS , logErrorS , logOtherS -- * Sessions , SessionBackend (..) , customizeSessionCookies , defaultClientSessionBackend , clientSessionBackend , clientSessionDateCacher , loadClientSession , Header(..) -- * JS loaders , ScriptLoadPosition (..) , BottomOfHeadAsync -- * Subsites , MonadHandler (..) , MonadWidget (..) , getRouteToParent , defaultLayoutSub -- * Misc , yesodVersion , yesodRender , 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 (..) , MonadBase (..) , MonadBaseControl , 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) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Breadcrumbs import Yesod.Core.Internal.Run (yesodRender, runFakeHandler) import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Routes.Class import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) 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) -- | 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 getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent) getRouteToParent = HandlerT $ return . handlerToParent defaultLayoutSub :: Yesod parent => WidgetT child IO () -> HandlerT child (HandlerT parent IO) Html defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout 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-1.2.3/Yesod/Core/0000755000000000000000000000000012162030273013723 5ustar0000000000000000yesod-core-1.2.3/Yesod/Core/Json.hs0000644000000000000000000001027312162030273015173 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Core.Json ( -- * Convert from a JSON value defaultLayoutJson , jsonToRepJson , returnJson , provideJson -- * Convert to a JSON value , parseJsonBody , parseJsonBody_ -- * Produce JSON values , J.Value (..) , J.ToJSON (..) , J.FromJSON (..) , array , object , (.=) , (J..:) -- * Convenience functions , jsonOrRedirect , acceptsJson ) where import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep) 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 (WidgetT) 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 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) => WidgetT site IO () -- ^ HTML -> HandlerT site IO a -- ^ JSON -> HandlerT site IO TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w provideRep $ fmap J.toJSON 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 -- | Provide a JSON representation for usage with 'selectReps', using aeson\'s -- 'J.toJSON' function to perform the conversion. -- -- Since 1.2.1 provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) () provideJson = provideRep . return . J.toJSON -- | 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'@. -- -- /Since: 0.3.0/ parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseJsonBody = do eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value' return $ case eValue of Left e -> J.Error $ show e Right value -> J.fromJSON value -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a parseJsonBody_ = do ra <- parseJsonBody 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 r j = do q <- acceptsJson if q then return (J.toJSON 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-1.2.3/Yesod/Core/Types.hs0000644000000000000000000004265112162030273015373 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Types where import qualified Blaze.ByteString.Builder as BBuilder import qualified Blaze.ByteString.Builder.Char.Utf8 import Control.Applicative (Applicative (..)) import Control.Applicative ((<$>)) import Control.Arrow (first) import Control.Exception (Exception) import Control.Monad (liftM, ap) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, MonadThrow (..), MonadUnsafeIO (..), ResourceT, Source) import Data.Dynamic (Dynamic) import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map import Data.Monoid (Endo (..), Last (..), Monoid (..)) 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 Data.Typeable (TypeRep) 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, Logger, toLogStr) import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) import Yesod.Core.Internal.Util (getTime, putTime) import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) -- 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 | 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 :: !(Source (ResourceT IO) ByteString) , fileMove :: !(FilePath -> IO ()) } data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) | FileUploadDisk !(NWP.BackEnd FilePath) | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString)) -- | 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 newtype Cache = Cache (Map TypeRep Dynamic) deriving Monoid type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } data RunHandlerEnv site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route site)) , rheSite :: !site , 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 } data HandlerData site parentRoute = HandlerData { handlerRequest :: !YesodRequest , handlerEnv :: !(RunHandlerEnv site) , handlerState :: !(IORef GHState) , handlerToParent :: !(Route site -> parentRoute) , handlerResource :: !InternalState } data YesodRunnerEnv site = YesodRunnerEnv { yreLogger :: !Logger , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) } data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv { ysreParentRunner :: !(ParentRunner parent parentMonad) , 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 m = m 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 HandlerT site m a = HandlerT { unHandlerT :: HandlerData site (MonadRoute m) -> m a } type family MonadRoute (m :: * -> *) type instance MonadRoute IO = () type instance MonadRoute (HandlerT site m) = (Route site) data GHState = GHState { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents , ghsIdent :: Int , ghsCache :: Cache , 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 WidgetT site m a = WidgetT { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site)) } instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where mempty = return () mappend x y = x >> y 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 !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length. | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder)) | 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. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = NotFound | InternalError Text | InvalidArgs [Text] | NotAuthenticated | PermissionDenied Text | BadMethod H.Method deriving (Show, Eq, Typeable) ----- header stuff -- | Headers to be added to a 'Result'. data Header = AddCookie SetCookie | DeleteCookie ByteString ByteString | Header ByteString ByteString deriving (Eq, Show) 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 newtype Body url = Body (HtmlUrl url) deriving Monoid 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 mappend (GWData a1 a2 a3 a4 a5 a6 a7) (GWData b1 b2 b3 b4 b5 b6 b7) = GWData (a1 `mappend` b1) (a2 `mappend` b2) (a3 `mappend` b3) (a4 `mappend` b4) (unionWith mappend a5 b5) (a6 `mappend` b6) (a7 `mappend` b7) data HandlerContents = HCContent H.Status !TypedContent | HCError ErrorResponse | HCSendFile ContentType FilePath (Maybe FilePart) | HCRedirect H.Status Text | HCCreated Text | HCWai W.Response 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" instance Exception HandlerContents -- Instances for WidgetT instance Monad m => Functor (WidgetT site m) where fmap = liftM instance Monad m => Applicative (WidgetT site m) where pure = return (<*>) = ap instance Monad m => Monad (WidgetT site m) where return a = WidgetT $ const $ return (a, mempty) WidgetT x >>= f = WidgetT $ \r -> do (a, wa) <- x r (b, wb) <- unWidgetT (f a) r return (b, wa `mappend` wb) instance MonadIO m => MonadIO (WidgetT site m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (WidgetT site m) where liftBase = WidgetT . const . liftBase . fmap (, mempty) instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site))) liftBaseWith f = WidgetT $ \reader -> liftBaseWith $ \runInBase -> liftM (\x -> (x, mempty)) (f $ liftM StW . runInBase . flip unWidgetT reader) restoreM (StW base) = WidgetT $ const $ restoreM base instance MonadTrans (WidgetT site) where lift = WidgetT . const . liftM (, mempty) instance MonadThrow m => MonadThrow (WidgetT site m) where monadThrow = lift . monadThrow instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (WidgetT site m) where monadLoggerLog a b c d = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d) instance MonadTrans (HandlerT site) where lift = HandlerT . const -- Instances for HandlerT instance Monad m => Functor (HandlerT site m) where fmap = liftM instance Monad m => Applicative (HandlerT site m) where pure = return (<*>) = ap instance Monad m => Monad (HandlerT site m) where return = HandlerT . const . return HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r instance MonadIO m => MonadIO (HandlerT site m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (HandlerT site m) where liftBase = lift . liftBase -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- @fork@ function is incompatible with the underlying @ResourceT@ system. -- Instead, if you must fork a separate thread, you should use -- @resourceForkIO@. -- -- Using fork usually leads to an exception that says -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- after cleanup. Please contact the maintainers.\" instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where data StM (HandlerT site m) a = StH (StM m a) liftBaseWith f = HandlerT $ \reader -> liftBaseWith $ \runInBase -> f $ liftM StH . runInBase . (\(HandlerT r) -> r reader) restoreM (StH base) = HandlerT $ const $ restoreM base instance MonadThrow m => MonadThrow (HandlerT site m) where monadThrow = lift . monadThrow instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (HandlerT site m) where monadLoggerLog a b c d = HandlerT $ \hd -> liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) instance Monoid (UniqueList x) where mempty = UniqueList id UniqueList x `mappend` UniqueList y = UniqueList $ x . y instance IsString Content where fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString 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 yesod-core-1.2.3/Yesod/Core/Dispatch.hs0000644000000000000000000001421112162030273016015 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Core.Dispatch ( -- * Quasi-quoted routing parseRoutes , parseRoutesNoCheck , parseRoutesFile , parseRoutesFileNoCheck , mkYesod -- ** More fine-grained , mkYesodData , mkYesodSubData , mkYesodDispatch , mkYesodSubDispatch -- ** Path pieces , PathPiece (..) , PathMultiPiece (..) , Texts -- * Convert to WAI , toWaiApp , toWaiAppPlain , warp , warpDebug , warpEnv , mkDefaultMiddlewares -- * WAI subsites , WaiSubsite (..) ) 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 Data.Monoid (mappend) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Blaze.ByteString.Builder import Network.HTTP.Types (status301) import Yesod.Routes.Parse import Yesod.Core.Types import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Safe (readMay) import System.Environment (getEnvironment) 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 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 return $ toWaiAppYre $ YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb } 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 = return $ W.responseLBS status301 [ ("Content-Type", "text/plain") , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting" where dest = joinPath y (resolveApproot y env) segments' [] dest' = if S.null (W.rawQueryString env) then dest else (dest `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) -- | 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 sb <- makeSessionBackend site let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb } 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 = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings Network.Wai.Handler.Warp.defaultSettings { Network.Wai.Handler.Warp.settingsPort = port , Network.Wai.Handler.Warp.settingsServerName = 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 = Logger logger , outputFormat = Apache FromSocket } return $ logWare . 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 readMay portS of Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Just port -> warp port site yesod-core-1.2.3/Yesod/Core/Handler.hs0000644000000000000000000010570212162030273015641 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- -- Module : Yesod.Handler -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : stable -- Portability : portable -- -- Define Handler stuff. -- --------------------------------------------------------- module Yesod.Core.Handler ( -- * Handler monad HandlerT -- ** Read information from handler , getYesod , getUrlRender , getUrlRenderParams , getCurrentRoute , getRequest , waiRequest , runRequestBody , rawRequestBody -- ** Request information -- *** Request datatype , RequestBodyContents , YesodRequest (..) , FileInfo , fileName , fileContentType , fileSource , fileMove -- *** Convenience functions , languages -- *** Lookup parameters , lookupGetParam , lookupPostParam , lookupCookie , lookupFile , lookupHeader -- **** Multi-lookup , lookupGetParams , lookupPostParams , lookupCookies , lookupFiles , lookupHeaders -- * Responses -- ** Pure , respond -- ** Streaming , respondSource , sendChunk , sendFlush , sendChunkBS , sendChunkLBS , sendChunkText , sendChunkLazyText , sendChunkHtml -- ** Redirecting , RedirectUrl (..) , redirect , redirectWith , redirectToPost -- ** Errors , notFound , badMethod , notAuthenticated , permissionDenied , permissionDeniedI , invalidArgs , invalidArgsI -- ** Short-circuit responses. , sendFile , sendFilePart , sendResponse , sendResponseStatus , sendResponseCreated , sendWaiResponse -- * Different representations -- $representations , selectRep , provideRep , provideRepType , ProvidedRep -- * Setting headers , setCookie , getExpires , deleteCookie , addHeader , setHeader , setLanguage -- ** Content caching and expiration , cacheSeconds , neverExpires , alreadyExpired , expiresAt -- * Session , SessionMap , lookupSession , lookupSessionBS , getSession , setSession , setSessionBS , deleteSession , clearSession -- ** Ultimate destination , setUltDest , setUltDestCurrent , setUltDestReferer , redirectUltDest , clearUltDest -- ** Messages , setMessage , setMessageI , getMessage -- * Helpers for specific content -- ** Hamlet , hamletToRepHtml , giveUrlRenderer -- ** Misc , newIdent -- * Lifting , handlerToIO -- * i18n , getMessageRender -- * Per-request caching , cached ) where import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, mkFileInfoLBS, mkFileInfoSource) import Control.Applicative ((<$>), (<|>)) import Control.Exception (evaluate) import Control.Monad (liftM) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, liftResourceT) import qualified Network.HTTP.Types as H import qualified Network.Wai as W import Control.Monad.Trans.Class (lift) import Data.Conduit (transPipe, Flush (Flush), yield, Producer) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html.Renderer.Text as RenderText 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 Data.Conduit (Source) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) import Data.Monoid (Endo (..), mappend, mempty) import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) import Control.Monad.Trans.Resource (ResourceT, runResourceT, withInternalState) import Data.Dynamic (fromDynamic, toDyn) import qualified Data.IORef.Lifted as I import Data.Maybe (listToMaybe) import Data.Typeable (Typeable, typeOf) import Yesod.Core.Class.Handler import Yesod.Core.Types import Yesod.Routes.Class (Route) import Control.Failure (failure) import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI) get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState put :: MonadHandler m => GHState -> m () put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState modify :: MonadHandler m => (GHState -> GHState) -> m () modify f = liftHandlerT $ HandlerT $ 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 = liftHandlerT . failure hcError :: MonadHandler m => ErrorResponse -> m a hcError = handlerError . HCError getRequest :: MonadHandler m => m YesodRequest getRequest = liftHandlerT $ HandlerT $ return . handlerRequest runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody = do HandlerData { handlerEnv = RunHandlerEnv {..} , handlerRequest = req } <- liftHandlerT $ HandlerT return let len = W.requestBodyLength $ reqWaiRequest req upload = rheUpload len x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest rbc <- liftResourceT $ rbHelper upload rr put x { ghsRBC = Just rbc } return rbc rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents rbHelper upload = case upload of FileUploadMemory s -> rbHelper' s mkFileInfoLBS FileUploadDisk s -> rbHelper' s mkFileInfoFile FileUploadSource s -> rbHelper' s mkFileInfoSource rbHelper' :: NWP.BackEnd x -> (Text -> Text -> x -> FileInfo) -> W.Request -> ResourceT 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)) askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv -- | Get the master site appliation argument. getYesod :: MonadHandler m => m (HandlerSite m) getYesod = rheSite `liftM` askHandlerEnv -- | Get the URL rendering function. getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text) getUrlRender = do x <- rheRender `liftM` askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: MonadHandler m => m (Route (HandlerSite m) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender `liftM` askHandlerEnv -- | 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 `liftM` 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 m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a) handlerToIO = HandlerT $ \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 = 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 , 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 $ \(HandlerT 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 , handlerToParent = const () , handlerResource = resState } liftIO (f newHandlerData) -- | 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 `liftM` 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 def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect def) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. clearUltDest :: MonadHandler m => m () clearUltDest = deleteSession ultDestKey msgKey :: Text msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. setMessage :: MonadHandler m => Html -> m () setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'. setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m () setMessageI msg = do mr <- getMessageRender setMessage $ toHtml $ mr msg -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'. getMessage :: MonadHandler m => m (Maybe Html) getMessage = do mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey deleteSession msgKey return mmsg -- | 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 = handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count -- | 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 -- | 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 -- | 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 -- | 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 = addHeaderInternal . AddCookie -- | 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 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 (encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} -- | 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 = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" -- | 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 -- | 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) -- | Lookup for session data. lookupSession :: MonadHandler m => Text -> m (Maybe Text) lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do m <- liftM ghsSession get return $ Map.lookup n m -- | Get all session variables. getSession :: MonadHandler m => m SessionMap getSession = liftM 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 $ 'h' : 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 giveUrlRenderer [hamlet| $newline never $doctype 5 Redirecting... <body onload="document.getElementById('form').submit()"> <form id="form" method="post" action=#{urlText}> <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 = giveUrlRenderer {-# DEPRECATED hamletToRepHtml "Use giveUrlRenderer instead" #-} -- | Provide a URL rendering function to the given function and return the -- result. Useful for processing Shakespearean templates. -- -- Since 1.2.0 giveUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output giveUrlRenderer f = do render <- getUrlRenderParams return $ f render -- | Get the request\'s 'W.Request' value. waiRequest :: MonadHandler m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) => m (message -> Text) getMessageRender = do env <- askHandlerEnv l <- reqLangs `liftM` getRequest return $ renderMessage (rheSite env) l -- | Use a per-request cache to avoid performing the same action multiple -- times. Note that values are stored by their type. Therefore, you should use -- newtype wrappers to distinguish logically different types. -- -- Since 1.2.0 cached :: (MonadHandler m, Typeable a) => m a -> m a cached f = do gs <- get let cache = ghsCache gs case clookup cache of Just val -> return val Nothing -> do val <- f put $ gs { ghsCache = cinsert val cache } return val where clookup :: Typeable a => Cache -> Maybe a clookup (Cache m) = res where res = Map.lookup (typeOf $ fromJust res) m >>= fromDynamic fromJust :: Maybe a -> a fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" cinsert :: Typeable a => a -> Cache -> Cache cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order -- of preference): -- -- * The _LANG get parameter. -- -- * The _LANG cookie. -- -- * The _LANG user session variable. -- -- * 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 = reqLangs `liftM` getRequest 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 = liftM 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 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 = liftM 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 = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. lookupFile :: (MonadHandler m, MonadResource m) => Text -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: (MonadHandler m, MonadResource 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 = liftM 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 typeHtml $ produceHtmlOutput -- > provideRep typeJson $ 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 <- liftM reqAccept getRequest case mapMaybe tryAccept cts of [] -> case reps of [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text) rep:_ -> if null cts then returnRep rep else sendResponseStatus H.status406 explainUnaccepted rep:_ -> returnRep rep where explainUnaccepted :: Text explainUnaccepted = "no match found for accept header" returnRep (ProvidedRep ct mcontent) = mcontent >>= return . TypedContent ct 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 headMay 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 => Source m S.ByteString rawRequestBody = do req <- lift waiRequest transPipe liftResourceT $ W.requestBody req -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@. fileSource :: MonadResource m => FileInfo -> Source m S.ByteString fileSource = transPipe liftResourceT . fileSourceRaw -- | 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 -> Source (HandlerT site IO) (Flush Builder) -> HandlerT site IO TypedContent respondSource ctype src = HandlerT $ \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 unHandlerT 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 -> Producer m (Flush Builder) 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 => Producer m (Flush Builder) sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- -- Since 1.2.0 sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder) sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- -- Since 1.2.0 sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder) sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- -- Since 1.2.0 sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder) sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- -- Since 1.2.0 sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder) sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- -- Since 1.2.0 sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml = sendChunk ��������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Widget.hs���������������������������������������������������������������0000644�0000000�0000000�00000024614�12162030273�015511� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} -- | 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 , 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 , widgetToParentWidget , handlerToWidget -- * Internal , whamletFileWithSettings ) 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 Control.Monad.IO.Class (MonadIO, liftIO) import Text.Shakespeare.I18N (RenderMessage) import Control.Monad (liftM) 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 Yesod.Core.Types import Yesod.Core.Class.Handler 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 render ~ RY site => ToWidget site (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . 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 (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where toWidget = liftWidgetT instance ToWidget site Html where toWidget = toWidget . const -- | 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 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 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 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 render ~ RY site => ToWidgetHead site (render -> 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 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 [|liftM (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 w = liftWidgetT $ WidgetT $ const $ return ((), w) toUnique :: x -> UniqueList x toUnique = UniqueList . (:) handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f widgetToParentWidget :: MonadIO m => WidgetT child IO a -> HandlerT child (HandlerT parent m) (WidgetT parent m a) widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do (a, gwd) <- liftIO $ f hd { handlerToParent = const () } return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd) liftGWD :: (child -> parent) -> GWData child -> GWData parent liftGWD tp gwd = GWData { gwdBody = fixBody $ gwdBody gwd , gwdTitle = gwdTitle gwd , gwdScripts = fixUnique fixScript $ gwdScripts gwd , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd , gwdCss = fmap fixCss $ gwdCss gwd , gwdJavascript = fmap fixJS $ gwdJavascript gwd , gwdHead = fixHead $ gwdHead gwd } where fixRender f route params = f (tp route) params fixBody (Body h) = Body $ h . fixRender fixHead (Head h) = Head $ h . fixRender fixUnique go (UniqueList f) = UniqueList (map go (f []) ++) fixScript (Script loc attrs) = Script (fixLoc loc) attrs fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs fixLoc (Local url) = Local $ tp url fixLoc (Remote t) = Remote t fixCss f = f . fixRender fixJS f = f . fixRender ��������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Content.hs��������������������������������������������������������������0000644�0000000�0000000�00000022222�12162030273�015671� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} 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 Control.Monad (liftM) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput) import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Aeson as J import Data.Aeson.Encode (fromValue) import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) import Yesod.Core.Types -- | 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 (fromByteString bs) $ Just $ B.length bs instance ToContent L.ByteString where toContent = flip ContentBuilder Nothing . fromLazyByteString instance ToContent T.Text where toContent = toContent . Blaze.fromText instance ToContent Text where toContent = toContent . Blaze.fromLazyText instance ToContent String where toContent = toContent . Blaze.fromString 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 ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where toContent src = ContentSource $ mapOutput toFlushBuilder src instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where toContent (ResumableSource 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 fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString 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.breakByte 59 -- 59 == ; -- 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 ct = (main, fst $ B.breakByte semicolon (tailEmpty sub)) where tailEmpty x = if B.null x then "" else B.tail x (main, sub) = B.breakByte slash ct slash = 47 semicolon = 59 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 . Blaze.fromLazyText . toLazyText . fromValue instance HasContentType J.Value where getContentType _ = typeJson instance HasContentType Html where getContentType _ = typeHtml instance HasContentType Text where getContentType _ = typePlain instance HasContentType T.Text where getContentType _ = typePlain -- | 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 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) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal.hs�������������������������������������������������������������0000644�0000000�0000000�00000000352�12162030273�016033� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������-- | 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) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/���������������������������������������������������������������0000755�0000000�0000000�00000000000�12162030273�015477� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/TH.hs����������������������������������������������������������0000644�0000000�0000000�00000012147�12162030273�016353� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Core.Internal.TH where import Prelude hiding (exp) import Yesod.Core.Handler import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.List (foldl') import Yesod.Routes.TH import Yesod.Routes.Parse import Yesod.Core.Types import Yesod.Core.Content 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 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False -- | 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 res = mkYesodDataGeneral name False res mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] mkYesodSubData name res = mkYesodDataGeneral name True res mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do let (name':rest) = words name fmap fst $ mkYesodGeneral name' rest isSub res -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: Type -> [Dec] masterTypeSyns site = [ TySynD (mkName "Handler") [] $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO , TySynD (mkName "Widget") [] $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() ] mkYesodGeneral :: String -- ^ foundation type -> [String] -- ^ arguments for the type -> Bool -- ^ it this a subsite -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral name args isSub resS = do renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res dispatchDec <- mkDispatchInstance site res parse <- mkParseRouteInstance site res let rname = mkName $ "resources" ++ name eres <- lift resS let resourcesDec = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) , FunD rname [Clause [] (NormalB eres) []] ] let dataDec = concat [ [parse] , renderRouteDec , [routeAttrsDec] , resourcesDec , if isSub then [] else masterTypeSyns site ] return (dataDec, dispatchDec) where site = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args) res = map (fmap parseType) resS mkMDS :: Q Exp -> MkDispatchSettings mkMDS 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 = [|notFound >> return ()|] , mds405 = [|badMethod >> return ()|] , mdsGetHandler = defaultGetHandler } -- | 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 -> [ResourceTree a] -- ^ The resource -> DecsQ mkDispatchInstance master res = do clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res let thisDispatch = FunD 'yesodDispatch [clause'] return [InstanceD [] yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) 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) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/Util.hs��������������������������������������������������������0000644�0000000�0000000�00000002616�12162030273�016755� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������module Yesod.Core.Internal.Util ( putTime , getTime , formatW3 , formatRFC1123 , formatRFC822 ) 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) import System.Locale (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" ������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/Session.hs�����������������������������������������������������0000644�0000000�0000000�00000004464�12162030273�017466� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (forever, guard) import Yesod.Core.Types import Yesod.Core.Internal.Util import qualified Data.IORef as I 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' ---------------------------------------------------------------------- -- Mostly copied from Kazu's date-cache, but with modifications -- that better suit our needs. -- -- The cached date is updated every 10s, we don't need second -- resolution for session expiration times. clientSessionDateCacher :: NominalDiffTime -- ^ Inactive session valitity. -> IO (IO ClientSessionDateCache, IO ()) clientSessionDateCacher validity = do ref <- getUpdated >>= I.newIORef tid <- forkIO $ forever (doUpdate ref) return $! (I.readIORef ref, killThread tid) where getUpdated = do now <- getCurrentTime let expires = validity `addUTCTime` now expiresS = runPut (putTime expires) return $! ClientSessionDateCache now expires expiresS doUpdate ref = do threadDelay 10000000 -- 10s I.writeIORef ref =<< getUpdated ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/Run.hs���������������������������������������������������������0000644�0000000�0000000�00000027244�12162030273�016610� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Internal.Run where import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) import Control.Exception (fromException) import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Maybe (fromMaybe) import Data.Monoid (appEndo, mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai import Prelude hiding (catch) import System.Log.FastLogger (Logger) import System.Log.FastLogger (LogStr, toLogStr) import System.Random (newStdGen) import Yesod.Core.Content import Yesod.Core.Class.Yesod import Yesod.Core.Types import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) -- | Function used internally by Yesod in the process of converting a -- 'HandlerT' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c => RunHandlerEnv site -> HandlerT site IO c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do let toErrorHandler e = case fromException e of Just (HCError x) -> x _ -> InternalError $ T.pack $ show e istate <- liftIO $ I.newIORef GHState { ghsSession = reqSession yreq , ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty , ghsHeaders = mempty } let hd = HandlerData { handlerRequest = yreq , handlerEnv = rhe , handlerState = istate , handlerToParent = const () , handlerResource = resState } contents' <- catch (fmap Right $ unHandlerT handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id $ fromException e) state <- liftIO $ I.readIORef istate let finalSession = ghsSession state let headers = ghsHeaders state let contents = either id (HCContent H.status200 . toTypedContent) contents' let handleError e = flip runInternalState resState $ do yar <- rheOnError e yreq { reqSession = finalSession } case yar of YRPlain _ hs ct c sess -> let hs' = appEndo headers hs in return $ YRPlain (getStatus e) hs' ct c sess YRWai _ -> return yar let sendFile' ct fp p = return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession case contents of HCContent status (TypedContent ct c) -> do ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let disable_caching x = Header "Cache-Control" "no-cache, must-revalidate" : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" : x hs = (if status /= H.movedPermanently301 then disable_caching else id) $ Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YRPlain status hs typePlain emptyContent finalSession HCSendFile ct fp p -> catch (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YRPlain H.status201 hs typePlain emptyContent finalSession HCWai r -> return $ YRWai r safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse -> YesodApp safeEh log' er req = do liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError $ toLogStr $ "Error handler errored out: " ++ show er return $ YRPlain H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString)) (reqSession req) -- | Run a '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 -> HandlerT site IO a -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () let yapp = runHandler RunHandlerEnv { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing , rheSite = site , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler } handler' errHandler err req = do liftIO $ I.writeIORef ret (Left err) return $ YRPlain H.status500 [] typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req) fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = "" , serverName = "runFakeHandler-serverName" , serverPort = 80 , requestHeaders = [] , isSecure = False , remoteHost = error "runFakeHandler-remoteHost" , pathInfo = ["runFakeHandler", "pathInfo"] , queryString = [] , requestBody = mempty , vault = mempty , requestBodyLength = KnownLength 0 } fakeRequest = YesodRequest { reqGetParams = [] , reqCookies = [] , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) , reqAccept = [] , reqSession = fakeSessionMap } _ <- runResourceT $ yapp fakeRequest I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} yesodRunner :: (ToTypedContent res, Yesod site) => HandlerT site IO res -> YesodRunnerEnv site -> Maybe (Route site) -> Application yesodRunner handler' YesodRunnerEnv {..} route req | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen yreq <- case mkYesodReq of Left yreq -> return yreq Right needGen -> liftIO $ needGen <$> newStdGen 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 , rheSite = yreSite , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler } yar <- runHandler rhe handler yreq liftIO $ yarToResponse yar saveSession yreq 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 $ toByteString $ fromMaybe (joinPath y ar ps $ params ++ params') (urlRenderOverride y url) where (ps, params') = renderRoute url resolveApproot :: Yesod master => master -> Request -> ResolvedApproot resolveApproot master req = case approot of ApprootRelative -> "" ApprootStatic t -> t ApprootMaster f -> f master ApprootRequest f -> f master req stripHandlerT :: HandlerT child (HandlerT parent m) a -> (parent -> child) -> (Route child -> Route parent) -> Maybe (Route child) -> HandlerT parent m a stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do let env = handlerEnv hd ($ hd) $ unHandlerT $ f hd { handlerEnv = env { rheSite = getSub $ rheSite env , rheRoute = newRoute , rheRender = \url params -> rheRender env (toMaster url) params } , handlerToParent = toMaster } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/Request.hs�����������������������������������������������������0000644�0000000�0000000�00000014424�12162030273�017470� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE 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 System.Random (RandomGen, randomRs) import Web.Cookie (parseCookiesText) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 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) import Data.Text.Encoding.Error (lenientDecode) import Data.Conduit import Data.Conduit.List (sourceList) import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word64) import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO) import Yesod.Core.Types import qualified Data.Map as Map -- | Impose a limit on the size of the request body. limitRequestBody :: Word64 -> W.Request -> W.Request limitRequestBody maxLen req = req { W.requestBody = W.requestBody req $= limit maxLen } where tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse limit 0 = tooLarge limit remaining = await >>= maybe (return ()) go where go bs = do let len = fromIntegral $ S8.length bs if len > remaining then tooLarge else do yield bs limit $ remaining - len tooLargeResponse :: W.Response tooLargeResponse = W.responseLBS (Status 413 "Too Large") [("Content-Type", "text/plain")] "Request body too large to be processed." parseWaiRequest :: RandomGen g => W.Request -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size -> (Either YesodRequest (g -> 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' = YesodRequest { reqGetParams = gets , reqCookies = cookies , reqWaiRequest = maybe id limitRequestBody mmaxBodySize env , 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 $ Just . pack . 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 (flip 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 :: RandomGen g => Int -> g -> String randomString len = take len . map toChar . randomRs (0, 61) where toChar i | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs) mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst) mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) tokenKey :: IsString a => a tokenKey = "_TOKEN" langKey :: IsString a => a langKey = "_LANG" ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Internal/LiteApp.hs�����������������������������������������������������0000644�0000000�0000000�00000004724�12162030273�017400� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-} module Yesod.Core.Internal.LiteApp where import Yesod.Routes.Class import Data.Monoid 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 Monoid LiteApp where mempty = LiteApp $ \_ _ -> Nothing mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps type LiteHandler = HandlerT LiteApp IO type LiteWidget = WidgetT LiteApp IO 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-1.2.3/Yesod/Core/Internal/Response.hs����������������������������������������������������0000644�0000000�0000000�00000006630�12162030273�017636� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Yesod.Core.Internal.Response where import Blaze.ByteString.Builder (toByteString) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Network.Wai import Prelude hiding (catch) 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 Blaze.ByteString.Builder (fromLazyByteString, 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) yarToResponse :: Monad m => YesodResponse -> (SessionMap -> m [Header]) -- ^ save session -> YesodRequest -> m Response yarToResponse (YRWai a) _ _ = return a yarToResponse (YRPlain s hs ct c newSess) saveSession yreq = 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) = let hs' = maybe finalHeaders finalHeaders' mlen in ResponseBuilder s hs' b go (ContentFile fp p) = ResponseFile s finalHeaders fp p go (ContentSource body) = ResponseSource s finalHeaders body go (ContentDontEvaluate c') = go c' return $ go c -- | Convert Header to a key/value pair. headerToPair :: Header -> (CI ByteString, ByteString) headerToPair (AddCookie sc) = ("Set-Cookie", toByteString $ renderSetCookie $ sc) headerToPair (DeleteCookie key path) = ( "Set-Cookie" , S.concat [ key , "=; path=" , path , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] ) headerToPair (Header key value) = (CI.mk key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show evaluateContent c = return (Right c) getStatus :: ErrorResponse -> H.Status getStatus NotFound = H.status404 getStatus (InternalError _) = H.status500 getStatus (InvalidArgs _) = H.status400 getStatus NotAuthenticated = H.status401 getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 ��������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Class/������������������������������������������������������������������0000755�0000000�0000000�00000000000�12162030273�014770� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Class/Breadcrumbs.hs����������������������������������������������������0000644�0000000�0000000�00000002172�12162030273�017557� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# 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 -> HandlerT site IO (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 => HandlerT site IO (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-1.2.3/Yesod/Core/Class/Dispatch.hs�������������������������������������������������������0000644�0000000�0000000�00000003242�12162030273�017064� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Dispatch where import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Core.Types import Yesod.Core.Content import Yesod.Core.Class.Yesod import Yesod.Core.Class.Handler import Yesod.Core.Internal.Run -- | 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 m where yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m -> W.Application instance YesodSubDispatch WaiSubsite master where yesodSubDispatch YesodSubRunnerEnv {..} req = app req where WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained. => HandlerT child (HandlerT parent m) TypedContent -> YesodSubRunnerEnv child parent (HandlerT parent m) -> Maybe (Route child) -> W.Application subHelper handlert YesodSubRunnerEnv {..} route = ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) where base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Class/Handler.hs��������������������������������������������������������0000644�0000000�0000000�00000006531�12162030273�016706� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Class.Handler ( MonadHandler (..) , MonadWidget (..) ) where import Yesod.Core.Types import Data.Monoid (mempty) import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..)) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid) 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.Error ( ErrorT, Error) 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 ) class MonadResource m => MonadHandler m where type HandlerSite m liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a replaceToParent :: HandlerData site route -> HandlerData site () replaceToParent hd = hd { handlerToParent = const () } instance MonadResourceBase m => MonadHandler (HandlerT site m) where type HandlerSite (HandlerT site m) = site liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent {-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-} instance MonadResourceBase m => MonadHandler (WidgetT site m) where type HandlerSite (WidgetT site m) = site liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent {-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-} #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT 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(ExceptionT) GO(Pipe l i o u) GO(ConduitM i o) #undef GO #undef GOX class MonadHandler m => MonadWidget m where liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a instance MonadResourceBase m => MonadWidget (WidgetT site m) where liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT 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(ExceptionT) GO(Pipe l i o u) GO(ConduitM i o) #undef GO #undef GOX �����������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/Yesod/Core/Class/Yesod.hs����������������������������������������������������������0000644�0000000�0000000�00000060222�12162030273�016411� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS) import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Control.Arrow ((***), second) import Control.Monad (forM, when, void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Aeson (object, (.=)) import Data.List (foldl') import Data.List (nub) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TEE import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Word (Word64) import Language.Haskell.TH.Syntax (Loc (..)) import Network.HTTP.Types (encodePath) import qualified Network.Wai as W import Data.Default (def) import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import System.IO (stdout) import System.Log.FastLogger (LogStr (..), Logger, loggerDate, loggerPutStr, mkLogger) import System.Log.FastLogger.Date (ZonedDate) import Text.Blaze (customAttribute, textTag, toValue, (!)) import Text.Blaze (preEscapedToMarkup) import qualified Text.Blaze.Html5 as TBH import Text.Hamlet import Text.Julius import qualified Web.ClientSession as CS import Web.Cookie (parseCookies) import Web.Cookie (SetCookie (..)) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget import Control.Monad.Trans.Class (lift) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute site => Yesod site where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- -- Default value: 'ApprootRelative'. This is valid under the following -- conditions: -- -- * Your application is served from the root of the domain. -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. -- -- If this is not true, you should override with a different -- implementation. approot :: Approot site approot = ApprootRelative -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. defaultLayout :: WidgetT site IO () -> HandlerT site IO Html defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage giveUrlRenderer [hamlet| $newline never $doctype 5 <html> <head> <title>#{pageTitle p} ^{pageHead p} <body> $maybe msg <- mmsg <p .message>#{msg} ^{pageBody p} |] -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. urlRenderOverride :: site -> Route site -> Maybe Builder urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. -- -- Return 'Authorized' if the request is authorized, -- 'Unauthorized' a message if unauthorized. -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route site -> Bool -- ^ is this a write request? -> HandlerT site IO AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default, -- this assumes you are following RESTful principles, and determines this -- from request method. In particular, all except the following request -- methods are considered write: GET HEAD OPTIONS TRACE. -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'. isWriteRequest :: Route site -> HandlerT site IO Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] -- | The default route for authentication. -- -- Used in particular by 'isAuthorized', but library users can do whatever -- they want with it. authRoute :: site -> Maybe (Route site) authRoute _ = Nothing -- | A function used to clean up path segments. It returns 'Right' with a -- clean path or 'Left' with a new set of pieces the user should be -- redirected to. The default implementation enforces: -- -- * No double slashes -- -- * There is no trailing slash. -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. cleanPath :: site -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . T.null) s dropDash t | T.all (== '-') t = T.drop 1 t | otherwise = t -- | Builds an absolute URL by concatenating the application root with the -- pieces of a path and a query string, if any. -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. joinPath :: site -> T.Text -- ^ application root -> [T.Text] -- ^ path pieces -> [(T.Text, T.Text)] -- ^ query string -> Builder joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x addDash t | T.all (== '-') t = T.cons '-' t | otherwise = t -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and -- JavaScript content in an external file; the "Yesod.Widget" module uses -- this feature. -- -- The return value is 'Nothing' if no storing was performed; this is the -- default implementation. A 'Just' 'Left' gives the absolute URL of the -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is -- necessary when you are serving the content outside the context of a -- Yesod application, such as via memcached. addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Maximum allowed length of the request body, in bytes. -- -- If @Nothing@, no maximum is applied. -- -- Default: 2 megabytes. maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64 maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes -- | Creates a @Logger@ to use for log messages. -- -- Note that a common technique (endorsed by the scaffolding) is to create -- a @Logger@ value and place it in your foundation datatype, and have this -- method return that already created value. That way, you can use that -- same @Logger@ for printing messages during app initialization. -- -- Default: Sends to stdout and automatically flushes on each write. makeLogger :: site -> IO Logger makeLogger _ = mkLogger True stdout -- | Send a message to the @Logger@ provided by @getLogger@. -- -- Default implementation: checks if the message should be logged using -- 'shouldLog' and, if so, formats using 'formatLogMessage'. messageLoggerSource :: site -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () messageLoggerSource a logger loc source level msg = when (shouldLog a source level) $ formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger -- | Where to Load sripts from. We recommend the default value, -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: -- -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js -- -- Or write your own async js loader. jsLoader :: site -> ScriptLoadPosition site jsLoader _ = BottomOfBody -- | Create a session backend. Returning 'Nothing' disables -- sessions. If you'd like to change the way that the session -- cookies are created, take a look at -- 'customizeSessionCookies'. -- -- Default: Uses clientsession with a 2 hour timeout. makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile -- | How to store uploaded files. -- -- Default: When the request body is greater than 50kb, store in a temp -- file. For chunked request bodies, store in a temp file. Otherwise, store -- in memory. fileUpload :: site -> W.RequestBodyLength -> FileUpload fileUpload _ (W.KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd -- | Should we log the given log source/level combination. -- -- Default: Logs everything at or above 'logLevel' shouldLog :: site -> LogSource -> LogLevel -> Bool shouldLog _ _ level = level >= LevelInfo -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- -- Default: the 'defaultYesodMiddleware' function. -- -- Since: 1.1.6 yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res yesodMiddleware = defaultYesodMiddleware -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- -- Since 1.2.0 defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language" authorizationCheck handler -- | Check if a given request is authorized via 'isAuthorized' and -- 'isWriteRequest'. -- -- Since 1.2.0 authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck = do getCurrentRoute >>= maybe (return ()) checkUrl where checkUrl url = do isWrite <- isWriteRequest url ar <- isAuthorized url isWrite case ar of Authorized -> return () AuthenticationRequired -> do master <- getYesod case authRoute master of Nothing -> void $ notAuthenticated Just url' -> do void $ selectRep $ do provideRepType typeHtml $ do setUltDestCurrent void $ redirect url' provideRepType typeJson $ void $ notAuthenticated Unauthorized s' -> permissionDenied s' -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route site), Yesod site) => WidgetT site IO () -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do master <- getYesod hd <- HandlerT return ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd let title = maybe mempty unTitle mTitle scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p css <- forM (Map.toList style) $ \(mmedia, content) -> do let rendered = toLazyText $ content render x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered return (mmedia, case x of Nothing -> Left $ preEscapedToMarkup rendered Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc regularScriptLoad = [hamlet| $newline never $forall s <- scripts ^{mkScriptTag s} $maybe j <- jscript $maybe s <- jsLoc <script src="#{s}"> $nothing <script>^{jelper j} |] headAll = [hamlet| $newline never \^{head'} $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css $maybe t <- right $ snd s $maybe media <- fst s <link rel=stylesheet media=#{media} href=#{t}> $nothing <link rel=stylesheet href=#{t}> $maybe content <- left $ snd s $maybe media <- fst s <style media=#{media}>#{content} $nothing <style>#{content} $case jsLoader master $of BottomOfBody $of BottomOfHeadAsync asyncJsLoader ^{asyncJsLoader asyncScripts mcomplete} $of BottomOfHeadBlocking ^{regularScriptLoad} |] let bodyScript = [hamlet| $newline never ^{body} ^{regularScriptLoad} |] return $ PageContent title headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body where renderLoc' render' (Local url) = render' url [] renderLoc' _ (Remote s) = s addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) mkScriptTag (Script loc attrs) render' = foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () mkLinkTag (Stylesheet loc attrs) render' = foldl' addAttr TBH.link ( ("rel", "stylesheet") : ("href", renderLoc' render' loc) : attrs ) runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r setTitle "Not Found" toWidget [hamlet| <h1>Not Found <p>#{path'} |] provideRep $ return $ object ["message" .= ("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 $ do setTitle "Not logged in" toWidget [hamlet| <h1>Not logged in <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 return $ object $ [ "message" .= ("Not logged in"::Text) ] ++ case authRoute site of Nothing -> [] Just url -> ["authentication_url" .= rend url] defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Permission Denied" toWidget [hamlet| <h1>Permission denied <p>#{msg} |] provideRep $ return $ object $ [ "message" .= ("Permission Denied. " <> msg) ] defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Invalid Arguments" toWidget [hamlet| <h1>Invalid Arguments <ul> $forall msg <- ia <li>#{msg} |] provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia] defaultErrorHandler (InternalError e) = do $logErrorS "yesod-core" e selectRep $ do provideRep $ defaultLayout $ do setTitle "Internal Server Error" toWidget [hamlet| <h1>Internal Server Error <pre>#{e} |] provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e] defaultErrorHandler (BadMethod m) = selectRep $ do provideRep $ defaultLayout $ do setTitle"Bad Method" toWidget [hamlet| <h1>Method Not Supported <p>Method <code>#{S8.unpack m}</code> not supported |] provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= 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 formatLogMessage :: IO ZonedDate -> Loc -> LogSource -> LogLevel -> LogStr -- ^ message -> IO [LogStr] formatLogMessage getdate loc src level msg = do now <- getdate return [ LB now , LB " [" , LS $ case level of LevelOther t -> T.unpack t _ -> drop 5 $ show level , LS $ if T.null src then "" else "#" ++ T.unpack src , LB "] " , msg , LB " @(" , LS $ fileLocationToString loc , LB ")\n" ] -- | 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 = fmap (customizeSessionCookie 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 let timeout = fromIntegral (minutes * 60) (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout return $ clientSessionBackend key getCachedDate jsToHtml :: Javascript -> Html jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b jelper :: JavascriptUrl url -> HtmlUrl url jelper = fmap jsToHtml left :: Either a b -> Maybe a left (Left x) = Just x left _ = Nothing right :: Either a b -> Maybe b right (Right x) = Just x right _ = Nothing clientSessionBackend :: CS.Key -- ^ The encryption key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> SessionBackend clientSessionBackend key getCachedDate = SessionBackend { sbLoadSession = loadClientSession key getCachedDate "_SESSION" } 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 = fromMaybe Map.empty $ do raw <- lookup "Cookie" $ W.requestHeaders req val <- lookup sessionName $ parseCookies raw let host = "" -- fixme, properly lock sessions to client address decodeClientSession key date host val save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV return [AddCookie def { setCookieName = sessionName , setCookieValue = encodeClientSession key iv date host sess' , setCookiePath = Just "/" , 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 = (loc_package loc) ++ ':' : (loc_module loc) ++ ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) where line = show . fst . loc_start char = show . snd . loc_start ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/������������������������������������������������������������������������������0000755�0000000�0000000�00000000000�12162030273�012727� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/YesodCoreTest.hs��������������������������������������������������������������0000644�0000000�0000000�00000002252�12162030273�016020� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������module YesodCoreTest (specs) where import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Links import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json import qualified YesodCoreTest.Streaming as Streaming import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth import qualified YesodCoreTest.LiteApp as LiteApp import Test.Hspec specs :: Spec specs = do cleanPathTest exceptionsTest widgetTest mediaTest linksTest noOverloadedTest internalRequestTest errorHandlingTest cacheTest WaiSubsite.specs Redirect.specs JsLoader.specs RequestBodySize.specs Json.specs Streaming.specs Reps.specs Auth.specs LiteApp.specs ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/test.hs�����������������������������������������������������������������������0000644�0000000�0000000�00000000141�12162030273�014236� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������import Test.Hspec import qualified YesodCoreTest main :: IO () main = hspec YesodCoreTest.specs �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/en.msg������������������������������������������������������������������������0000644�0000000�0000000�00000000020�12162030273�014031� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������Another: String ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/YesodCoreTest/����������������������������������������������������������������0000755�0000000�0000000�00000000000�12162030273�015463� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.2.3/test/YesodCoreTest/Json.hs���������������������������������������������������������0000644�0000000�0000000�00000002706�12162030273�016735� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} module YesodCoreTest.Json (specs, Widget) where import Yesod.Core import Test.Hspec import qualified Data.Map as Map import Network.Wai.Test import Data.Text (Text) import Data.ByteString.Lazy (ByteString) data App = App mkYesod "App" [parseRoutes| / HomeR GET /has-multiple-pieces/#Int/#Int MultiplePiecesR GET |] instance Yesod App getHomeR :: Handler RepPlain getHomeR = do val <- parseJsonBody_ case Map.lookup ("foo" :: Text) val of Nothing -> invalidArgs ["foo not found"] Just foo -> return $ RepPlain $ toContent (foo :: Text) getMultiplePiecesR :: Int -> Int -> Handler () getMultiplePiecesR _ _ = return () test :: String -> ByteString -> (SResponse -> Session ()) -> Spec test name rbody f = it name $ do app <- toWaiApp App flip runSession app $ do sres <- srequest SRequest { simpleRequest = defaultRequest , simpleRequestBody = rbody } f sres specs :: Spec specs = describe "Yesod.Json" $ do test "parses valid content" "{\"foo\":\"bar\"}" $ \sres -> do assertStatus 200 sres assertBody "bar" sres test "400 for bad JSON" "{\"foo\":\"bar\"" $ \sres -> do assertStatus 400 sres test "400 for bad structure" "{\"foo2\":\"bar\"}" $ \sres -> do assertStatus 400 sres assertBodyContains "foo not found" sres ����������������������������������������������������������yesod-core-1.2.3/test/YesodCoreTest/JsLoader.hs�����������������������������������������������������0000644�0000000�0000000�00000002075�12162030273�017526� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoader (specs, Widget) where import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec import Yesod.Core import Network.Wai.Test data H = H mkYesod "H" [parseRoutes| / HeadR GET |] instance Yesod H where jsLoader _ = BottomOfHeadBlocking getHeadR :: Handler Html getHeadR = defaultLayout $ addScriptRemote "load.js" specs :: Spec specs = describe "Test.JsLoader" $ do it "link from head" $ runner H $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title>" res it "link from bottom" $ runner B $ do res <- request defaultRequest assertBody "\n" res runner :: YesodDispatch master => master -> Session () -> IO () runner app f = toWaiApp app >>= runSession f yesod-core-1.2.3/test/YesodCoreTest/Links.hs0000644000000000000000000000504212162030273017100 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Links (linksTest, Widget) where import Test.Hspec import Yesod.Core import Text.Hamlet import Network.Wai import Network.Wai.Test import Data.Text (Text) import Blaze.ByteString.Builder (toByteString) data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /single/#Text TextR GET /multi/*Texts TextsR GET /route-test-1/+[Text] RT1 GET /route-test-2/*Vector-String RT2 GET /route-test-3/*Vector-(Maybe-Int) RT3 GET /route-test-4/#(Foo-Int-Int) RT4 GET |] data Vector a = Vector deriving (Show, Read, Eq) instance PathMultiPiece (Vector a) data Foo x y = Foo deriving (Show, Read, Eq) instance PathPiece (Foo x y) instance Yesod Y getRootR :: Handler Html getRootR = defaultLayout $ toWidget [hamlet||] getTextR :: Text -> Handler Html getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|] getTextsR :: [Text] -> Handler Html getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|] getRT1 :: [Text] -> Handler () getRT1 _ = return () getRT2 :: Vector String -> Handler () getRT2 _ = return () getRT3 :: Vector (Maybe Int) -> Handler () getRT3 _ = return () getRT4 :: Foo Int Int -> Handler () getRT4 _ = return () linksTest :: Spec linksTest = describe "Test.Links" $ do it "linkToHome" case_linkToHome it "blank path pieces" case_blanks runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_linkToHome :: IO () case_linkToHome = runner $ do res <- request defaultRequest assertBody "\n\n" res case_blanks :: IO () case_blanks = runner $ do liftIO $ do let go r = let (ps, qs) = renderRoute r in toByteString $ joinPath Y "" ps qs (go $ TextR "-") `shouldBe` "/single/--" (go $ TextR "") `shouldBe` "/single/-" (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar" res1 <- request defaultRequest { pathInfo = ["single", "-"] , rawPathInfo = "dummy1" } assertBody "\n%%" res1 res2 <- request defaultRequest { pathInfo = ["multi", "foo", "-", "bar"] , rawPathInfo = "dummy2" } assertBody "\n%["foo","","bar"]%" res2 yesod-core-1.2.3/test/YesodCoreTest/Auth.hs0000644000000000000000000000461112162030273016722 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} module YesodCoreTest.Auth (specs, Widget) where import Yesod.Core import Test.Hspec import Network.Wai.Test import Network.Wai import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import Data.List (isSuffixOf) data App = App mkYesod "App" [parseRoutes| /no-auth NoAuthR /needs-login-json NeedsLoginJsonR /needs-login-html NeedsLoginHtmlR /read-only ReadOnlyR /forbidden ForbiddenR |] instance Yesod App where isAuthorized NoAuthR _ = return Authorized isAuthorized NeedsLoginJsonR _ = return AuthenticationRequired isAuthorized NeedsLoginHtmlR _ = return AuthenticationRequired isAuthorized ReadOnlyR False = return Authorized isAuthorized ReadOnlyR True = return $ Unauthorized "Read only" isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden" authRoute _ = Just NoAuthR handleNoAuthR, handleReadOnlyR, handleForbiddenR :: Handler () handleNoAuthR = return () handleReadOnlyR = return () handleForbiddenR = return () handleNeedsLoginJsonR :: Handler RepJson handleNeedsLoginJsonR = return $ repJson $ object [] handleNeedsLoginHtmlR :: Handler Html handleNeedsLoginHtmlR = return "" test :: String -- ^ method -> String -- ^ path -> (SResponse -> Session ()) -> Spec test method path f = it (method ++ " " ++ path) $ do app <- toWaiApp App flip runSession app $ do sres <- request defaultRequest { requestMethod = S8.pack method , pathInfo = [T.pack path] , requestHeaders = if not $ isSuffixOf "json" path then [] else [("Accept", S8.pack "application/json")] } f sres specs :: Spec specs = describe "Auth" $ do test "GET" "no-auth" $ \sres -> assertStatus 200 sres test "POST" "no-auth" $ \sres -> assertStatus 200 sres test "GET" "needs-login-html" $ \sres -> assertStatus 303 sres test "POST" "needs-login-html" $ \sres -> assertStatus 303 sres test "GET" "needs-login-json" $ \sres -> assertStatus 401 sres test "POST" "needs-login-json" $ \sres -> assertStatus 401 sres test "GET" "read-only" $ \sres -> assertStatus 200 sres test "POST" "read-only" $ \sres -> assertStatus 403 sres test "GET" "forbidden" $ \sres -> assertStatus 403 sres test "POST" "forbidden" $ \sres -> assertStatus 403 sres yesod-core-1.2.3/test/YesodCoreTest/Reps.hs0000644000000000000000000000544112162030273016734 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} module YesodCoreTest.Reps (specs, Widget) where import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.String (IsString) import Data.Text (Text) import Data.Maybe (fromJust) import Data.Monoid (Endo (..)) import qualified Control.Monad.Trans.Writer as Writer import qualified Data.Set as Set data App = App mkYesod "App" [parseRoutes| / HomeR GET !home /json JsonR GET /parent/#Int ParentR: /#Text/child ChildR !child |] instance Yesod App specialHtml :: IsString a => a specialHtml = "text/html; charset=special" getHomeR :: Handler TypedContent getHomeR = selectRep $ do rep typeHtml "HTML" rep specialHtml "HTMLSPECIAL" rep typeXml "XML" rep typeJson "JSON" rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) () rep ct t = provideRepType ct $ return (t :: Text) getJsonR :: Handler TypedContent getJsonR = selectRep $ do rep typeHtml "HTML" provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] handleChildR :: Int -> Text -> Handler () handleChildR _ _ = return () testRequest :: Int -- ^ http status code -> Request -> ByteString -- ^ expected body -> Spec testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do app <- toWaiApp App flip runSession app $ do sres <- request req assertStatus status sres assertBody expected sres test :: String -- ^ accept header -> ByteString -- ^ expected body -> Spec test accept expected = testRequest 200 (acceptRequest accept) expected acceptRequest :: String -> Request acceptRequest accept = defaultRequest { requestHeaders = [("Accept", S8.pack accept)] } specs :: Spec specs = do describe "selectRep" $ do test "application/json" "JSON" test (S8.unpack typeJson) "JSON" test "text/xml" "XML" test (S8.unpack typeXml) "XML" test "text/xml,application/json" "XML" test "text/xml;q=0.9,application/json;q=1.0" "JSON" test (S8.unpack typeHtml) "HTML" test "text/html" "HTML" test specialHtml "HTMLSPECIAL" testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}" testRequest 406 (acceptRequest "text/foo") "no match found for accept header" test "text/*" "HTML" test "*/*" "HTML" describe "routeAttrs" $ do it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home" it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty it "ChildR" $ routeAttrs (ParentR 5 $ ChildR "ignored") `shouldBe` Set.singleton "child" yesod-core-1.2.3/test/YesodCoreTest/Streaming.hs0000644000000000000000000000137412162030273017755 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module YesodCoreTest.Streaming (specs) where import Yesod.Core import Test.Hspec import Network.Wai.Test import Data.Text (Text) import Data.ByteString (ByteString) app :: LiteApp app = liteApp $ dispatchTo $ respondSource typeHtml $ do sendChunk ("Hello " :: String) sendChunk ("World" :: ByteString) sendChunk ("!\n" :: Text) sendChunkHtml "<&>" test :: String -> (SResponse -> Session ()) -> Spec test name f = it name $ do wapp <- toWaiApp app flip runSession wapp $ do sres <- request defaultRequest f sres specs :: Spec specs = describe "Streaming" $ do test "works" $ \sres -> do assertStatus 200 sres assertBody "Hello World!\n<&>" sres yesod-core-1.2.3/test/YesodCoreTest/MediaData.hs0000644000000000000000000000046412162030273017634 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.MediaData where import Yesod.Core data Y = Y mkYesodData "Y" [parseRoutes| / RootR GET /static StaticR !IGNORED GET !alsoIgnored |] yesod-core-1.2.3/test/YesodCoreTest/YesodTest.hs0000644000000000000000000000073012162030273017742 0ustar0000000000000000-- this is being re-worked into a general-purpose testing module for Yesod apps module YesodCoreTest.YesodTest ( yesod , parseRoutes, mkYesod, yesodDispatch, renderRoute, Yesod(..) , redirect , Approot (..) , module Network.Wai , module Network.Wai.Test , module Test.Hspec ) where import Yesod.Core import Network.Wai.Test import Network.Wai import Test.Hspec yesod :: YesodDispatch y => y -> Session a -> IO a yesod app f = toWaiApp app >>= runSession f yesod-core-1.2.3/test/YesodCoreTest/RequestBodySize.hs0000644000000000000000000000576012162030273021130 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.RequestBodySize (specs, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Data.Text (Text) import qualified Data.Text as T import Data.Conduit import Data.Conduit.List (consume) import Data.Conduit.Binary (isolate) data Y = Y mkYesod "Y" [parseRoutes| /post PostR POST /consume ConsumeR POST /partial-consume PartialConsumeR POST /unused UnusedR POST |] instance Yesod Y where maximumContentLength _ _ = Just 10 postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain postPostR = do val <- lookupPostParams "foobarbaz" return $ RepPlain $ toContent $ T.concat val postConsumeR = do body <- rawRequestBody $$ consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do body <- rawRequestBody $$ isolate 5 =$ consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain "" runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f caseHelper :: String -- ^ name -> Text -- ^ pathinfo -> ByteString -- ^ request body -> Int -- ^ expected status code, chunked -> Int -- ^ expected status code, non-chunked -> Spec caseHelper name path body statusChunked statusNonChunked = describe name $ do it "chunked" $ runner $ do res <- mkRequest False assertStatus statusChunked res it "non-chunked" $ runner $ do res <- mkRequest True assertStatus statusNonChunked res where mkRequest includeLength = srequest $ SRequest defaultRequest { pathInfo = [path] , requestHeaders = ("content-type", "application/x-www-form-urlencoded") : if includeLength then [("content-length", S8.pack $ show $ S.length body)] else [] , requestMethod = "POST" , requestBodyLength = if includeLength then KnownLength $ fromIntegral $ S.length body else ChunkedBody } $ L.fromChunks $ map S.singleton $ S.unpack body specs :: Spec specs = describe "Test.RequestBodySize" $ do caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413 caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200 caseHelper "consume- large" "consume" "this is longer than 10" 413 413 caseHelper "consume- small" "consume" "smaller" 200 200 caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413 caseHelper "partial consume- small" "partial-consume" "smaller" 200 200 caseHelper "unused- large" "unused" "this is longer than 10" 200 413 caseHelper "unused- small" "unused" "smaller" 200 200 yesod-core-1.2.3/test/YesodCoreTest/InternalRequest.hs0000644000000000000000000000741212162030273021150 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module YesodCoreTest.InternalRequest (internalRequestTest) where import Data.List (nub) import System.Random (StdGen, mkStdGen) import Network.Wai as W import Network.Wai.Test import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) import Yesod.Core import Data.Word (Word64) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do it "looks reasonably random" looksRandom it "does not repeat itself" $ noRepeat 10 100 -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?). looksRandom :: Bool looksRandom = randomString 20 (mkStdGen 0) == "VH9SkhtptqPs6GqtofVg" noRepeat :: Int -> Int -> Bool noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n -- For convenience instead of "(undefined :: StdGen)". g :: StdGen g = error "test/YesodCoreTest/InternalRequest.g" parseWaiRequest' :: Request -> SessionMap -> Bool -> Word64 -> YesodRequest parseWaiRequest' a b c d = case parseWaiRequest a b c (Just d) of Left yreq -> yreq Right needGen -> needGen g tokenSpecs :: Spec tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do it "is Nothing if sessions are disabled" noDisabledToken it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken it "uses preexisting token in session" useOldToken it "generates a new token for sessions without token" generateToken noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where r = parseWaiRequest' defaultRequest mempty False 1000 ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 useOldToken :: Bool useOldToken = reqToken r == Just "old" where r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 generateToken :: Bool generateToken = reqToken r /= Nothing where r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 langSpecs :: Spec langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do it "respects Accept-Language" respectAcceptLangs it "respects sessions" respectSessionLang it "respects cookies" respectCookieLang it "respects queries" respectQueryLang it "prioritizes correctly" prioritizeLangs respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] } mempty False 1000 respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where r = parseWaiRequest' defaultRequest { requestHeaders = [ ("Accept-Language", "en, es") , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] } (singleton "_LANG" "en-SESSION") False 10000 internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do randomStringSpecs tokenSpecs langSpecs yesod-core-1.2.3/test/YesodCoreTest/ErrorHandling.hs0000644000000000000000000000732712162030273020566 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget ) where import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) data App = App mkYesod "App" [parseRoutes| / HomeR GET /not_found NotFoundR POST /first_thing FirstThingR POST /after_runRequestBody AfterRunRequestBodyR POST /error-in-body ErrorInBodyR GET /error-in-body-noeval ErrorInBodyNoEvalR GET |] instance Yesod App getHomeR :: Handler Html getHomeR = do $logDebug "Testing logging" defaultLayout $ toWidget [hamlet| $doctype 5
|] postNotFoundR, postFirstThingR, postAfterRunRequestBodyR :: Handler Html postNotFoundR = do (_, _files) <- runRequestBody _ <- notFound getHomeR postFirstThingR = do _ <- error "There was an error 3.14159" getHomeR postAfterRunRequestBodyR = do x <- runRequestBody _ <- error $ show $ fst x getHomeR getErrorInBodyR :: Handler Html getErrorInBodyR = do let foo = error "error in body 19328" :: String defaultLayout [whamlet|#{foo}|] getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate Html) getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do it "says not found" caseNotFound it "says 'There was an error' before runRequestBody" caseBefore it "says 'There was an error' after runRequestBody" caseAfter it "error in body == 500" caseErrorInBody it "error in body, no eval == 200" caseErrorInBodyNoEval runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f caseNotFound :: IO () caseNotFound = runner $ do res <- request defaultRequest { pathInfo = ["not_found"] , requestMethod = "POST" } assertStatus 404 res assertBodyContains "Not Found" res caseBefore :: IO () caseBefore = runner $ do res <- request defaultRequest { pathInfo = ["first_thing"] , requestMethod = "POST" } assertStatus 500 res assertBodyContains "There was an error 3.14159" res caseAfter :: IO () caseAfter = runner $ do let content = "foo=bar&baz=bin12345" res <- srequest SRequest { simpleRequest = defaultRequest { pathInfo = ["after_runRequestBody"] , requestMethod = "POST" , requestHeaders = [ ("content-type", "application/x-www-form-urlencoded") , ("content-length", S8.pack $ show $ L.length content) ] } , simpleRequestBody = content } assertStatus 500 res assertBodyContains "bin12345" res caseErrorInBody :: IO () caseErrorInBody = runner $ do res <- request defaultRequest { pathInfo = ["error-in-body"] } assertStatus 500 res assertBodyContains "error in body 19328" res caseErrorInBodyNoEval :: IO () caseErrorInBodyNoEval = do eres <- try $ runner $ do _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] } return () case eres of Left (_ :: SomeException) -> return () Right _ -> error "Expected an exception" yesod-core-1.2.3/test/YesodCoreTest/LiteApp.hs0000644000000000000000000000276112162030273017363 0ustar0000000000000000module YesodCoreTest.LiteApp (specs) where import Yesod.Core import Test.Hspec import Network.Wai.Test import Network.Wai import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 iapp :: IO Application iapp = toWaiApp $ liteApp $ do onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage") onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage") onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text))) onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text))) test :: String -- ^ method -> [String] -- ^ path -> (Either Int String) -- ^ status code or body -> Spec test method path expected = it (method ++ " " ++ show path) $ do app <- iapp flip runSession app $ do sres <- request defaultRequest { requestMethod = S8.pack method , pathInfo = map T.pack path } case expected of Left i -> assertStatus i sres Right b -> assertBody (L8.pack b) sres specs :: Spec specs = describe "LiteApp" $ do test "GET" [] $ Right "GetHomepage" test "POST" [] $ Right "PostHomepage" -- test "PUT" [] $ Left 405 test "GET" ["string", "foo"] $ Right "foo" test "DELETE" ["string", "bar"] $ Right "bar" test "GET" ["string!", "foo"] $ Left 404 test "GET" ["multi", "foo", "bar"] $ Right "bar" test "GET" ["multi", "foo", "bar", "baz"] $ Left 500 yesod-core-1.2.3/test/YesodCoreTest/Redirect.hs0000644000000000000000000000320012162030273017553 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.Redirect (specs, Widget) where import YesodCoreTest.YesodTest import Yesod.Core.Handler (redirectWith) import qualified Network.HTTP.Types as H data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /r301 R301 GET /r303 R303 GET /r307 R307 GET /rregular RRegular GET |] instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO () app = yesod Y getRootR :: Handler () getRootR = return () getR301, getR303, getR307, getRRegular :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR specs :: Spec specs = describe "Redirect" $ do it "301 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r301"] } assertStatus 301 res assertBodyContains "" res it "303 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r303"] } assertStatus 303 res assertBodyContains "" res it "307 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r307"] } assertStatus 307 res assertBodyContains "" res it "303 redirect for regular, HTTP 1.1" $ app $ do res <- request defaultRequest { pathInfo = ["rregular"] } assertStatus 303 res assertBodyContains "" res it "302 redirect for regular, HTTP 1.0" $ app $ do res <- request defaultRequest { pathInfo = ["rregular"] , httpVersion = H.http10 } assertStatus 302 res assertBodyContains "" res yesod-core-1.2.3/test/YesodCoreTest/Widget.hs0000644000000000000000000000761512162030273017253 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Widget (widgetTest) where import Test.Hspec import Yesod.Core import Text.Julius import Text.Lucius import Text.Hamlet import Network.Wai import Network.Wai.Test data Y = Y mkMessage "Y" "test" "en" type Strings = [String] mkYesod "Y" [parseRoutes| / RootR GET /foo/*Strings MultiR GET /whamlet WhamletR GET /towidget TowidgetR GET /auto AutoR GET /jshead JSHeadR GET |] instance Yesod Y where approot = ApprootStatic "http://test" getRootR :: Handler Html getRootR = defaultLayout $ toWidgetBody [julius||] getMultiR :: [String] -> Handler () getMultiR _ = return () data Msg = Hello | Goodbye instance RenderMessage Y Msg where renderMessage _ ("en":_) Hello = "Hello" renderMessage _ ("es":_) Hello = "Hola" renderMessage _ ("en":_) Goodbye = "Goodbye" renderMessage _ ("es":_) Goodbye = "Adios" renderMessage a (_:xs) y = renderMessage a xs y renderMessage a [] y = renderMessage a ["en"] y getTowidgetR :: Handler Html getTowidgetR = defaultLayout $ do toWidget [julius|foo|] :: Widget toWidgetHead [julius|foo|] toWidgetBody [julius|foo|] toWidget [lucius|foo{bar:baz}|] toWidgetHead [lucius|foo{bar:baz}|] toWidget [hamlet||] toWidgetHead [hamlet||] toWidgetBody [hamlet||] getWhamletR :: Handler Html getWhamletR = defaultLayout [whamlet| $newline never

Test

@{WhamletR}

_{Goodbye}

_{MsgAnother} ^{embed} |] where embed = [whamlet| $newline never

Embed |] getAutoR :: Handler Html getAutoR = defaultLayout [whamlet| $newline never ^{someHtml} |] where someHtml = [shamlet|somehtml|] getJSHeadR :: Handler Html getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] widgetTest :: Spec widgetTest = describe "Test.Widget" $ do it "addJuliusBody" case_addJuliusBody it "whamlet" case_whamlet it "two letter lang codes" case_two_letter_lang it "automatically applies toWidget" case_auto it "toWidgetHead puts JS in head" case_jshead runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_addJuliusBody :: IO () case_addJuliusBody = runner $ do res <- request defaultRequest assertBody "\n" res case_whamlet :: IO () case_whamlet = runner $ do res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res case_two_letter_lang :: IO () case_two_letter_lang = runner $ do res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es-ES")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res case_auto :: IO () case_auto = runner $ do res <- request defaultRequest { pathInfo = ["auto"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\nsomehtml" res case_jshead :: IO () case_jshead = runner $ do res <- request defaultRequest { pathInfo = ["jshead"] } assertBody "\n" res assertHeader "Vary" "Accept, Accept-Language" res yesod-core-1.2.3/test/YesodCoreTest/NoOverloadedStrings.hs0000644000000000000000000000464012162030273021756 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec import YesodCoreTest.NoOverloadedStringsSub import Yesod.Core import Network.Wai import Network.Wai.Test import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 getSubsite :: a -> Subsite getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBinR = do widget <- widgetToParentWidget [whamlet|

Used defaultLayoutT Baz |] lift $ defaultLayout widget getOnePiecesR :: Monad m => Int -> m () getOnePiecesR _ = return () getTwoPiecesR :: Monad m => Int -> Int -> m () getTwoPiecesR _ _ = return () getThreePiecesR :: Monad m => Int -> Int -> Int -> m () getThreePiecesR _ _ _ = return () data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /foo FooR GET /subsite SubsiteR Subsite getSubsite |] instance Yesod Y getRootR :: Handler () getRootR = return () getFooR :: Handler () getFooR = return () runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_sanity :: IO () case_sanity = runner $ do res <- request defaultRequest assertBody mempty res case_subsite :: IO () case_subsite = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "bar"] } assertBody (L8.pack "BarR") res assertStatus 200 res case_deflayout :: IO () case_deflayout = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "baz"] } assertBodyContains (L8.pack "Used Default Layout") res assertStatus 200 res case_deflayoutT :: IO () case_deflayoutT = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "bin"] } assertBodyContains (L8.pack "Used defaultLayoutT") res assertStatus 200 res noOverloadedTest :: Spec noOverloadedTest = describe "Test.NoOverloadedStrings" $ do it "sanity" case_sanity it "subsite" case_subsite it "deflayout" case_deflayout it "deflayoutT" case_deflayoutT yesod-core-1.2.3/test/YesodCoreTest/CleanPath.hs0000644000000000000000000001140612162030273017660 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.CleanPath (cleanPathTest, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status200, decodePathSegments) import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow ((***)) import Network.HTTP.Types (encodePath) import Data.Monoid (mappend) import Blaze.ByteString.Builder.Char.Utf8 (fromText) data Subsite = Subsite getSubsite :: a -> Subsite getSubsite = const Subsite instance RenderRoute Subsite where data Route Subsite = SubsiteRoute [TS.Text] deriving (Eq, Show, Read) renderRoute (SubsiteRoute x) = (x, []) instance ParseRoute Subsite where parseRoute (x, _) = Just $ SubsiteRoute x instance YesodSubDispatch Subsite master where yesodSubDispatch _ req = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show (pathInfo req) data Y = Y mkYesod "Y" [parseRoutes| /foo FooR GET /foo/#String FooStringR GET /bar BarR GET /subsite SubsiteR Subsite getSubsite /plain PlainR GET |] instance Yesod Y where approot = ApprootStatic "http://test" cleanPath _ s@("subsite":_) = Right s cleanPath _ ["bar", ""] = Right ["bar"] cleanPath _ ["bar"] = Left ["bar", ""] cleanPath _ s = if corrected == s then Right s else Left corrected where corrected = filter (not . TS.null) s joinPath Y ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x getFooR :: Handler RepPlain getFooR = return $ RepPlain "foo" getFooStringR :: String -> Handler RepPlain getFooStringR = return . RepPlain . toContent getBarR, getPlainR :: Handler RepPlain getBarR = return $ RepPlain "bar" getPlainR = return $ RepPlain "plain" cleanPathTest :: Spec cleanPathTest = describe "Test.CleanPath" $ do it "remove trailing slash" removeTrailingSlash it "noTrailingSlash" noTrailingSlash it "add trailing slash" addTrailingSlash it "has trailing slash" hasTrailingSlash it "/foo/something" fooSomething it "subsite dispatch" subsiteDispatch it "redirect with query string" redQueryString it "parsing" $ do parseRoute (["foo"], []) `shouldBe` Just FooR parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar") parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"]) parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y)) runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f removeTrailingSlash :: IO () removeTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo/" } assertStatus 301 res assertHeader "Location" "http://test/foo" res noTrailingSlash :: IO () noTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "foo" res addTrailingSlash :: IO () addTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/bar" } assertStatus 301 res assertHeader "Location" "http://test/bar/" res hasTrailingSlash :: IO () hasTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/bar/" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "bar" res fooSomething :: IO () fooSomething = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo/something" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "something" res subsiteDispatch :: IO () subsiteDispatch = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/subsite/1/2/3/" } assertStatus 200 res assertContentType "SUBSITE" res assertBody "[\"1\",\"2\",\"3\",\"\"]" res redQueryString :: IO () redQueryString = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/plain/" , rawQueryString = "?foo=bar" } assertStatus 301 res assertHeader "Location" "http://test/plain?foo=bar" res yesod-core-1.2.3/test/YesodCoreTest/Cache.hs0000644000000000000000000000241612162030273017025 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec import Network.Wai.Test import Yesod.Core import Data.IORef.Lifted import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy.Char8 as L8 data C = C newtype V1 = V1 Int deriving Typeable newtype V2 = V2 Int deriving Typeable mkYesod "C" [parseRoutes|/ RootR GET|] instance Yesod C getRootR :: Handler RepPlain getRootR = do ref <- newIORef 0 V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b] cacheTest :: Spec cacheTest = describe "Test.Cache" $ do it "works" works runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f works :: IO () works = runner $ do res <- request defaultRequest assertStatus 200 res assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res yesod-core-1.2.3/test/YesodCoreTest/Media.hs0000644000000000000000000000340512162030273017040 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Text.Lucius import YesodCoreTest.MediaData mkYesodDispatch "Y" resourcesY instance Yesod Y where addStaticContent _ _ content = do route <- getCurrentRoute case route of Just StaticR -> return $ Just $ Left $ if content == "foo2{bar:baz}" then "screen.css" else "all.css" _ -> return Nothing getRootR :: Handler Html getRootR = defaultLayout $ do toWidget [lucius|foo1{bar:baz}|] toWidgetMedia "screen" [lucius|foo2{bar:baz}|] toWidget [lucius|foo3{bar:baz}|] getStaticR :: Handler Html getStaticR = getRootR runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f caseMedia :: IO () caseMedia = runner $ do res <- request defaultRequest assertStatus 200 res flip assertBody res "\n" caseMediaLink :: IO () caseMediaLink = runner $ do res <- request defaultRequest { pathInfo = ["static"] } assertStatus 200 res flip assertBody res "\n" mediaTest :: Spec mediaTest = describe "Test.Media" $ do it "media" caseMedia it "media link" caseMediaLink yesod-core-1.2.3/test/YesodCoreTest/WaiSubsite.hs0000644000000000000000000000166012162030273020101 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.WaiSubsite (specs, Widget) where import YesodCoreTest.YesodTest import Yesod.Core import qualified Network.HTTP.Types as H myApp :: Application myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI" getApp :: a -> WaiSubsite getApp _ = WaiSubsite myApp data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /sub WaiSubsiteR WaiSubsite getApp |] instance Yesod Y app :: Session () -> IO () app = yesod Y getRootR :: Handler () getRootR = return () specs :: Spec specs = describe "WaiSubsite" $ do it "root" $ app $ do res <- request defaultRequest { pathInfo = [] } assertStatus 200 res assertBodyContains "" res it "subsite" $ app $ do res <- request defaultRequest { pathInfo = ["sub", "foo"] } assertStatus 200 res assertBodyContains "WAI" res yesod-core-1.2.3/test/YesodCoreTest/Exceptions.hs0000644000000000000000000000234512162030273020144 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Exceptions (exceptionsTest, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status301) data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /redirect RedirR GET |] instance Yesod Y where approot = ApprootStatic "http://test" errorHandler (InternalError e) = return $ toTypedContent e errorHandler x = defaultErrorHandler x getRootR :: Handler () getRootR = error "FOOBAR" >> return () getRedirR :: Handler () getRedirR = do addHeader "foo" "bar" redirectWith status301 RootR exceptionsTest :: Spec exceptionsTest = describe "Test.Exceptions" $ do it "500" case500 it "redirect keeps headers" caseRedirect runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case500 :: IO () case500 = runner $ do res <- request defaultRequest assertStatus 500 res assertBody "FOOBAR" res caseRedirect :: IO () caseRedirect = runner $ do res <- request defaultRequest { pathInfo = ["redirect"] } assertStatus 301 res assertHeader "foo" "bar" res yesod-core-1.2.3/test/YesodCoreTest/NoOverloadedStringsSub.hs0000644000000000000000000000143312162030273022425 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} module YesodCoreTest.NoOverloadedStringsSub where import Yesod.Core import Network.Wai import Yesod.Core.Types data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application) mkYesodSubData "Subsite" [parseRoutes| /bar BarR GET /baz BazR GET /bin BinR GET /has-one-piece/#Int OnePiecesR GET /has-two-pieces/#Int/#Int TwoPiecesR GET /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET |] instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where yesodSubDispatch ysre = f ysre where Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre yesod-core-1.2.3/test/YesodCoreTest/JsLoaderSites/0000755000000000000000000000000012162030273020176 5ustar0000000000000000yesod-core-1.2.3/test/YesodCoreTest/JsLoaderSites/Bottom.hs0000644000000000000000000000065112162030273022000 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoaderSites.Bottom (B(..), Widget) where import Yesod.Core data B = B mkYesod "B" [parseRoutes| / BottomR GET |] instance Yesod B where jsLoader _ = BottomOfBody getBottomR :: Handler Html getBottomR = defaultLayout $ addScriptRemote "load.js"