yesod-core-1.6.24.5/bench/0000755000000000000000000000000014371110614013263 5ustar0000000000000000yesod-core-1.6.24.5/src/0000755000000000000000000000000014371110614012773 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/0000755000000000000000000000000014371110614014056 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Core/0000755000000000000000000000000014377567452014774 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Core/Class/0000755000000000000000000000000014371437515016027 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Core/Internal/0000755000000000000000000000000014453667122016536 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Routes/0000755000000000000000000000000014371110614015337 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Routes/TH/0000755000000000000000000000000014371110614015652 5ustar0000000000000000yesod-core-1.6.24.5/test/0000755000000000000000000000000014453667122013177 5ustar0000000000000000yesod-core-1.6.24.5/test/YesodCoreTest/0000755000000000000000000000000014460174107015725 5ustar0000000000000000yesod-core-1.6.24.5/test/YesodCoreTest/ErrorHandling/0000755000000000000000000000000014371110614020455 5ustar0000000000000000yesod-core-1.6.24.5/test/YesodCoreTest/JsLoaderSites/0000755000000000000000000000000014371110614020432 5ustar0000000000000000yesod-core-1.6.24.5/test/YesodCoreTest/ParameterizedSite/0000755000000000000000000000000014371110614021340 5ustar0000000000000000yesod-core-1.6.24.5/test/fixtures/0000755000000000000000000000000014371110614015034 5ustar0000000000000000yesod-core-1.6.24.5/src/Yesod/Core.hs0000644000000000000000000001207614371110614015310 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Yesod.Core ( -- * Type classes Yesod (..) , YesodDispatch (..) , YesodSubDispatch (..) , RenderRoute (..) , ParseRoute (..) , RouteAttrs (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs -- * Types , Approot (..) , FileUpload (..) , ErrorResponse (..) -- * Utilities , maybeAuthorized , widgetToPageContent -- * Defaults , defaultErrorHandler , defaultYesodMiddleware , authorizationCheck -- * Data types , AuthResult (..) , unauthorizedI -- * Logging , defaultMakeLogger , defaultMessageLoggerSource , defaultShouldLogIO , formatLogMessage , LogLevel (..) , logDebug , logInfo , logWarn , logError , logOther , logDebugS , logInfoS , logWarnS , logErrorS , logOtherS -- * Sessions , SessionBackend (..) , customizeSessionCookies , defaultClientSessionBackend , envClientSessionBackend , clientSessionBackend , sslOnlySessions , laxSameSiteSessions , strictSameSiteSessions , sslOnlyMiddleware , clientSessionDateCacher , loadClientSession , Header(..) -- * CSRF protection , defaultCsrfMiddleware , defaultCsrfSetCookieMiddleware , csrfSetCookieMiddleware , defaultCsrfCheckMiddleware , csrfCheckMiddleware -- * JS loaders , ScriptLoadPosition (..) , BottomOfHeadAsync -- * Generalizing type classes , MonadHandler (..) , MonadWidget (..) -- * Approot , guessApproot , guessApprootOr , getApprootText -- * Misc , yesodVersion , yesodRender , Yesod.Core.runFakeHandler -- * LiteApp , module Yesod.Core.Internal.LiteApp -- * Low-level , yesodRunner -- * Re-exports , module Yesod.Core.Content , module Yesod.Core.Dispatch , module Yesod.Core.Handler , module Yesod.Core.Widget , module Yesod.Core.Json , module Text.Shakespeare.I18N , module Yesod.Core.Internal.Util , module Text.Blaze.Html , MonadTrans (..) , MonadIO (..) , MonadUnliftIO (..) , MonadResource (..) , MonadLogger -- * Commonly referenced functions/datatypes , Application -- * Utilities , showIntegral , readIntegral -- * Shakespeare -- ** Hamlet , hamlet , shamlet , xhamlet , HtmlUrl -- ** Julius , julius , JavascriptUrl , renderJavascriptUrl -- ** Cassius/Lucius , cassius , lucius , CssUrl , renderCssUrl ) where import Yesod.Core.Content import Yesod.Core.Dispatch import Yesod.Core.Handler import Yesod.Core.Class.Handler import Yesod.Core.Widget import Yesod.Core.Json import Yesod.Core.Types import Text.Shakespeare.I18N import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup) import Control.Monad.Logger import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Core.Internal.Session import Yesod.Core.Internal.Run (yesodRunner, yesodRender) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Breadcrumbs import qualified Yesod.Core.Internal.Run import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Routes.Class import UnliftIO (MonadIO (..), MonadUnliftIO (..)) import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp import Text.Hamlet import Text.Cassius import Text.Lucius import Text.Julius import Network.Wai (Application) runFakeHandler :: (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site -> HandlerT site IO a -> m (Either ErrorResponse a) runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler {-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-} -- | Return an 'Unauthorized' value, with the given i18n message. unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult unauthorizedI msg = do mr <- getMessageRender return $ Unauthorized $ mr msg yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only -- contain links to pages the user is allowed to see. maybeAuthorized :: Yesod site => Route site -> Bool -- ^ is this a write request? -> HandlerT site IO (Maybe (Route site)) maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) readIntegral :: Num a => String -> Maybe a readIntegral s = case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing yesod-core-1.6.24.5/src/Yesod/Core/Content.hs0000644000000000000000000002505614371110614016724 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} module Yesod.Core.Content ( -- * Content Content (..) , emptyContent , ToContent (..) , ToFlushBuilder (..) -- * Mime types -- ** Data type , ContentType , typeHtml , typePlain , typeJson , typeXml , typeAtom , typeRss , typeJpeg , typePng , typeGif , typeSvg , typeJavascript , typeCss , typeFlv , typeOgv , typeOctet -- * Utilities , simpleContentType , contentTypeTypes -- * Evaluation strategy , DontFullyEvaluate (..) -- * Representations , TypedContent (..) , ToTypedContent (..) , HasContentType (..) -- ** Specific content types , RepHtml , RepJson (..) , RepPlain (..) , RepXml (..) -- ** Smart constructors , repJson , repPlain , repXml ) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8Builder) import qualified Data.Text.Lazy as TL import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput) import Control.Monad (liftM) import Control.Monad.Trans.Resource (ResourceT) import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J import Data.Text.Lazy.Builder (toLazyText) import Data.Void (Void, absurd) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) import Data.Word8 (_semicolon, _slash) import Control.Arrow (second) -- | Zero-length enumerator. emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy -- bytestring and then calling 'toContent' on that. -- -- Please note that the built-in instances for lazy data structures ('String', -- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include -- the content length for the 'ContentBuilder' constructor. class ToContent a where toContent :: a -> Content instance ToContent Content where toContent = id instance ToContent Builder where toContent = flip ContentBuilder Nothing instance ToContent B.ByteString where toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs instance ToContent L.ByteString where toContent = flip ContentBuilder Nothing . lazyByteString instance ToContent T.Text where toContent = toContent . encodeUtf8Builder instance ToContent Text where toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks instance ToContent String where toContent = toContent . stringUtf8 instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where toContent () = toContent B.empty instance ToContent Void where toContent = absurd instance ToContent (ContentType, Content) where toContent = snd instance ToContent TypedContent where toContent (TypedContent _ c) = c instance ToContent (JSONResponse a) where toContent (JSONResponse a) = toContent $ J.toEncoding a instance ToContent Css where toContent = toContent . renderCss instance ToContent Javascript where toContent = toContent . toLazyText . unJavascript instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=) instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where toContent src = ContentSource $ mapOutput toFlushBuilder src instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where toContent (CI.SealedConduitT src) = toContent src -- | A class for all data which can be sent in a streaming response. Note that -- for textual data, instances must use UTF-8 encoding. -- -- Since 1.2.0 class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks) instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8 instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8 instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder repJson :: ToContent a => a -> RepJson repJson = RepJson . toContent repPlain :: ToContent a => a -> RepPlain repPlain = RepPlain . toContent repXml :: ToContent a => a -> RepXml repXml = RepXml . toContent class ToTypedContent a => HasContentType a where getContentType :: Monad m => m a -> ContentType instance HasContentType RepJson where getContentType _ = typeJson deriving instance ToContent RepJson instance HasContentType RepPlain where getContentType _ = typePlain deriving instance ToContent RepPlain instance HasContentType (JSONResponse a) where getContentType _ = typeJson instance HasContentType RepXml where getContentType _ = typeXml deriving instance ToContent RepXml typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" typePlain :: ContentType typePlain = "text/plain; charset=utf-8" typeJson :: ContentType typeJson = "application/json; charset=utf-8" typeXml :: ContentType typeXml = "text/xml" typeAtom :: ContentType typeAtom = "application/atom+xml" typeRss :: ContentType typeRss = "application/rss+xml" typeJpeg :: ContentType typeJpeg = "image/jpeg" typePng :: ContentType typePng = "image/png" typeGif :: ContentType typeGif = "image/gif" typeSvg :: ContentType typeSvg = "image/svg+xml" typeJavascript :: ContentType typeJavascript = "text/javascript; charset=utf-8" typeCss :: ContentType typeCss = "text/css; charset=utf-8" typeFlv :: ContentType typeFlv = "video/x-flv" typeOgv :: ContentType typeOgv = "video/ogg" typeOctet :: ContentType typeOctet = "application/octet-stream" -- | Removes \"extra\" information at the end of a content type string. In -- particular, removes everything after the semicolon, if present. -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.break (== _semicolon) -- | Give just the media types as a pair. -- -- For example, \"text/html; charset=utf-8\" returns ("text", "html") contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString) contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType where tailEmpty x = if B.null x then "" else B.tail x instance HasContentType a => HasContentType (DontFullyEvaluate a) where getContentType = getContentType . liftM unDontFullyEvaluate instance ToContent a => ToContent (DontFullyEvaluate a) where toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a instance ToContent J.Value where toContent = flip ContentBuilder Nothing . J.fromEncoding . J.toEncoding instance ToContent J.Encoding where toContent = flip ContentBuilder Nothing . J.fromEncoding instance HasContentType J.Value where getContentType _ = typeJson instance HasContentType J.Encoding where getContentType _ = typeJson instance HasContentType Html where getContentType _ = typeHtml instance HasContentType Text where getContentType _ = typePlain instance HasContentType T.Text where getContentType _ = typePlain instance HasContentType Css where getContentType _ = typeCss instance HasContentType Javascript where getContentType _ = typeJavascript -- | Any type which can be converted to 'TypedContent'. -- -- Since 1.2.0 class ToContent a => ToTypedContent a where toTypedContent :: a -> TypedContent instance ToTypedContent TypedContent where toTypedContent = id instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) instance ToTypedContent Void where toTypedContent = absurd instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where toTypedContent (RepJson c) = TypedContent typeJson c instance ToTypedContent RepPlain where toTypedContent (RepPlain c) = TypedContent typePlain c instance ToTypedContent RepXml where toTypedContent (RepXml c) = TypedContent typeXml c instance ToTypedContent J.Value where toTypedContent v = TypedContent typeJson (toContent v) instance ToTypedContent J.Encoding where toTypedContent e = TypedContent typeJson (toContent e) instance ToTypedContent Html where toTypedContent h = TypedContent typeHtml (toContent h) instance ToTypedContent T.Text where toTypedContent t = TypedContent typePlain (toContent t) instance ToTypedContent [Char] where toTypedContent = toTypedContent . pack instance ToTypedContent Text where toTypedContent t = TypedContent typePlain (toContent t) instance ToTypedContent (JSONResponse a) where toTypedContent c = TypedContent typeJson (toContent c) instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where toTypedContent (DontFullyEvaluate a) = let TypedContent ct c = toTypedContent a in TypedContent ct (ContentDontEvaluate c) instance ToTypedContent Css where toTypedContent = TypedContent typeCss . toContent instance ToTypedContent Javascript where toTypedContent = TypedContent typeJavascript . toContent yesod-core-1.6.24.5/src/Yesod/Core/Dispatch.hs0000644000000000000000000002216514371110614017047 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Core.Dispatch ( -- * Quasi-quoted routing parseRoutes , parseRoutesNoCheck , parseRoutesFile , parseRoutesFileNoCheck , mkYesod , mkYesodWith -- ** More fine-grained , mkYesodData , mkYesodSubData , mkYesodDispatch , mkYesodSubDispatch -- *** Helpers , defaultGen , getGetMaxExpires -- ** Path pieces , PathPiece (..) , PathMultiPiece (..) , Texts -- * Convert to WAI , toWaiApp , toWaiAppPlain , toWaiAppYre , warp , warpDebug , warpEnv , mkDefaultMiddlewares , defaultMiddlewaresNoLogging -- * WAI subsites , WaiSubsite (..) , WaiSubsiteWithAuth (..) ) where import Prelude hiding (exp) import Yesod.Core.Internal.TH import Language.Haskell.TH.Syntax (qLocation) import Web.PathPieces import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.Bits ((.|.), finiteBitSize, shiftL) import Data.Text (Text) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Builder (byteString, toLazyByteString) import Network.HTTP.Types (status301, status307) import Yesod.Routes.Parse import Yesod.Core.Types import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Text.Read (readMaybe) import System.Environment (getEnvironment) import System.Entropy (getEntropy) import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.MethodOverride import qualified Network.Wai.Handler.Warp import System.Log.FastLogger import Control.Monad.Logger import Control.Monad (when) import qualified Paths_yesod_core import Data.Version (showVersion) -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This function will provide no middlewares; if you want commonly -- used middlewares, please use 'toWaiApp'. toWaiAppPlain :: YesodDispatch site => site -> IO W.Application toWaiAppPlain site = do logger <- makeLogger site sb <- makeSessionBackend site getMaxExpires <- getGetMaxExpires return $ toWaiAppYre YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } -- | Generate a random number uniformly distributed in the full range -- of 'Int'. -- -- Note: Before 1.6.20, this generates pseudo-random number in an -- unspecified range. The range size may not be a power of 2. Since -- 1.6.20, this uses a secure entropy source and generates in the full -- range of 'Int'. -- -- @since 1.6.21.0 defaultGen :: IO Int defaultGen = bsToInt <$> getEntropy bytes where bits = finiteBitSize (undefined :: Int) bytes = div (bits + 7) 8 bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0 -- | Pure low level function to construct WAI application. Usefull -- when you need not standard way to run your app, or want to embed it -- inside another app. -- -- @since 1.4.29 toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application toWaiAppYre yre req = case cleanPath site $ W.pathInfo req of Left pieces -> sendRedirect site pieces req Right pieces -> yesodDispatch yre req { W.pathInfo = pieces } where site = yreSite yre sendRedirect :: Yesod master => master -> [Text] -> W.Application sendRedirect y segments' env sendResponse = sendResponse $ W.responseLBS status [ ("Content-Type", "text/plain") , ("Location", BL.toStrict $ toLazyByteString dest') ] "Redirecting" where -- Ensure that non-GET requests get redirected correctly. See: -- https://github.com/yesodweb/yesod/issues/951 status | W.requestMethod env == "GET" = status301 | otherwise = status307 dest = joinPath y (resolveApproot y env) segments' [] dest' = if S.null (W.rawQueryString env) then dest else dest `mappend` byteString (W.rawQueryString env) -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers: -- -- * Logging -- -- * GZIP compression -- -- * Automatic HEAD method handling -- -- * Request method override with the _method query string parameter -- -- * Accept header override with the _accept query string parameter toWaiApp :: YesodDispatch site => site -> IO W.Application toWaiApp site = do logger <- makeLogger site toWaiAppLogger logger site toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger logger site = do sb <- makeSessionBackend site getMaxExpires <- getGetMaxExpires let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } messageLoggerSource site logger $(qLocation >>= liftLoc) "yesod-core" LevelInfo (toLogStr ("Application launched" :: S.ByteString)) middleware <- mkDefaultMiddlewares logger return $ middleware $ toWaiAppYre yre -- | A convenience method to run an application using the Warp webserver on the -- specified port. Automatically calls 'toWaiApp'. Provides a default set of -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: -- -- * 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 -- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. -- -- Since 1.2.0 warp :: YesodDispatch site => Int -> site -> IO () warp port site = do logger <- makeLogger site toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings ( Network.Wai.Handler.Warp.setPort port $ Network.Wai.Handler.Warp.setServerName serverValue $ Network.Wai.Handler.Warp.setOnException (\_ e -> when (shouldLog' e) $ messageLoggerSource site logger $(qLocation >>= liftLoc) "yesod-core" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) Network.Wai.Handler.Warp.defaultSettings) where shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException serverValue :: S8.ByteString serverValue = S8.pack $ concat [ "Warp/" , Network.Wai.Handler.Warp.warpVersion , " + Yesod/" , showVersion Paths_yesod_core.version , " (core)" ] -- | A default set of middlewares. -- -- Since 1.2.0 mkDefaultMiddlewares :: Logger -> IO W.Middleware mkDefaultMiddlewares logger = do logWare <- mkRequestLogger def { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger , outputFormat = Apache FromSocket } return $ logWare . defaultMiddlewaresNoLogging -- | All of the default middlewares, excluding logging. -- -- Since 1.2.12 defaultMiddlewaresNoLogging :: W.Middleware defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride -- | Deprecated synonym for 'warp'. warpDebug :: YesodDispatch site => Int -> site -> IO () warpDebug = warp {-# DEPRECATED warpDebug "Please use warp instead" #-} -- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It -- reads port information from the PORT environment variable, as used by tools -- such as Keter and the FP Complete School of Haskell. -- -- Note that the exact behavior of this function may be modified slightly over -- time to work correctly with external tools, without a change to the type -- signature. warpEnv :: YesodDispatch site => site -> IO () warpEnv site = do env <- getEnvironment case lookup "PORT" env of Nothing -> error "warpEnv: no PORT environment variable found" Just portS -> case readMaybe portS of Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Just port -> warp port site -- | Default constructor for 'yreGetMaxExpires' field. Low level -- function for simple manual construction of 'YesodRunnerEnv'. -- -- @since 1.4.29 getGetMaxExpires :: IO (IO Text) getGetMaxExpires = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentMaxExpiresRFC1123 , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day } yesod-core-1.6.24.5/src/Yesod/Core/Handler.hs0000644000000000000000000017072114377567452016715 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- -- 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 , HandlerFor -- ** Read information from handler , getYesod , getsYesod , getUrlRender , getUrlRenderParams , getPostParams , getCurrentRoute , getRequest , waiRequest , runRequestBody , rawRequestBody -- ** Request information -- *** Request datatype , RequestBodyContents , YesodRequest (..) , FileInfo , fileName , fileContentType , fileSource , fileSourceByteString , fileMove -- *** Convenience functions , languages -- *** Lookup parameters , lookupGetParam , lookupPostParam , lookupCookie , lookupFile , lookupHeader -- **** Lookup authentication data , lookupBasicAuth , lookupBearerAuth -- **** Multi-lookup , lookupGetParams , lookupPostParams , lookupCookies , lookupFiles , lookupHeaders -- * Responses -- ** Pure , respond -- ** Streaming , respondSource , sendChunk , sendFlush , sendChunkBS , sendChunkLBS , sendChunkText , sendChunkLazyText , sendChunkHtml -- ** Redirecting , RedirectUrl (..) , redirect , redirectWith , redirectToPost , Fragment(..) -- ** Errors , notFound , badMethod , notAuthenticated , permissionDenied , permissionDeniedI , invalidArgs , invalidArgsI -- ** Short-circuit responses -- $rollbackWarning , sendFile , sendFilePart , sendResponse , sendResponseStatus -- ** Type specific response with custom status , sendStatusJSON , sendResponseCreated , sendResponseNoContent , sendWaiResponse , sendWaiApplication , sendRawResponse , sendRawResponseNoConduit , notModified -- * Different representations -- $representations , selectRep , provideRep , provideRepType , ProvidedRep -- * Setting headers , setCookie , getExpires , deleteCookie , addHeader , setHeader , replaceOrAddHeader , setLanguage , addContentDispositionFileName -- ** Content caching and expiration , cacheSeconds , neverExpires , alreadyExpired , expiresAt , setEtag , setWeakEtag -- * Session , SessionMap , lookupSession , lookupSessionBS , getSession , setSession , setSessionBS , deleteSession , clearSession -- ** Ultimate destination , setUltDest , setUltDestCurrent , setUltDestReferer , redirectUltDest , clearUltDest -- ** Messages , addMessage , addMessageI , getMessages , setMessage , setMessageI , getMessage -- * Subsites , SubHandlerFor , getSubYesod , getRouteToParent , getSubCurrentRoute -- * Helpers for specific content -- ** Hamlet , hamletToRepHtml , giveUrlRenderer , withUrlRenderer -- ** Misc , newIdent -- * Lifting , handlerToIO , forkHandler -- * i18n , getMessageRender -- * Per-request caching , cached , cacheGet , cacheSet , cachedBy , cacheByGet , cacheBySet -- * AJAX CSRF protection -- $ajaxCSRFOverview -- ** Setting CSRF Cookies , setCsrfCookie , setCsrfCookieWithCookie , defaultCsrfCookieName -- ** Looking up CSRF Headers , checkCsrfHeaderNamed , hasValidCsrfHeaderNamed , defaultCsrfHeaderName -- ** Looking up CSRF POST Parameters , hasValidCsrfParamNamed , checkCsrfParamNamed , defaultCsrfParamName -- ** Checking CSRF Headers or POST Parameters , checkCsrfHeaderOrParam ) where import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, mkFileInfoLBS, mkFileInfoSource) import Control.Applicative ((<|>)) import qualified Data.CaseInsensitive as CI import Control.Exception (evaluate, SomeException, throwIO) import Control.Exception (handle) import Control.Monad (void, liftM, unless) import qualified Control.Monad.Trans.Writer as Writer import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import qualified Network.HTTP.Types as H import qualified Network.Wai as W import Network.Wai.Middleware.HttpAuth ( extractBasicAuth, extractBearerAuth ) import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON(..)) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Hamlet (Html, HtmlUrl, hamlet) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.HashMap.Strict as HM import Data.ByteArray (constEq) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Monoid (Endo (..)) import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..), defaultSetCookie) import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToHtml, toHtml) import qualified Data.IORef as I import Data.Maybe (listToMaybe, mapMaybe) import Data.Typeable (Typeable) import Data.Kind (Type) import Web.PathPieces (PathPiece(..)) import Yesod.Core.Class.Handler import Yesod.Core.Types import Yesod.Routes.Class (Route) import Data.ByteString.Builder (Builder) import Data.CaseInsensitive (CI, original) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) import qualified System.PosixCompat.Files as PC import Conduit ((.|), runConduit, sinkLazy) import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void) import qualified Yesod.Core.TypeCache as Cache import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold import Control.Monad.Logger (MonadLogger, logWarnS) type HandlerT site (m :: Type -> Type) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-} get :: MonadHandler m => m GHState get = liftHandler $ HandlerFor $ I.readIORef . handlerState put :: MonadHandler m => GHState -> m () put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState modify :: MonadHandler m => (GHState -> GHState) -> m () modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState tell :: MonadHandler m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } handlerError :: MonadHandler m => HandlerContents -> m a handlerError = liftIO . throwIO hcError :: MonadHandler m => ErrorResponse -> m a hcError = handlerError . HCError getRequest :: MonadHandler m => m YesodRequest getRequest = liftHandler $ HandlerFor $ return . handlerRequest runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody = do HandlerData { handlerEnv = RunHandlerEnv {..} , handlerRequest = req } <- liftHandler $ HandlerFor return let len = W.requestBodyLength $ reqWaiRequest req upload = rheUpload len x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest internalState <- liftResourceT getInternalState rbc <- liftIO $ rbHelper upload rr internalState put x { ghsRBC = Just rbc } return rbc rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents rbHelper upload req internalState = case upload of FileUploadMemory s -> rbHelper' s mkFileInfoLBS req FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req FileUploadSource s -> rbHelper' s mkFileInfoSource req rbHelper' :: NWP.BackEnd x -> (Text -> Text -> x -> FileInfo) -> W.Request -> IO ([(Text, Text)], [(Text, FileInfo)]) rbHelper' backend mkFI req = (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req where fix1 = go *** go fix2 (x, NWP.FileInfo a' b c) | S.null a = Nothing | otherwise = Just (go x, mkFI (go a) (go b) c) where a | S.length a' < 2 = a' | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a' | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a' | otherwise = a' go = decodeUtf8With lenientDecode askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m)) askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv -- | Get the master site application argument. getYesod :: MonadHandler m => m (HandlerSite m) getYesod = rheSite <$> askHandlerEnv -- | Get a specific component of the master site application argument. -- Analogous to the 'gets' function for operating on 'StateT'. getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a getsYesod f = (f . rheSite) <$> askHandlerEnv -- | Get the URL rendering function. getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text) getUrlRender = do x <- rheRender <$> askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: MonadHandler m => m (Route (HandlerSite m) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender <$> askHandlerEnv -- | Get all the post parameters passed to the handler. To also get -- the submitted files (if any), you have to use 'runRequestBody' -- instead of this function. -- -- @since 1.4.33 getPostParams :: MonadHandler m => m [(Text, Text)] getPostParams = do reqBodyContent <- runRequestBody return $ fst reqBodyContent -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) getCurrentRoute = rheRoute <$> askHandlerEnv -- | Returns a function that runs 'HandlerFor' actions inside @IO@. -- -- Sometimes you want to run an inner 'HandlerFor' action outside -- the control flow of an HTTP request (on the outer 'HandlerFor' -- 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 HandlerFor but on a new thread./ -- /This is the inner HandlerFor./ -- ... -- /Code here runs inside the request's control flow./ -- /This is the outer HandlerFor./ -- ... -- @ -- -- Another use case for this function is creating a stream of -- server-sent events using 'HandlerFor' actions (see -- @yesod-eventsource@). -- -- Most of the environment from the outer 'HandlerFor' is preserved -- on the inner 'HandlerFor', however: -- -- * The request body is cleared (otherwise it would be very -- difficult to prevent huge memory leaks). -- -- * The cache is cleared (see 'cached'). -- -- Changes to the response made inside the inner 'HandlerFor' are -- ignored (e.g., session variables, cookies, response headers). -- This allows the inner 'HandlerFor' to outlive the outer -- 'HandlerFor' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread). handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a) handlerToIO = HandlerFor $ \oldHandlerData -> do -- Take just the bits we need from oldHandlerData. let newReq = oldReq { reqWaiRequest = newWaiReq } where oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq newWaiReq = oldWaiReq { W.requestBody = return mempty , W.requestBodyLength = W.KnownLength 0 } oldEnv = handlerEnv oldHandlerData newState <- liftIO $ do oldState <- I.readIORef (handlerState oldHandlerData) return $ oldState { ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty , ghsCacheBy = mempty , ghsHeaders = mempty } -- xx From this point onwards, no references to oldHandlerData xx liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) -- Return HandlerFor running function. return $ \(HandlerFor f) -> liftIO $ runResourceT $ withInternalState $ \resState -> do -- The state IORef needs to be created here, otherwise it -- will be shared by different invocations of this function. newStateIORef <- liftIO (I.newIORef newState) let newHandlerData = HandlerData { handlerRequest = newReq , handlerEnv = oldEnv , handlerState = newStateIORef , handlerResource = resState } liftIO (f newHandlerData) -- | forkIO for a Handler (run an action in the background) -- -- Uses 'handlerToIO', liftResourceT, and resourceForkIO -- for correctness and efficiency -- -- @since 1.2.8 forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler -> HandlerFor site () -> HandlerFor site () forkHandler onErr handler = do yesRunner <- handlerToIO void $ liftResourceT $ resourceForkIO $ liftIO $ handle (yesRunner . onErr) (yesRunner handler) -- | Redirect to the given route. -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0 -- This is the appropriate choice for a get-following-post -- technique, which should be the usual use case. -- -- If you want direct control of the final status code, or need a different -- status code, please use 'redirectWith'. redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m a redirect url = do req <- waiRequest let status = if W.httpVersion req == H.http11 then H.status303 else H.status302 redirectWith status url -- | Redirect to the given URL with the specified status code. redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url) => H.Status -> url -> m a redirectWith status url = do urlText <- toTextUrl url handlerError $ HCRedirect status urlText ultDestKey :: Text ultDestKey = "_ULT" -- | Sets the ultimate destination variable to the given route. -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m () setUltDest url = do urlText <- toTextUrl url setSession ultDestKey urlText -- | Same as 'setUltDest', but uses the current page. -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. setUltDestCurrent :: MonadHandler m => m () setUltDestCurrent = do route <- getCurrentRoute case route of Nothing -> return () Just r -> do gets' <- reqGetParams <$> getRequest setUltDest (r, gets') -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest. setUltDestReferer :: MonadHandler m => m () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders) (const $ return ()) mdest where setUltDestBS = setUltDest . T.pack . S8.unpack -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. -- -- The ultimate destination is set with 'setUltDest'. -- -- This function uses 'redirect', and thus will perform a temporary redirect to -- a GET request. redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m) => url -- ^ default destination if nothing in session -> m a redirectUltDest defaultDestination = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect defaultDestination) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. clearUltDest :: MonadHandler m => m () clearUltDest = deleteSession ultDestKey msgKey :: Text msgKey = "_MSG" -- | Adds a status and message in the user's session. -- -- See 'getMessages'. -- -- @since 1.4.20 addMessage :: MonadHandler m => Text -- ^ status -> Html -- ^ message -> m () addMessage status msg = do val <- lookupSessionBS msgKey setSessionBS msgKey $ addMsg val where addMsg = maybe msg' (S.append msg' . S.cons W8._nul) msg' = S.append (encodeUtf8 status) (W8._nul `S.cons` L.toStrict (renderHtml msg)) -- | Adds a message in the user's session but uses RenderMessage to allow for i18n -- -- See 'getMessages'. -- -- @since 1.4.20 addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => Text -> msg -> m () addMessageI status msg = do mr <- getMessageRender addMessage status $ toHtml $ mr msg -- | Gets all messages in the user's session, and then clears the variable. -- -- See 'addMessage'. -- -- @since 1.4.20 getMessages :: MonadHandler m => m [(Text, Html)] getMessages = do bs <- lookupSessionBS msgKey let ms = maybe [] enlist bs deleteSession msgKey return ms where enlist = pairup . S.split W8._nul pairup [] = [] pairup [_] = [] pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs decode = decodeUtf8With lenientDecode -- | Calls 'addMessage' with an empty status setMessage :: MonadHandler m => Html -> m () setMessage = addMessage "" -- | Calls 'addMessageI' with an empty status setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m () setMessageI = addMessageI "" -- | Gets just the last message in the user's session, -- discards the rest and the status getMessage :: MonadHandler m => m (Maybe Html) getMessage = fmap (fmap snd . listToMaybe) getMessages -- $rollbackWarning -- -- Note that since short-circuiting is implemented by using exceptions, -- using e.g. 'sendStatusJSON' inside a runDB block -- will result in the database actions getting rolled back: -- -- @ -- runDB $ do -- userId <- insert $ User "username" "email@example.com" -- postId <- insert $ BlogPost "title" "hi there!" -- /The previous two inserts will be rolled back./ -- sendStatusJSON Status.status200 () -- @ -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: MonadHandler m => ContentType -> FilePath -> m a sendFile ct fp = handlerError $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. sendFilePart :: MonadHandler m => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count -> m a sendFilePart ct fp off count = do fs <- liftIO $ PC.getFileStatus fp handlerError $ HCSendFile ct fp $ Just W.FilePart { W.filePartOffset = off , W.filePartByteCount = count , W.filePartFileSize = fromIntegral $ PC.fileSize fs } -- | Bypass remaining handler code and output the given content with a 200 -- status code. sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a sendResponse = handlerError . HCContent H.status200 . toTypedContent -- | Bypass remaining handler code and output the given content with the given -- status code. sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Bypass remaining handler code and output the given JSON with the given -- status code. -- -- @since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a sendStatusJSON s v = sendResponseStatus s (toEncoding v) -- | Send a 201 "Created" response with the given route as the Location -- response header. sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a sendResponseCreated url = do r <- getUrlRender handlerError $ HCCreated $ r url -- | Bypass remaining handler code and output no content with a 204 status code. -- -- @since 1.6.9 sendResponseNoContent :: MonadHandler m => m a sendResponseNoContent = sendWaiResponse $ W.responseBuilder H.status204 [] mempty -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't. sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai -- | Switch over to handling the current request with a WAI @Application@. -- -- @since 1.2.17 sendWaiApplication :: MonadHandler m => W.Application -> m b sendWaiApplication = handlerError . HCWaiApp -- | Send a raw response without conduit. This is used for cases such as -- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw -- responses (e.g., Warp). -- -- @since 1.2.16 sendRawResponseNoConduit :: (MonadHandler m, MonadUnliftIO m) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) -> m a sendRawResponseNoConduit raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO (raw src sink) where fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] "sendRawResponse: backend does not support raw responses" -- | Send a raw response. This is used for cases such as WebSockets. Requires -- WAI 2.1 or later, and a web server which supports raw responses (e.g., -- Warp). -- -- @since 1.2.7 sendRawResponse :: (MonadHandler m, MonadUnliftIO m) => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ()) -> m a sendRawResponse raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink) where fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] "sendRawResponse: backend does not support raw responses" src' src = do bs <- liftIO src unless (S.null bs) $ do yield bs src' src -- | Send a 304 not modified response immediately. This is a short-circuiting -- action. -- -- @since 1.4.4 notModified :: MonadHandler m => m a notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty -- | Return a 404 not found page. Also denotes no handler available. notFound :: MonadHandler m => m a notFound = hcError NotFound -- | Return a 405 method not supported page. badMethod :: MonadHandler m => m a badMethod = do w <- waiRequest hcError $ BadMethod $ W.requestMethod w -- | Return a 401 status code notAuthenticated :: MonadHandler m => m a notAuthenticated = hcError NotAuthenticated -- | Return a 403 permission denied page. permissionDenied :: MonadHandler m => Text -> m a permissionDenied = hcError . PermissionDenied -- | Return a 403 permission denied page. permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m) => msg -> m a permissionDeniedI msg = do mr <- getMessageRender permissionDenied $ mr msg -- | Return a 400 invalid arguments page. invalidArgs :: MonadHandler m => [Text] -> m a invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page. invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg ------- Headers -- | Set the cookie on the client. setCookie :: MonadHandler m => SetCookie -> m () setCookie sc = do addHeaderInternal (DeleteCookie name path) addHeaderInternal (AddCookie sc) where name = setCookieName sc path = maybe "/" id (setCookiePath sc) -- | Helper function for setCookieExpires value getExpires :: MonadIO m => Int -- ^ minutes -> m UTCTime getExpires m = do now <- liftIO getCurrentTime return $ fromIntegral (m * 60) `addUTCTime` now -- | Unset the cookie on the client. -- -- Note: although the value used for key and path is 'Text', you should only -- use ASCII values to be HTTP compliant. deleteCookie :: MonadHandler m => Text -- ^ key -> Text -- ^ path -> m () deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8 -- | Set the language in the user session. Will show up in 'languages' on the -- next request. setLanguage :: MonadHandler m => Text -> m () setLanguage = setSession langKey -- | Set attachment file name. -- -- Allows Unicode characters by encoding to UTF-8. -- Some modurn browser parse UTF-8 characters with out encoding setting. -- But, for example IE9 can't parse UTF-8 characters. -- This function use -- () -- -- @since 1.6.4 addContentDispositionFileName :: MonadHandler m => T.Text -> m () addContentDispositionFileName fileName = addHeader "Content-Disposition" $ rfc6266Utf8FileName fileName -- | Unicode attachment filename. -- -- > rfc6266Utf8FileName (Data.Text.pack "€") -- "attachment; filename*=UTF-8''%E2%82%AC" rfc6266Utf8FileName :: T.Text -> T.Text rfc6266Utf8FileName fileName = "attachment; filename*=UTF-8''" `mappend` decodeUtf8 (H.urlEncode True (encodeUtf8 fileName)) -- | Set an arbitrary response header. -- -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -- -- @since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m () addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} -- | Replace an existing header with a new value or add a new header -- if not present. -- -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -- -- @since 1.4.36 replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b) sameHeaderName :: Header -> Header -> Bool sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 sameHeaderName _ _ = False replaceIndividualHeader :: [Header] -> [Header] replaceIndividualHeader [] = [repHeader] replaceIndividualHeader xs = aux xs [] where aux [] acc = acc ++ [repHeader] aux (x:xs') acc = if sameHeaderName repHeader x then acc ++ [repHeader] ++ (filter (\header -> not (sameHeaderName header repHeader)) xs') else aux xs' (acc ++ [x]) replaceHeader :: Endo [Header] -> Endo [Header] replaceHeader endo = let allHeaders :: [Header] = appEndo endo [] in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: MonadHandler m => Int -> m () cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age=" , T.pack $ show i , ", public" ] -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. neverExpires :: MonadHandler m => m () neverExpires = do setHeader "Expires" . rheMaxExpires =<< askHandlerEnv cacheSeconds oneYear where oneYear :: Int oneYear = 60 * 60 * 24 * 365 -- | Set an Expires header in the past, meaning this content should not be -- cached. alreadyExpired :: MonadHandler m => m () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: MonadHandler m => UTCTime -> m () expiresAt = setHeader "Expires" . formatRFC1123 data Etag = WeakEtag !S.ByteString -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are -- semantically identical but make no guarantees about being bytewise identical. | StrongEtag !S.ByteString -- ^ Signifies that contents should be byte-for-byte identical if they match -- the provided ETag | InvalidEtag !S.ByteString -- ^ Anything else that ends up in a header that expects an ETag but doesn't -- properly follow the ETag format specified in RFC 7232, section 2.3 deriving (Show, Eq) -- | Check the if-none-match header and, if it matches the given value, return -- a 304 not modified response. Otherwise, set the etag header to the given -- value. -- -- Note that it is the responsibility of the caller to ensure that the provided -- value is a valid etag value, no sanity checking is performed by this -- function. -- -- @since 1.4.4 setEtag :: MonadHandler m => Text -> m () setEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch baseTag = encodeUtf8 etag strongTag = StrongEtag baseTag badTag = InvalidEtag baseTag if any (\tag -> tag == strongTag || tag == badTag) matches then notModified else addHeader "etag" $ T.concat ["\"", etag, "\""] -- | Parse an if-none-match field according to the spec. parseMatch :: S.ByteString -> [Etag] parseMatch = map clean . S.split W8._comma where clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace classify bs | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl = StrongEtag $ S.init $ S.tail bs | S.length bs >= 4 && S.head bs == W8._W && S.index bs 1 == W8._slash && S.index bs 2 == W8._quotedbl && S.last bs == W8._quotedbl = WeakEtag $ S.init $ S.drop 3 bs | otherwise = InvalidEtag bs -- | Check the if-none-match header and, if it matches the given value, return -- a 304 not modified response. Otherwise, set the etag header to the given -- value. -- -- A weak etag is only expected to be semantically identical to the prior content, -- but doesn't have to be byte-for-byte identical. Therefore it can be useful for -- dynamically generated content that may be difficult to perform bytewise hashing -- upon. -- -- Note that it is the responsibility of the caller to ensure that the provided -- value is a valid etag value, no sanity checking is performed by this -- function. -- -- @since 1.4.37 setWeakEtag :: MonadHandler m => Text -> m () setWeakEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch if WeakEtag (encodeUtf8 etag) `elem` matches then notModified else addHeader "etag" $ T.concat ["W/\"", etag, "\""] -- | Set a variable in the user's session. -- -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. setSession :: MonadHandler m => Text -- ^ key -> Text -- ^ value -> m () setSession k = setSessionBS k . encodeUtf8 -- | Same as 'setSession', but uses binary data for the value. setSessionBS :: MonadHandler m => Text -> S.ByteString -> m () setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: MonadHandler m => Text -> m () deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- -- @since: 1.0.1 clearSession :: MonadHandler m => m () clearSession = modify $ \x -> x { ghsSession = Map.empty } modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'. addHeaderInternal :: MonadHandler m => Header -> m () addHeaderInternal = tell . Endo . (:) -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text instance RedirectUrl master Text where toTextUrl = return instance RedirectUrl master String where toTextUrl = toTextUrl . T.pack instance RedirectUrl master (Route master) where toTextUrl url = do r <- getUrlRender return $ r url instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where toTextUrl (url, params) = do r <- getUrlRenderParams return $ r url params instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where toTextUrl (url, params) = toTextUrl (url, Map.toList params) -- | Add a fragment identifier to a route to be used when -- redirecting. For example: -- -- > redirect (NewsfeedR :#: storyId) -- -- @since 1.2.9. data Fragment a b = a :#: b deriving Show instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a -- | Lookup for session data. lookupSession :: MonadHandler m => Text -> m (Maybe Text) lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do m <- fmap ghsSession get return $ Map.lookup n m -- | Get all session variables. getSession :: MonadHandler m => m SessionMap getSession = fmap ghsSession get -- | Get a unique identifier. newIdent :: MonadHandler m => m Text newIdent = do x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' } return $ T.pack $ "hident" ++ show i' -- | Redirect to a POST resource. -- -- This is not technically a redirect; instead, it returns an HTML page with a -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m a redirectToPost url = do urlText <- toTextUrl url req <- getRequest withUrlRenderer [hamlet| $newline never $doctype 5 Redirecting... <body> <form id="form" method="post" action=#{urlText}> $maybe token <- reqToken req <input type=hidden name=#{defaultCsrfParamName} value=#{token}> <noscript> <p>Javascript has been disabled; please click on the button below to be redirected. <input type="submit" value="Continue"> <script> window.onload = function() { document.getElementById('form').submit(); }; |] >>= sendResponse -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html hamletToRepHtml = withUrlRenderer {-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-} -- | Deprecated synonym for 'withUrlRenderer'. -- -- @since 1.2.0 giveUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output giveUrlRenderer = withUrlRenderer {-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-} -- | Provide a URL rendering function to the given function and return the -- result. Useful for processing Shakespearean templates. -- -- @since 1.2.20 withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output withUrlRenderer f = do render <- getUrlRenderParams return $ f render -- | Get the request\'s 'W.Request' value. waiRequest :: MonadHandler m => m W.Request waiRequest = reqWaiRequest <$> getRequest getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) => m (message -> Text) getMessageRender = do env <- askHandlerEnv l <- languages return $ renderMessage (rheSite env) l -- | Use a per-request cache to avoid performing the same action multiple times. -- Values are stored by their type, the result of typeOf from Typeable. -- Therefore, you should use different newtype wrappers at each cache site. -- -- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth. -- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts. -- -- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals> -- -- @since 1.2.0 cached :: (MonadHandler m, Typeable a) => m a -> m a cached action = do cache <- ghsCache <$> get eres <- Cache.cached cache action case eres of Right res -> return res Left (newCache, res) -> do gs <- get let merged = newCache `HM.union` ghsCache gs put $ gs { ghsCache = merged } return res -- | Retrieves a value from the cache used by 'cached'. -- -- @since 1.6.10 cacheGet :: (MonadHandler m, Typeable a) => m (Maybe a) cacheGet = do cache <- ghsCache <$> get pure $ Cache.cacheGet cache -- | Sets a value in the cache used by 'cached'. -- -- @since 1.6.10 cacheSet :: (MonadHandler m, Typeable a) => a -> m () cacheSet value = do gs <- get let cache = ghsCache gs newCache = Cache.cacheSet value cache put $ gs { ghsCache = newCache } -- | a per-request cache. just like 'cached'. -- 'cached' can only cache a single value per type. -- 'cachedBy' stores multiple values per type by usage of a ByteString key -- -- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user -- 'cachedBy' is required if the action has parameters and can return multiple values per type. -- You can turn those parameters into a ByteString cache key. -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. -- -- @since 1.4.0 cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a cachedBy k action = do cache <- ghsCacheBy <$> get eres <- Cache.cachedBy cache k action case eres of Right res -> return res Left (newCache, res) -> do gs <- get let merged = newCache `HM.union` ghsCacheBy gs put $ gs { ghsCacheBy = merged } return res -- | Retrieves a value from the cache used by 'cachedBy'. -- -- @since 1.6.10 cacheByGet :: (MonadHandler m, Typeable a) => S.ByteString -> m (Maybe a) cacheByGet key = do cache <- ghsCacheBy <$> get pure $ Cache.cacheByGet key cache -- | Sets a value in the cache used by 'cachedBy'. -- -- @since 1.6.10 cacheBySet :: (MonadHandler m, Typeable a) => S.ByteString -> a -> m () cacheBySet key value = do gs <- get let cache = ghsCacheBy gs newCache = Cache.cacheBySet key value cache put $ gs { ghsCacheBy = newCache } -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following (in descending order -- of preference): -- -- * The _LANG get parameter. -- -- * The _LANG user session variable. -- -- * The _LANG cookie. -- -- * Accept-Language HTTP header. -- -- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates. -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). -- -- __NOTE__: Before version @1.6.19.0@, this function prioritized the session -- variable above all other sources. -- languages :: MonadHandler m => m [Text] languages = reqLangs <$> 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 = fmap listToMaybe . lookupHeaders -- | Lookup a request header. -- -- @since 1.2.2 lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString] lookupHeaders key = do req <- waiRequest return $ lookup' key $ W.requestHeaders req -- | Lookup basic authentication data from __Authorization__ header of -- request. Returns user name and password -- -- @since 1.4.9 lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") where getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode) <$> extractBasicAuth bs -- | Lookup bearer authentication datafrom __Authorization__ header of -- request. Returns bearer token value -- -- @since 1.4.9 lookupBearerAuth :: (MonadHandler m) => m (Maybe Text) lookupBearerAuth = fmap (>>= getBR) (lookupHeader "Authorization") where getBR bs = decodeUtf8With lenientDecode <$> extractBearerAuth bs -- | Lookup for GET parameters. lookupGetParams :: MonadHandler m => Text -> m [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. lookupGetParam :: MonadHandler m => Text -> m (Maybe Text) lookupGetParam = fmap listToMaybe . lookupGetParams -- | Lookup for POST parameters. lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp lookupPostParam :: (MonadResource m, MonadHandler m) => Text -> m (Maybe Text) lookupPostParam = fmap listToMaybe . lookupPostParams -- | Lookup for POSTed files. lookupFile :: MonadHandler m => Text -> m (Maybe FileInfo) lookupFile = fmap listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: MonadHandler m => Text -> m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. lookupCookie :: MonadHandler m => Text -> m (Maybe Text) lookupCookie = fmap listToMaybe . lookupCookies -- | Lookup for cookie data. lookupCookies :: MonadHandler m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr -- $representations -- -- HTTP allows content negotation to determine what /representation/ of data -- you would like to use. The most common example of this is providing both a -- user-facing HTML page and an API facing JSON response from the same URL. The -- means of achieving this is the Accept HTTP header, which provides a list of -- content types the client will accept, sorted by preference. -- -- By using 'selectRep' and 'provideRep', you can provide a number of different -- representations, e.g.: -- -- > selectRep $ do -- > provideRep produceHtmlOutput -- > provideRep produceJsonOutput -- -- The first provided representation will be used if no matches are found. -- | Select a representation to send to the client based on the representations -- provided inside this do-block. Should be used together with 'provideRep'. -- -- @since 1.2.0 selectRep :: MonadHandler m => Writer.Writer (Endo [ProvidedRep m]) () -> m TypedContent selectRep w = do -- the content types are already sorted by q values -- which have been stripped cts <- fmap reqAccept getRequest case mapMaybe tryAccept cts of [] -> case reps of [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text) rep:_ -> returnRep rep rep:_ -> returnRep rep where returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent reps = appEndo (Writer.execWriter w) [] repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList [ (k, v) , (noSpace k, v) , (simpleContentType k, v) ]) reps -- match on the type for sub-type wildcards. -- If the accept is text/ * it should match a provided text/html mainTypeMap = Map.fromList $ reverse $ map (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps tryAccept ct = if subType == "*" then if mainType == "*" then listToMaybe reps else Map.lookup mainType mainTypeMap else lookupAccept ct where (mainType, subType) = contentTypeTypes ct lookupAccept ct = Map.lookup ct repMap <|> Map.lookup (noSpace ct) repMap <|> Map.lookup (simpleContentType ct) repMap -- Mime types such as "text/html; charset=foo" get converted to -- "text/html;charset=foo" noSpace = S8.filter (/= ' ') -- | Internal representation of a single provided representation. -- -- @since 1.2.0 data ProvidedRep m = ProvidedRep !ContentType !(m Content) -- | Provide a single representation to be used, based on the request of the -- client. Should be used together with 'selectRep'. -- -- @since 1.2.0 provideRep :: (Monad m, HasContentType a) => m a -> Writer.Writer (Endo [ProvidedRep m]) () provideRep handler = provideRepType (getContentType handler) handler -- | Same as 'provideRep', but instead of determining the content type from the -- type of the value itself, you provide the content type separately. This can -- be a convenience instead of creating newtype wrappers for uncommonly used -- content types. -- -- > provideRepType "application/x-special-format" "This is the content" -- -- @since 1.2.0 provideRepType :: (Monad m, ToContent a) => ContentType -> m a -> Writer.Writer (Endo [ProvidedRep m]) () provideRepType ct handler = Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):) -- | Stream in the raw request body without any parsing. -- -- @since 1.2.0 rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m () rawRequestBody = do req <- lift waiRequest let loop = do bs <- liftIO $ W.requestBody req unless (S.null bs) $ do yield bs loop loop -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@. fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m () fileSource = transPipe liftResourceT . fileSourceRaw -- | Extract a strict `ByteString` body from a `FileInfo`. -- -- This function will block while reading the file. -- -- > do -- > fileByteString <- fileSourceByteString fileInfo -- -- @since 1.6.5 fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString fileSourceByteString fileInfo = runConduit (L.toStrict <$> (fileSource fileInfo .| sinkLazy)) -- | Provide a pure value for the response body. -- -- > respond ct = return . TypedContent ct . toContent -- -- @since 1.2.0 respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent respond ct = return . TypedContent ct . toContent -- | Use a @Source@ for the response body. -- -- Note that, for ease of use, the underlying monad is a @HandlerFor@. This -- implies that you can run any @HandlerFor@ action. However, since a streaming -- response occurs after the response headers have already been sent, some -- actions make no sense here. For example: short-circuit responses, setting -- headers, changing status codes, etc. -- -- @since 1.2.0 respondSource :: ContentType -> ConduitT () (Flush Builder) (HandlerFor site) () -> HandlerFor site TypedContent respondSource ctype src = HandlerFor $ \hd -> -- Note that this implementation relies on the fact that the ResourceT -- environment provided by the server is the same one used in HandlerFor. -- This is a safe assumption assuming the HandlerFor is run correctly. return $ TypedContent ctype $ ContentSource $ transPipe (lift . flip unHandlerFor hd) src -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. -- -- @since 1.2.0 sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m () sendChunk = yield . toFlushBuilder -- | In a streaming response, send a flush command, causing all buffered data -- to be immediately sent to the client. -- -- @since 1.2.0 sendFlush :: Monad m => ConduitT i (Flush Builder) m () sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- -- @since 1.2.0 sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m () sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- -- @since 1.2.0 sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m () sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- -- @since 1.2.0 sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m () sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- -- @since 1.2.0 sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m () sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- -- @since 1.2.0 sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m () sendChunkHtml = sendChunk -- $ajaxCSRFOverview -- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in. -- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs. -- This is known as a <https://en.wikipedia.org/wiki/Cross-site_request_forgery Cross Site Request Forgery> (CSRF) attack. -- -- To combat this attack, you need a way to verify that the request is valid. -- This is achieved by generating a random string ("token"), storing it in your encrypted session so that the server can look it up (see 'reqToken'), and adding the token to HTTP requests made to your server. -- When a request comes in, the token in the request is compared to the one from the encrypted session. If they match, you can be sure the request is valid. -- -- Yesod implements this behavior in two ways: -- -- (1) The yesod-form package <http://www.yesodweb.com/book/forms#forms_running_forms stores the CSRF token in a hidden field> in the form, then validates it with functions like 'Yesod.Form.Functions.runFormPost'. -- -- (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session. -- -- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam'). -- -- The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware. -- -- === Opting-out of CSRF checking for specific routes -- -- (Note: this code is generic to opting out of any Yesod middleware) -- -- @ -- 'yesodMiddleware' app = do -- maybeRoute <- 'getCurrentRoute' -- let dontCheckCsrf = case maybeRoute of -- Just HomeR -> True -- Don't check HomeR -- Nothing -> True -- Don't check for 404s -- _ -> False -- Check other routes -- -- 'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app -- @ -- -- This can also be implemented using the 'csrfCheckMiddleware' function. -- | The default cookie name for the CSRF token ("XSRF-TOKEN"). -- -- @since 1.4.14 defaultCsrfCookieName :: S8.ByteString defaultCsrfCookieName = "XSRF-TOKEN" -- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name. -- -- The cookie's path is set to @/@, making it valid for your whole website. -- -- @since 1.4.14 setCsrfCookie :: MonadHandler m => m () setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie { setCookieName = defaultCsrfCookieName , setCookiePath = Just "/" } -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. -- -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- -- @since 1.4.14 setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m () setCsrfCookieWithCookie cookie = do mCsrfToken <- reqToken <$> getRequest Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token }) -- | The default header name for the CSRF token ("X-XSRF-TOKEN"). -- -- @since 1.4.14 defaultCsrfHeaderName :: CI S8.ByteString defaultCsrfHeaderName = "X-XSRF-TOKEN" -- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () checkCsrfHeaderNamed headerName = do (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader]) -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName -- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages. hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text) hasValidCsrfHeaderNamed' headerName = do mCsrfToken <- reqToken <$> getRequest mXsrfHeader <- lookupHeader headerName return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader) -- CSRF Parameter checking -- | The default parameter name for the CSRF token ("_token") -- -- @since 1.4.14 defaultCsrfParamName :: Text defaultCsrfParamName = "_token" -- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 checkCsrfParamNamed :: MonadHandler m => Text -> m () checkCsrfParamNamed paramName = do (valid, mParam) <- hasValidCsrfParamNamed' paramName unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam]) -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName -- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages. hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text) hasValidCsrfParamNamed' paramName = do mCsrfToken <- reqToken <$> getRequest mCsrfParam <- lookupPostParam paramName return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam) -- | Checks that a valid CSRF token is present in either the request headers or POST parameters. -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error. -- -- @since 1.4.14 checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m) => CI S8.ByteString -- ^ The header name to lookup the CSRF token -> Text -- ^ The POST parameter name to lookup the CSRF token -> m () checkCsrfHeaderOrParam headerName paramName = do (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName (validParam, mParam) <- hasValidCsrfParamNamed' paramName unless (validHeader || validParam) $ do let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam] $logWarnS "yesod-core" errorMessage permissionDenied errorMessage validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool -- It's important to use constant-time comparison (constEq) in order to avoid timing attacks. validCsrf (Just token) (Just param) = encodeUtf8 token `constEq` param validCsrf Nothing _param = True validCsrf (Just _token) Nothing = False data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value | CSRFParam Text (Maybe Text) -- Key/Value csrfErrorMessage :: [CSRFExpectation] -> Text -- ^ Error message csrfErrorMessage expectedLocations = T.intercalate "\n" [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether." , "If you're a developer of this site, these tips will help you debug the issue:" , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection." , "- Check that your HTTP client is persisting cookies between requests, like a browser does." , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "." , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations) ] where csrfLocation expected = case expected of CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)] CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)] formatValue :: Maybe Text -> Text formatValue maybeText = case maybeText of Nothing -> "(which is not currently set)" Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"] getSubYesod :: MonadHandler m => m (SubHandlerSite m) getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m)) getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m))) getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv �����������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Json.hs����������������������������������������������������������0000644�0000000�0000000�00000020106�14371110614�016212� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Core.Json ( -- * Convert from a JSON value defaultLayoutJson , jsonToRepJson , returnJson , returnJsonEncoding , provideJson -- * Convert to a JSON value , parseCheckJsonBody , parseInsecureJsonBody , requireCheckJsonBody , requireInsecureJsonBody -- ** Deprecated JSON conversion , parseJsonBody , parseJsonBody_ , requireJsonBody -- * Produce JSON values , J.Value (..) , J.ToJSON (..) , J.FromJSON (..) , array , object , (.=) , (J..:) -- * Convenience functions , jsonOrRedirect , jsonEncodingOrRedirect , acceptsJson -- * Checking if data is JSON , contentTypeHeaderIsJson ) where import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader) import Control.Monad.Trans.Writer (Writer) import Data.Monoid (Endo) import Yesod.Core.Content (TypedContent) import Yesod.Core.Types (reqAccept) import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Handler import Yesod.Core.Widget (WidgetFor) import Yesod.Routes.Class import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP import Data.Aeson ((.=), object) import Data.Conduit.Attoparsec (sinkParser) import Data.Text (pack) import qualified Data.Vector as V import Data.Conduit import Data.Conduit.Lift import qualified Data.ByteString.Char8 as B8 import Data.Maybe (listToMaybe) import Control.Monad (liftM) -- | Provide both an HTML and JSON representation for a piece of -- data, using the default layout for the HTML output -- ('defaultLayout'). -- -- @since 0.3.0 defaultLayoutJson :: (Yesod site, J.ToJSON a) => WidgetFor site () -- ^ HTML -> HandlerFor site a -- ^ JSON -> HandlerFor site TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w provideRep $ fmap J.toEncoding json -- | Wraps a data type in a 'RepJson'. The data type must -- support conversion to JSON via 'J.ToJSON'. -- -- @since 0.3.0 jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value jsonToRepJson = return . J.toJSON {-# DEPRECATED jsonToRepJson "Use returnJson instead" #-} -- | Convert a value to a JSON representation via aeson\'s 'J.toJSON' function. -- -- @since 1.2.1 returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value returnJson = return . J.toJSON -- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function. -- -- @since 1.4.21 returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding returnJsonEncoding = return . J.toEncoding -- | Provide a JSON representation for usage with 'selectReps', using aeson\'s -- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion. -- -- @since 1.2.1 provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) () provideJson = provideRep . return . J.toEncoding -- | Same as 'parseInsecureJsonBody' -- -- @since 0.3.0 parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseJsonBody = parseInsecureJsonBody {-# DEPRECATED parseJsonBody "Use parseCheckJsonBody or parseInsecureJsonBody instead" #-} -- | Same as 'parseCheckJsonBody', but does not check that the mime type -- indicates JSON content. -- -- Note: This function is vulnerable to CSRF attacks. -- -- @since 1.6.11 parseInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseInsecureJsonBody = do eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value') return $ case eValue of Left e -> J.Error $ show e Right value -> J.fromJSON value -- | Parse the request body to a data type as a JSON value. The -- data type must support conversion from JSON via 'J.FromJSON'. -- If you want the raw JSON value, just ask for a @'J.Result' -- 'J.Value'@. -- -- The MIME type must indicate JSON content. Requiring a JSON -- content-type helps secure your site against CSRF attacks -- (browsers will perform POST requests for form and text/plain -- content-types without doing a CORS check, and those content-types -- can easily contain valid JSON). -- -- Note that this function will consume the request body. As such, calling it -- twice will result in a parse error on the second call, since the request -- body will no longer be available. -- -- @since 0.3.0 parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseCheckJsonBody = do mct <- lookupHeader "content-type" case fmap contentTypeHeaderIsJson mct of Just True -> parseInsecureJsonBody _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a parseJsonBody_ = requireInsecureJsonBody {-# DEPRECATED parseJsonBody_ "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-} -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse -- error. requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireJsonBody = requireInsecureJsonBody {-# DEPRECATED requireJsonBody "Use requireCheckJsonBody or requireInsecureJsonBody instead" #-} -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse -- error. -- -- @since 1.6.11 requireInsecureJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireInsecureJsonBody = do ra <- parseInsecureJsonBody case ra of J.Error s -> invalidArgs [pack s] J.Success a -> return a -- | Same as 'parseCheckJsonBody', but return an invalid args response on a parse -- error. requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireCheckJsonBody = do ra <- parseCheckJsonBody case ra of J.Error s -> invalidArgs [pack s] J.Success a -> return a -- | Convert a list of values to an 'J.Array'. array :: J.ToJSON a => [a] -> J.Value array = J.Array . V.fromList . map J.toJSON -- | jsonOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: -- -- 1. 200 with JSON data if the client prefers -- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. jsonOrRedirect :: (MonadHandler m, J.ToJSON a) => Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON -> m J.Value jsonOrRedirect = jsonOrRedirect' J.toJSON -- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: -- -- 1. 200 with JSON data if the client prefers -- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. -- @since 1.4.21 jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a) => Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON -> m J.Encoding jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding jsonOrRedirect' :: MonadHandler m => (a -> b) -> Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON -> m b jsonOrRedirect' f r j = do q <- acceptsJson if q then return (f j) else redirect r -- | Returns @True@ if the client prefers @application\/json@ as -- indicated by the @Accept@ HTTP header. acceptsJson :: MonadHandler m => m Bool acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';')) . listToMaybe . reqAccept) `liftM` getRequest -- | Given the @Content-Type@ header, returns if it is JSON. -- -- This function is currently a simple check for @application/json@, but in the future may check for -- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@. -- -- @since 1.6.17 contentTypeHeaderIsJson :: B8.ByteString -> Bool contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json" ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Widget.hs��������������������������������������������������������0000644�0000000�0000000�00000035767�14377567452�016575� 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 QuasiQuotes #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Core.Widget ( -- * Datatype WidgetT , WidgetFor , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets , whamlet , whamletFile , ihamletToRepHtml , ihamletToHtml -- * Convert to Widget , ToWidget (..) , ToWidgetHead (..) , ToWidgetBody (..) , ToWidgetMedia (..) -- * Creating -- ** Head of page , setTitle , setTitleI , setDescription , setDescriptionI , setDescriptionIdemp , setDescriptionIdempI , setOGType , setOGImage -- ** CSS , addStylesheet , addStylesheetAttrs , addStylesheetRemote , addStylesheetRemoteAttrs , addStylesheetEither , CssBuilder (..) -- ** Javascript , addScript , addScriptAttrs , addScriptRemote , addScriptRemoteAttrs , addScriptEither -- * Subsites , handlerToWidget -- * Internal , whamletFileWithSettings , asWidgetT ) where import Data.Monoid import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text) import Data.Kind (Type) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Yesod.Core.Types import Yesod.Core.Class.Handler type WidgetT site (m :: Type -> Type) = WidgetFor site {-# DEPRECATED WidgetT "Use WidgetFor directly" #-} preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup class ToWidget site a where toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidget site (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where toWidget = liftWidget instance ToWidget site Html where toWidget = toWidget . const -- | @since 1.4.28 instance ToWidget site Text where toWidget = toWidget . toHtml -- | @since 1.4.28 instance ToWidget site TL.Text where toWidget = toWidget . toHtml -- | @since 1.4.28 instance ToWidget site TB.Builder where toWidget = toWidget . toHtml -- | Allows adding some CSS to the page with a specific media type. -- -- Since 1.2 class ToWidgetMedia site a where -- | Add the given content to the page, but only for the given media type. -- -- Since 1.2 toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site) => Text -- ^ media value -> a -> m () instance render ~ RY site => ToWidgetMedia site (render -> Css) where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x instance ToWidgetMedia site Css where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget instance render ~ RY site => ToWidgetBody site (render -> Javascript) where toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetBody site Javascript where toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetBody site Html where toWidgetBody = toWidget class ToWidgetHead site a where toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget instance ToWidgetHead site Css where toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where toWidgetHead = toWidget instance ToWidgetHead site CssBuilder where toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> Javascript) where toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetHead site Javascript where toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetHead site Html where toWidgetHead = toWidgetHead . const -- | Set the page title. -- -- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set -- values. -- -- SEO Notes: -- -- * Title tags are the second most important on-page factor for SEO, after -- content -- * Every page should have a unique title tag -- * Start your title tag with your main targeted keyword -- * Don't stuff your keywords -- * Google typically shows 55-64 characters, so aim to keep your title -- length under 60 characters setTitle :: MonadWidget m => Html -> m () setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty -- | Set the localised page title. -- -- n.b. See comments for @setTitle@ setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setTitleI msg = do mr <- getMessageRender setTitle $ toHtml $ mr msg -- | Add description meta tag to the head of the page -- -- Google does not use the description tag as a ranking signal, but the -- contents of this tag will likely affect your click-through rate since it -- shows up in search results. -- -- The average length of the description shown in Google's search results is -- about 160 characters on desktop, and about 130 characters on mobile, at time -- of writing. -- -- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/ -- -- @since 1.6.18 setDescription :: MonadWidget m => Text -> m () setDescription description = toWidgetHead $ [hamlet|<meta name=description content=#{description}>|] {-# WARNING setDescription [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead" , "Multiple calls to setDescription will insert multiple meta tags in the page head." , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \ \may need to change your layout to include pageDescription." ] #-} -- | Add translated description meta tag to the head of the page -- -- n.b. See comments for @setDescription@. -- -- @since 1.6.18 setDescriptionI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setDescriptionI msg = do mr <- getMessageRender toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] {-# WARNING setDescriptionI [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead" , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head." , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \ \may need to change your layout to include pageDescription." ] #-} -- | Add description meta tag to the head of the page -- -- Google does not use the description tag as a ranking signal, but the -- contents of this tag will likely affect your click-through rate since it -- shows up in search results. -- -- The average length of the description shown in Google's search results is -- about 160 characters on desktop, and about 130 characters on mobile, at time -- of writing. -- -- Unlike 'setDescription', this version is *idempotent* - calling it multiple -- times will result in only a single description meta tag in the head. -- -- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/ -- -- @since 1.6.23 setDescriptionIdemp :: MonadWidget m => Text -> m () setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty -- | Add translated description meta tag to the head of the page -- -- n.b. See comments for @setDescriptionIdemp@. -- -- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple -- times will result in only a single description meta tag in the head. -- -- @since 1.6.23 setDescriptionIdempI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setDescriptionIdempI msg = do mr <- getMessageRender setDescriptionIdemp $ mr msg -- | Add OpenGraph type meta tag to the head of the page -- -- See all available OG types here: https://ogp.me/#types -- -- @since 1.6.18 setOGType :: MonadWidget m => Text -> m () setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|] -- | Add OpenGraph image meta tag to the head of the page -- -- Best practices: -- -- * Use custom images for shareable pages, e.g., homepage, articles, etc. -- * Use your logo or any other branded image for the rest of your pages. -- * Use images with a 1.91:1 ratio and minimum recommended dimensions of -- 1200x630 for optimal clarity across all devices. -- -- Source: https://ahrefs.com/blog/open-graph-meta-tags/ -- -- @since 1.6.18 setOGImage :: MonadWidget m => Text -> m () setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|] -- | 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 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 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 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 mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings whamletFile :: FilePath -> Q Exp whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp whamletFileWithSettings = NP.hamletFileWithSettings rules asWidgetT :: WidgetT site m () -> WidgetT site m () asWidgetT = id rules :: Q NP.HamletRules rules = do ah <- [|asWidgetT . toWidget|] let helper qg f = do x <- newName "urender" e <- f $ VarE x let e' = LamE [VarP x] e g <- qg bind <- [|(>>=)|] return $ InfixE (Just g) bind (Just e') let ur f = do let env = NP.Env (Just $ helper [|getUrlRenderParams|]) (Just $ helper [|fmap (toHtml .) getMessageRender|]) f env return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) => HtmlUrlI18n message (Route (HandlerSite m)) -> m Html ihamletToRepHtml = ihamletToHtml {-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-} -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- -- Since 1.2.1 ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) => HtmlUrlI18n message (Route (HandlerSite m)) -> m Html ihamletToHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender return $ ih (toHtml . mrender) urender tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () tell = liftWidget . tellWidget toUnique :: x -> UniqueList x toUnique = UniqueList . (:) handlerToWidget :: HandlerFor site a -> WidgetFor site a handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler ���������yesod-core-1.6.24.5/src/Yesod/Core/Internal.hs������������������������������������������������������0000644�0000000�0000000�00000000436�14371110614�017061� 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) import Yesod.Core.Internal.TH as X (mkYesodGeneral) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Types.hs���������������������������������������������������������0000644�0000000�0000000�00000054574�14371110614�016425� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Yesod.Core.Types where import Data.Aeson (ToJSON) import qualified Data.ByteString.Builder as BB import Control.Arrow (first) import Control.Exception (Exception) import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.CaseInsensitive (CI) import Data.Conduit (Flush, ConduitT) import Data.IORef (IORef, modifyIORef') import Data.Map (Map, unionWith) import qualified Data.Map as Map import Data.Monoid (Endo (..), Last (..)) import Data.Semigroup (Semigroup(..)) import Data.Serialize (Serialize (..), putByteString) import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TBuilder import Data.Time (UTCTime) import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H import Network.Wai (FilePart, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr) import Network.Wai.Logger (DateCacheGetter) import Text.Blaze.Html (Html, toHtml) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) import Yesod.Core.Internal.Util (getTime, putTime) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..)) import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) import UnliftIO (MonadUnliftIO (..), SomeException) -- Sessions type SessionMap = Map Text ByteString type SaveSession = SessionMap -- ^ The session contents after running the handler -> IO [Header] newtype SessionBackend = SessionBackend { sbLoadSession :: W.Request -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session } data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap deriving (Show, Read) instance Serialize SessionCookie where put (SessionCookie a b c) = do either putTime putByteString a put b put (map (first T.unpack) $ Map.toList c) get = do a <- getTime b <- get c <- map (first T.pack) <$> get return $ SessionCookie (Left a) b (Map.fromList c) data ClientSessionDateCache = ClientSessionDateCache { csdcNow :: !UTCTime , csdcExpires :: !UTCTime , csdcExpiresSerialized :: !ByteString } deriving (Eq, Show) -- | The parsed request information. This type augments the standard WAI -- 'W.Request' with additional information. data YesodRequest = YesodRequest { reqGetParams :: ![(Text, Text)] -- ^ Same as 'W.queryString', but decoded to @Text@. , reqCookies :: ![(Text, Text)] , reqWaiRequest :: !W.Request , reqLangs :: ![Text] -- ^ Languages which the client supports. This is an ordered list by preference. , reqToken :: !(Maybe Text) -- ^ A random, session-specific token used to prevent CSRF attacks. , reqSession :: !SessionMap -- ^ Initial session sent from the client. -- -- Since 1.2.0 , reqAccept :: ![ContentType] -- ^ An ordered list of the accepted content types. -- -- Since 1.2.0 } -- | An augmented WAI 'W.Response'. This can either be a standard @Response@, -- or a higher-level data structure which Yesod will turn into a @Response@. data YesodResponse = YRWai !W.Response | YRWaiApp !W.Application | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(Text, Text)] , [(Text, FileInfo)] ) data FileInfo = FileInfo { fileName :: !Text , fileContentType :: !Text , fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ()) , fileMove :: !(FilePath -> IO ()) } data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath) | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ())) -- | How to determine the root of the application for constructing URLs. -- -- Note that future versions of Yesod may add new constructors without bumping -- the major version number. As a result, you should /not/ pattern match on -- @Approot@ values. data Approot master = ApprootRelative -- ^ No application root. | ApprootStatic !Text | ApprootMaster !(master -> Text) | ApprootRequest !(master -> W.Request -> Text) type ResolvedApproot = Text data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text deriving (Eq, Show, Read) data ScriptLoadPosition master = BottomOfBody | BottomOfHeadBlocking | BottomOfHeadAsync !(BottomOfHeadAsync master) type BottomOfHeadAsync master = [Text] -- ^ urls to load asynchronously -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head> type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized. -- -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } data RunHandlerEnv child site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route child)) , rheRouteToMaster :: !(Route child -> Route site) , rheSite :: !site , rheChild :: !child , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheOnError :: !(ErrorResponse -> YesodApp) -- ^ How to respond when an error is thrown internally. -- -- Since 1.2.0 , rheMaxExpires :: !Text -- | @since 1.6.24.0 -- catch function for rendering 500 pages on exceptions. -- by default this is catch from unliftio (rethrows all async exceptions). , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a) } data HandlerData child site = HandlerData { handlerRequest :: !YesodRequest , handlerEnv :: !(RunHandlerEnv child site) , handlerState :: !(IORef GHState) , handlerResource :: !InternalState } data YesodRunnerEnv site = YesodRunnerEnv { yreLogger :: !Logger , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) , yreGen :: !(IO Int) -- ^ Generate a random number uniformly distributed in the full -- range of 'Int'. -- -- Note: Before 1.6.20, the default value generates pseudo-random -- number in an unspecified range. The range size may not be a power -- of 2. Since 1.6.20, the default value uses a secure entropy source -- and generates in the full range of 'Int'. , yreGetMaxExpires :: !(IO Text) } data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv { ysreParentRunner :: !(ParentRunner parent) , ysreGetSub :: !(parent -> sub) , ysreToParentRoute :: !(Route sub -> Route parent) , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner? } type ParentRunner parent = HandlerFor parent TypedContent -> YesodRunnerEnv parent -> Maybe (Route parent) -> W.Application -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. newtype HandlerFor site a = HandlerFor { unHandlerFor :: HandlerData site site -> IO a } deriving Functor data GHState = GHState { ghsSession :: !SessionMap , ghsRBC :: !(Maybe RequestBodyContents) , ghsIdent :: !Int , ghsCache :: !TypeMap , ghsCacheBy :: !KeyedTypeMap , ghsHeaders :: !(Endo [Header]) } -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as -- the 'HandlerFor' monad and template haskell code should hide it away. type YesodApp = YesodRequest -> ResourceT IO YesodResponse -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for -- better error messages. newtype WidgetFor site a = WidgetFor { unWidgetFor :: WidgetData site -> IO a } deriving Functor data WidgetData site = WidgetData { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site))) , wdHandler :: {-# UNPACK #-} !(HandlerData site site) } instance a ~ () => Monoid (WidgetFor site a) where mempty = return () #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance a ~ () => Semigroup (WidgetFor site a) where x <> y = x >> y -- | A 'String' can be trivially promoted to a widget. -- -- For example, in a yesod-scaffold site you could use: -- -- @getHomeR = do defaultLayout "Widget text"@ instance a ~ () => IsString (WidgetFor site a) where fromString = toWidget . toHtml . T.pack where toWidget x = tellWidget mempty { gwdBody = Body (const x) } tellWidget :: GWData (Route site) -> WidgetFor site () tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d) type RY master = Route master -> [(Text, Text)] -> Text -- | Newtype wrapper allowing injection of arbitrary content into CSS. -- -- Usage: -- -- > toWidget $ CssBuilder "p { color: red }" -- -- Since: 1.1.3 newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent { pageTitle :: !Html , pageDescription :: !(Maybe Text) , pageHead :: !(HtmlUrl url) , pageBody :: !(HtmlUrl url) } data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ()) | ContentFile !FilePath !(Maybe FilePart) | ContentDontEvaluate !Content data TypedContent = TypedContent !ContentType !Content type RepHtml = Html {-# DEPRECATED RepHtml "Please use Html instead" #-} newtype RepJson = RepJson Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content type ContentType = ByteString -- FIXME Text? -- | Wrapper around types so that Handlers can return a domain type, even when -- the data will eventually be encoded as JSON. -- Example usage in a type signature: -- -- > postSignupR :: Handler (JSONResponse CreateUserResponse) -- -- And in the implementation: -- -- > return $ JSONResponse $ CreateUserResponse userId -- -- @since 1.6.14 data JSONResponse a where JSONResponse :: ToJSON a => a -> JSONResponse a -- | Prevents a response body from being fully evaluated before sending the -- request. -- -- Since 1.1.0 newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } -- | Responses to indicate some form of an error occurred. data ErrorResponse = NotFound -- ^ The requested resource was not found. -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value. -- HTTP status: 404. | InternalError !Text -- ^ Some sort of unexpected exception. -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take. -- HTTP status: 500. | InvalidArgs ![Text] -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body. -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@. -- HTTP status: 400. | NotAuthenticated -- ^ Indicates the user is not logged in. -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'. -- HTTP code: 401. | PermissionDenied !Text -- ^ Indicates the user doesn't have permission to access the requested resource. -- This is thrown when 'isAuthorized' returns 'Unauthorized'. -- HTTP code: 403. | BadMethod !H.Method -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.) -- HTTP code: 405. deriving (Show, Eq, Generic) instance NFData ErrorResponse ----- header stuff -- | Headers to be added to a 'Result'. data Header = AddCookie !SetCookie | DeleteCookie !ByteString !ByteString -- ^ name and path | Header !(CI ByteString) !ByteString -- ^ key and value deriving (Eq, Show) -- FIXME In the next major version bump, let's just add strictness annotations -- to Header (and probably everywhere else). We can also add strictness -- annotations to SetCookie in the cookie package. instance NFData Header where rnf (AddCookie x) = rnf x rnf (DeleteCookie x y) = x `seq` y `seq` () rnf (Header x y) = x `seq` y `seq` () data Location url = Local !url | Remote !Text deriving (Show, Eq) -- | A diff list that does not directly enforce uniqueness. -- When creating a widget Yesod will use nub to make it unique. newtype UniqueList x = UniqueList ([x] -> [x]) data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] } deriving (Show, Eq) data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } newtype Description = Description { unDescription :: Text } newtype Head url = Head (HtmlUrl url) deriving Monoid instance Semigroup (Head url) where (<>) = mappend newtype Body url = Body (HtmlUrl url) deriving Monoid instance Semigroup (Body url) where (<>) = mappend type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder data GWData a = GWData { gwdBody :: !(Body a) , gwdTitle :: !(Last Title) , gwdDescription :: !(Last Description) , 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 mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup (GWData a) where GWData a1 a2 a3 a4 a5 a6 a7 a8 <> GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData (mappend a1 b1) (mappend a2 b2) (mappend a3 b3) (mappend a4 b4) (mappend a5 b5) (unionWith mappend a6 b6) (mappend a7 b7) (mappend a8 b8) data HandlerContents = HCContent !H.Status !TypedContent | HCError !ErrorResponse | HCSendFile !ContentType !FilePath !(Maybe FilePart) | HCRedirect !H.Status !Text | HCCreated !Text | HCWai !W.Response | HCWaiApp !W.Application instance Show HandlerContents where show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t) show (HCError e) = "HCError " ++ show e show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp) show (HCRedirect s t) = "HCRedirect " ++ show (s, t) show (HCCreated t) = "HCCreated " ++ show t show (HCWai _) = "HCWai" show (HCWaiApp _) = "HCWaiApp" instance Exception HandlerContents -- Instances for WidgetFor instance Applicative (WidgetFor site) where pure = WidgetFor . const . pure (<*>) = ap instance Monad (WidgetFor site) where return = pure WidgetFor x >>= f = WidgetFor $ \wd -> do a <- x wd unWidgetFor (f a) wd instance MonadIO (WidgetFor site) where liftIO = WidgetFor . const -- | @since 1.6.7 instance PrimMonad (WidgetFor site) where type PrimState (WidgetFor site) = PrimState IO primitive = liftIO . primitive -- | @since 1.4.38 instance MonadUnliftIO (WidgetFor site) where {-# INLINE withRunInIO #-} withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x instance MonadReader (WidgetData site) (WidgetFor site) where ask = WidgetFor return local f (WidgetFor g) = WidgetFor $ g . f instance MonadThrow (WidgetFor site) where throwM = liftIO . throwM instance MonadResource (WidgetFor site) where liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler instance MonadLogger (WidgetFor site) where monadLoggerLog a b c d = WidgetFor $ \wd -> rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d) instance MonadLoggerIO (WidgetFor site) where askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler -- Instances for HandlerFor instance Applicative (HandlerFor site) where pure = HandlerFor . const . return (<*>) = ap instance Monad (HandlerFor site) where return = pure HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r instance MonadIO (HandlerFor site) where liftIO = HandlerFor . const -- | @since 1.6.7 instance PrimMonad (HandlerFor site) where type PrimState (HandlerFor site) = PrimState IO primitive = liftIO . primitive instance MonadReader (HandlerData site site) (HandlerFor site) where ask = HandlerFor return local f (HandlerFor g) = HandlerFor $ g . f -- | @since 1.4.38 instance MonadUnliftIO (HandlerFor site) where {-# INLINE withRunInIO #-} withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x instance MonadThrow (HandlerFor site) where throwM = liftIO . throwM instance MonadResource (HandlerFor site) where liftResourceT f = HandlerFor $ runInternalState f . handlerResource instance MonadLogger (HandlerFor site) where monadLoggerLog a b c d = HandlerFor $ \hd -> rheLog (handlerEnv hd) a b c (toLogStr d) instance MonadLoggerIO (HandlerFor site) where askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd)) instance Monoid (UniqueList x) where mempty = UniqueList id #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup (UniqueList x) where UniqueList x <> UniqueList y = UniqueList $ x . y instance IsString Content where fromString = flip ContentBuilder Nothing . BB.stringUtf8 instance RenderRoute WaiSubsite where data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] deriving (Show, Eq, Read, Ord) renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y instance RenderRoute WaiSubsiteWithAuth where data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)] deriving (Show, Eq, Read, Ord) renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs) instance ParseRoute WaiSubsiteWithAuth where parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y data Logger = Logger { loggerSet :: !LoggerSet , loggerDate :: !DateCacheGetter } loggerPutStr :: Logger -> LogStr -> IO () loggerPutStr (Logger ls _) = pushLogStr ls -- | A handler monad for subsite -- -- @since 1.6.0 newtype SubHandlerFor sub master a = SubHandlerFor { unSubHandlerFor :: HandlerData sub master -> IO a } deriving Functor instance Applicative (SubHandlerFor child master) where pure = SubHandlerFor . const . return (<*>) = ap instance Monad (SubHandlerFor child master) where return = pure SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r instance MonadIO (SubHandlerFor child master) where liftIO = SubHandlerFor . const instance MonadReader (HandlerData child master) (SubHandlerFor child master) where ask = SubHandlerFor return local f (SubHandlerFor g) = SubHandlerFor $ g . f -- | @since 1.4.38 instance MonadUnliftIO (SubHandlerFor child master) where {-# INLINE withRunInIO #-} withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x instance MonadThrow (SubHandlerFor child master) where throwM = liftIO . throwM instance MonadResource (SubHandlerFor child master) where liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource instance MonadLogger (SubHandlerFor child master) where monadLoggerLog a b c d = SubHandlerFor $ \sd -> rheLog (handlerEnv sd) a b c (toLogStr d) instance MonadLoggerIO (SubHandlerFor child master) where askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv ������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Unsafe.hs��������������������������������������������������������0000644�0000000�0000000�00000001506�14371110614�016525� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������-- | This is designed to be used as -- -- > import qualified Yesod.Core.Unsafe as Unsafe -- -- This serves as a reminder that the functions are unsafe to use in many situations. module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where import Yesod.Core.Internal.Run (runFakeHandler) import Yesod.Core.Types import Yesod.Core.Class.Yesod import Control.Monad.IO.Class (MonadIO) -- | designed to be used as -- -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger fakeHandlerGetLogger :: (Yesod site, MonadIO m) => (site -> Logger) -> site -> HandlerFor site a -> m a fakeHandlerGetLogger getLogger app f = runFakeHandler mempty getLogger app f >>= either (error . ("runFakeHandler issue: " `mappend`) . show) return ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH/Types.hs����������������������������������������������������0000644�0000000�0000000�00000004712�14371110614�017316� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveLift #-} -- | Warning! This module is considered internal and may have breaking changes module Yesod.Routes.TH.Types ( -- * Data types Resource (..) , ResourceTree (..) , Piece (..) , Dispatch (..) , CheckOverlap , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName , flatten ) where import Language.Haskell.TH.Syntax data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] deriving (Lift, Show, Functor) resourceTreePieces :: ResourceTree typ -> [Piece typ] resourceTreePieces (ResourceLeaf r) = resourcePieces r resourceTreePieces (ResourceParent _ _ x _) = x resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r resourceTreeName (ResourceParent x _ _ _) = x data Resource typ = Resource { resourceName :: String , resourcePieces :: [Piece typ] , resourceDispatch :: Dispatch typ , resourceAttrs :: [String] , resourceCheck :: CheckOverlap } deriving (Lift, Show, Functor) type CheckOverlap = Bool data Piece typ = Static String | Dynamic typ deriving (Lift, Show) instance Functor Piece where fmap _ (Static s) = Static s fmap f (Dynamic t) = Dynamic (f t) data Dispatch typ = Methods { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end , methodsMethods :: [String] -- ^ supported request methods } | Subsite { subsiteType :: typ , subsiteFunc :: String } deriving (Lift, Show) instance Functor Dispatch where fmap f (Methods a b) = Methods (fmap f a) b fmap f (Subsite a b) = Subsite (f a) b resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing data FlatResource a = FlatResource { frParentPieces :: [(String, [Piece a])] , frName :: String , frPieces :: [Piece a] , frDispatch :: Dispatch a , frCheck :: Bool } deriving (Show) flatten :: [ResourceTree a] -> [FlatResource a] flatten = concatMap (go id True) where go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] go front check' (ResourceParent name check pieces children) = concatMap (go (front . ((name, pieces):)) (check && check')) children ������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/Session.hs����������������������������������������������0000644�0000000�0000000�00000004543�14371110614�020507� 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.Monad (guard) import Yesod.Core.Types import Yesod.Core.Internal.Util import Control.AutoUpdate encodeClientSession :: CS.Key -> CS.IV -> ClientSessionDateCache -- ^ expire time -> ByteString -- ^ remote host -> SessionMap -- ^ session -> ByteString -- ^ cookie value encodeClientSession key iv date rhost session' = CS.encrypt key iv $ encode $ SessionCookie expires rhost session' where expires = Right (csdcExpiresSerialized date) decodeClientSession :: CS.Key -> ClientSessionDateCache -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value -> Maybe SessionMap decodeClientSession key date rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie (Left expire) rhost' session' <- either (const Nothing) Just $ decode decrypted guard $ expire > csdcNow date guard $ rhost' == rhost return session' ---------------------------------------------------------------------- -- Originally copied from Kazu's date-cache, but now using mkAutoUpdate. -- -- The cached date is updated every 10s, we don't need second -- resolution for session expiration times. -- -- The second component of the returned tuple used to be an action that -- killed the updater thread, but is now a no-op that's just there -- to preserve the type. clientSessionDateCacher :: NominalDiffTime -- ^ Inactive session validity. -> IO (IO ClientSessionDateCache, IO ()) clientSessionDateCacher validity = do getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings { updateAction = getUpdated , updateFreq = 10000000 -- 10s } return (getClientSessionDateCache, return ()) where getUpdated = do now <- getCurrentTime let expires = validity `addUTCTime` now expiresS = runPut (putTime expires) return $! ClientSessionDateCache now expires expiresS �������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/Request.hs����������������������������������������������0000644�0000000�0000000�00000016260�14371110614�020513� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings, CPP #-} module Yesod.Core.Internal.Request ( parseWaiRequest , RequestBodyContents , FileInfo , fileName , fileContentType , fileMove , mkFileInfoLBS , mkFileInfoFile , mkFileInfoSource , FileUpload (..) , tooLargeResponse , tokenKey , langKey , textQueryString -- The below are exported for testing. , randomString ) where import Data.String (IsString) import Control.Arrow (second) import qualified Network.Wai.Parse as NWP import qualified Network.Wai as W import Web.Cookie (parseCookiesText) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as LS8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText, Status (Status)) import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import Conduit import Data.Word (Word8, Word64) import Control.Exception (throwIO) import Control.Monad ((<=<), liftM) import Yesod.Core.Types import qualified Data.Map as Map import Data.IORef import qualified Data.Vector.Storable as V import Data.ByteString.Internal (ByteString (PS)) import qualified Data.Word8 as Word8 -- | Impose a limit on the size of the request body. limitRequestBody :: Word64 -> W.Request -> IO W.Request limitRequestBody maxLen req = do ref <- newIORef maxLen return req { W.requestBody = do bs <- W.requestBody req remaining <- readIORef ref let len = fromIntegral $ S8.length bs remaining' = remaining - len if remaining < len then throwIO $ HCWai $ tooLargeResponse maxLen len else do writeIORef ref remaining' return bs } tooLargeResponse :: Word64 -> Word64 -> W.Response tooLargeResponse maxLen bodyLen = W.responseLBS (Status 413 "Too Large") [("Content-Type", "text/plain")] (L.concat [ "Request body too large to be processed. The maximum size is " , (LS8.pack (show maxLen)) , " bytes; your request body was " , (LS8.pack (show bodyLen)) , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass." ]) parseWaiRequest :: W.Request -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size -> Either (IO YesodRequest) (IO Int -> IO YesodRequest) parseWaiRequest env session useToken mmaxBodySize = -- In most cases, we won't need to generate any random values. Therefore, -- we split our results: if we need a random generator, return a Right -- value, otherwise return a Left and avoid the relatively costly generator -- acquisition. case etoken of Left token -> Left $ mkRequest token Right mkToken -> Right $ mkRequest <=< mkToken where mkRequest token' = do envLimited <- maybe return limitRequestBody mmaxBodySize env return YesodRequest { reqGetParams = gets , reqCookies = cookies , reqWaiRequest = envLimited , reqLangs = langs'' , reqToken = token' , reqSession = if useToken then Map.delete tokenKey session else session , reqAccept = httpAccept env } gets = textQueryString env reqCookie = lookup "Cookie" $ W.requestHeaders env cookies = maybe [] parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k -- The language preferences are prioritized as follows: langs' = catMaybes [ lookup langKey gets -- Query _LANG , lookup langKey cookies -- Cookie _LANG , lookupText langKey session -- Session _LANG ] ++ langs -- Accept-Language(s) -- Github issue #195. We want to add an extra two-letter version of any -- language in the list. langs'' = addTwoLetters (id, Set.empty) langs' -- If sessions are disabled tokens should not be used (any -- tokenKey present in the session is ignored). If sessions -- are enabled and a session has no tokenKey a new one is -- generated. etoken | useToken = case Map.lookup tokenKey session of -- Already have a token, use it. Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs -- Don't have a token, get a random generator and make a new one. Nothing -> Right $ fmap Just . randomString 40 | otherwise = Left Nothing textQueryString :: W.Request -> [(Text, Text)] textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString -- | Get the list of accepted content types from the WAI Request\'s Accept -- header. -- -- Since 1.2.0 httpAccept :: W.Request -> [ContentType] httpAccept = NWP.parseHttpAccept . fromMaybe S8.empty . lookup "Accept" . W.requestHeaders addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] = filter (`Set.notMember` exist) $ toAdd [] addTwoLetters (toAdd, exist) (l:ls) = l : addTwoLetters (toAdd', exist') ls where (toAdd', exist') | T.length l > 2 = (toAdd . (T.take 2 l:), exist) | otherwise = (toAdd, Set.insert l exist) -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given -- random number generator. randomString :: Monad m => Int -> m Int -> m Text randomString len gen = liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar where asciiChar = let loop = do x <- gen let y = fromIntegral $ x `mod` 64 case () of () | y < 26 -> return $ y + Word8._A | y < 52 -> return $ y + Word8._a - 26 | y < 62 -> return $ y + Word8._0 - 52 | otherwise -> loop in loop fromByteVector :: V.Vector Word8 -> ByteString fromByteVector v = PS fptr offset idx where (fptr, offset, idx) = V.unsafeToForeignPtr v {-# INLINE fromByteVector #-} mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS name ct lbs = FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs) mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst) mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst) tokenKey :: IsString a => a tokenKey = "_TOKEN" langKey :: IsString a => a langKey = "_LANG" ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Class/Handler.hs�������������������������������������������������0000644�0000000�0000000�00000010573�14371437515�017746� 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 (..) , liftHandlerT , liftWidgetT ) where import Yesod.Core.Types import Control.Monad.Logger (MonadLogger) import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Class (lift) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Trans.Identity ( IdentityT) #if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.List ( ListT ) #endif import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Except ( ExceptT ) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) -- FIXME should we just use MonadReader instances instead? class (MonadResource m, MonadLogger m) => MonadHandler m where type HandlerSite m type SubHandlerSite m liftHandler :: HandlerFor (HandlerSite m) a -> m a liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a liftHandlerT = liftHandler {-# DEPRECATED liftHandlerT "Use liftHandler instead" #-} instance MonadHandler (HandlerFor site) where type HandlerSite (HandlerFor site) = site type SubHandlerSite (HandlerFor site) = site liftHandler = id {-# INLINE liftHandler #-} liftSubHandler (SubHandlerFor f) = HandlerFor f {-# INLINE liftSubHandler #-} instance MonadHandler (SubHandlerFor sub master) where type HandlerSite (SubHandlerFor sub master) = master type SubHandlerSite (SubHandlerFor sub master) = sub liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd { handlerEnv = let rhe = handlerEnv hd in rhe { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe) , rheRouteToMaster = id , rheChild = rheSite rhe } } {-# INLINE liftHandler #-} liftSubHandler = id {-# INLINE liftSubHandler #-} instance MonadHandler (WidgetFor site) where type HandlerSite (WidgetFor site) = site type SubHandlerSite (WidgetFor site) = site liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler {-# INLINE liftHandler #-} liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler {-# INLINE liftSubHandler #-} #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler GO(IdentityT) #if !MIN_VERSION_transformers(0,6,0) GO(ListT) #endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r) GO(StateT s) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) GO(Pipe l i o u) GO(ConduitM i o) #undef GO #undef GOX class MonadHandler m => MonadWidget m where liftWidget :: WidgetFor (HandlerSite m) a -> m a instance MonadWidget (WidgetFor site) where liftWidget = id {-# INLINE liftWidget #-} liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a liftWidgetT = liftWidget {-# DEPRECATED liftWidgetT "Use liftWidget instead" #-} #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget GO(IdentityT) #if !MIN_VERSION_transformers(0,6,0) GO(ListT) #endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r) GO(StateT s) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) GO(Pipe l i o u) GO(ConduitM i o) #undef GO #undef GOX �������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/Util.hs�������������������������������������������������0000644�0000000�0000000�00000003410�14371110614�017771� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} module Yesod.Core.Internal.Util ( putTime , getTime , formatW3 , formatRFC1123 , formatRFC822 , getCurrentMaxExpiresRFC1123 ) where import Data.Int (Int64) import Data.Serialize (Get, Put, Serialize (..)) import qualified Data.Text as T import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), DiffTime, UTCTime (..), formatTime, getCurrentTime, addUTCTime, defaultTimeLocale) putTime :: UTCTime -> Put putTime (UTCTime d t) = let d' = fromInteger $ toModifiedJulianDay d t' = fromIntegral $ fromEnum (t / diffTimeScale) in put (d' * posixDayLength_int64 + min posixDayLength_int64 t') getTime :: Get UTCTime getTime = do val <- get let (d, t) = val `divMod` posixDayLength_int64 d' = ModifiedJulianDay $! fromIntegral d t' = fromIntegral t d' `seq` t' `seq` return (UTCTime d' t') posixDayLength_int64 :: Int64 posixDayLength_int64 = 86400 diffTimeScale :: DiffTime diffTimeScale = 1e12 -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> T.Text formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> T.Text formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" -- | Format as per RFC 822. formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" {- | Get the time 365 days from now in RFC 1123 format. For use as an expiry date on a resource that never expires. See RFC 2616 section 14.21 for details. -} getCurrentMaxExpiresRFC1123 :: IO T.Text getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/Response.hs���������������������������������������������0000644�0000000�0000000�00000010773�14371110614�020664� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Yesod.Core.Internal.Response where import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import Data.CaseInsensitive (CI) import Network.Wai import Control.Monad (mplus) import Control.Monad.Trans.Resource (runInternalState, InternalState) import Network.Wai.Internal import Web.Cookie (renderSetCookie) import Yesod.Core.Content import Yesod.Core.Types import qualified Network.HTTP.Types as H import qualified Data.Text as T import Control.Exception (SomeException, handle) import Data.ByteString.Builder (lazyByteString, toLazyByteString) import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8) import Conduit yarToResponse :: YesodResponse -> (SessionMap -> IO [Header]) -- ^ save session -> YesodRequest -> Request -> InternalState -> (Response -> IO ResponseReceived) -> IO ResponseReceived yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do extraHeaders <- do let nsToken = maybe newSess (\n -> Map.insert tokenKey (encodeUtf8 n) newSess) (reqToken yreq) sessionHeaders <- saveSession nsToken return $ ("Content-Type", ct) : map headerToPair sessionHeaders let finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders let go (ContentBuilder b mlen) = do let hs' = maybe finalHeaders finalHeaders' mlen sendResponse $ ResponseBuilder s hs' b go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p go (ContentSource body) = sendResponse $ responseStream s finalHeaders $ \sendChunk flush -> runConduit $ transPipe (`runInternalState` is) body .| mapM_C (\mchunk -> case mchunk of Flush -> flush Chunk builder -> sendChunk builder) go (ContentDontEvaluate c') = go c' go c where s | s' == defaultStatus = H.status200 | otherwise = s' -- | Indicates that the user provided no specific status code to be used, and -- therefore the default status code should be used. For normal responses, this -- would be a 200 response, whereas for error responses this would be an -- appropriate status code. -- -- For more information on motivation for this, see: -- -- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ -- -- Since 1.2.3.1 defaultStatus :: H.Status defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS" -- | Convert Header to a key/value pair. headerToPair :: Header -> (CI ByteString, ByteString) headerToPair (AddCookie sc) = ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc) headerToPair (DeleteCookie key path) = ( "Set-Cookie" , S.concat [ key , "=; path=" , path , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] ) headerToPair (Header key value) = (key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b len = L.length lbs mlen' = mlen `mplus` Just (fromIntegral len) len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen') where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show evaluateContent c = return (Right c) getStatus :: ErrorResponse -> H.Status getStatus NotFound = H.status404 getStatus (InternalError _) = H.status500 getStatus (InvalidArgs _) = H.status400 getStatus NotAuthenticated = H.status401 getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 �����yesod-core-1.6.24.5/src/Yesod/Core/Internal/Run.hs��������������������������������������������������0000644�0000000�0000000�00000036613�14371110614�017633� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Yesod.Core.Internal.Run ( toErrorHandler , errFromShow , basicRunHandler , handleError , handleContents , evalFallback , runHandler , safeEh , runFakeHandler , yesodRunner , yesodRender , resolveApproot ) where import qualified Control.Exception as EUnsafe import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BL import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import Data.Monoid (appEndo) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai import Network.Wai.Internal import System.Log.FastLogger (LogStr, toLogStr) import Yesod.Core.Content import Yesod.Core.Class.Yesod import Yesod.Core.Types import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) import Data.Proxy(Proxy(..)) -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse toErrorHandler e0 = handleAny errFromShow $ case fromException e0 of Just (HCError x) -> evaluate $!! x _ -> errFromShow e0 -- | Generate an @ErrorResponse@ based on the shown version of the exception errFromShow :: SomeException -> IO ErrorResponse errFromShow x = do text <- evaluate (T.pack $ show x) `catchAny` \_ -> return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception") return $ InternalError text -- | Do a basic run of a handler, getting some contents and the final -- @GHState@. The @GHState@ unfortunately may contain some impure -- exceptions, but all other synchronous exceptions will be caught and -- represented by the @HandlerContents@. basicRunHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents) basicRunHandler rhe handler yreq resState = do -- Create a mutable ref to hold the state. We use mutable refs so -- that the updates will survive runtime exceptions. istate <- I.newIORef defState -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ contents' <- rheCatchHandlerExceptions rhe (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ return (HCContent defaultStatus tc)) (\e -> case fromException e of Just e' -> return e' Nothing -> HCError <$> toErrorHandler e) -- Get the raw state and return state <- I.readIORef istate return (state, contents') where defState = GHState { ghsSession = reqSession yreq , ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty , ghsCacheBy = mempty , ghsHeaders = mempty } hd istate = HandlerData { handlerRequest = yreq , handlerEnv = rhe , handlerState = istate , handlerResource = resState } -- | Convert an @ErrorResponse@ into a @YesodResponse@ handleError :: RunHandlerEnv sub site -> YesodRequest -> InternalState -> Map.Map Text S8.ByteString -> [Header] -> ErrorResponse -> IO YesodResponse handleError rhe yreq resState finalSession headers e0 = do -- Find any evil hidden impure exceptions e <- (evaluate $!! e0) `catchAny` errFromShow -- Generate a response, leveraging the updated session and -- response headers flip runInternalState resState $ do yar <- rheOnError rhe e yreq { reqSession = finalSession } case yar of YRPlain status' hs ct c sess -> let hs' = headers ++ hs status | status' == defaultStatus = getStatus e | otherwise = status' in return $ YRPlain status hs' ct c sess YRWai _ -> return yar YRWaiApp _ -> return yar -- | Convert a @HandlerContents@ into a @YesodResponse@ handleContents :: (ErrorResponse -> IO YesodResponse) -> Map.Map Text S8.ByteString -> [Header] -> HandlerContents -> IO YesodResponse handleContents handleError' finalSession headers contents = case contents of HCContent status (TypedContent ct c) -> do -- Check for impure exceptions hiding in the contents ec' <- evaluateContent c case ec' of Left e -> handleError' e Right c' -> return $ YRPlain status headers ct c' finalSession HCError e -> handleError' e HCRedirect status loc -> do let disable_caching x = Header "Cache-Control" "no-cache, must-revalidate" : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" : x hs = (if status /= H.movedPermanently301 then disable_caching else id) $ Header "Location" (encodeUtf8 loc) : headers return $ YRPlain status hs typePlain emptyContent finalSession HCSendFile ct fp p -> return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession HCCreated loc -> return $ YRPlain H.status201 (Header "Location" (encodeUtf8 loc) : headers) typePlain emptyContent finalSession HCWai r -> return $ YRWai r HCWaiApp a -> return $ YRWaiApp a -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value. -- -- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) => (forall a. IO a -> (SomeException -> IO a) -> IO a) -> HandlerContents -> w -> IO (w, HandlerContents) evalFallback catcher contents val = catcher (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) -- | Function used internally by Yesod in the process of converting a -- 'HandlerFor' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do -- Get the raw state and original contents (state, contents0) <- basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state) (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) []) contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse handleContents (handleError rhe yreq resState finalSession headers) finalSession headers contents3 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse -> YesodApp safeEh log' er req = do liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError $ toLogStr $ "Error handler errored out: " ++ show er return $ YRPlain H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString)) (reqSession req) -- | Run a 'HandlerFor' 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 'HandlerFor' -- 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 -- @HandlerFor@. The only useful information the @HandlerFor@ 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 -- @HandlerFor@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the -- @HandlerFor@'s return value. runFakeHandler :: forall site m a . (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site -> HandlerFor site a -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") maxExpires <- getCurrentMaxExpiresRFC1123 let handler' = liftIO . I.writeIORef ret . Right =<< handler let yapp = runHandler RunHandlerEnv { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing , rheRouteToMaster = id , rheChild = site , rheSite = site , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires , rheCatchHandlerExceptions = catchHandlerExceptions site } handler' errHandler err req = do liftIO $ I.writeIORef ret (Left err) return $ YRPlain H.status500 [] typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req) fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = "" , requestHeaderHost = Nothing , requestHeaders = [] , isSecure = False , remoteHost = error "runFakeHandler-remoteHost" , pathInfo = ["runFakeHandler", "pathInfo"] , queryString = [] , requestBody = return mempty , vault = mempty , requestBodyLength = KnownLength 0 , requestHeaderRange = Nothing , requestHeaderReferer = Nothing , requestHeaderUserAgent = Nothing } fakeRequest = YesodRequest { reqGetParams = [] , reqCookies = [] , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) , reqAccept = [] , reqSession = fakeSessionMap } _ <- runResourceT $ yapp fakeRequest I.readIORef ret yesodRunner :: forall res site . (ToTypedContent res, Yesod site) => HandlerFor site res -> YesodRunnerEnv site -> Maybe (Route site) -> Application yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do mmaxLen <- maximumContentLengthIO yreSite route case (mmaxLen, requestBodyLength req) of (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len) _ -> do let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend maxExpires <- yreGetMaxExpires let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let yreq = case mkYesodReq of Left yreq' -> yreq' Right needGen -> needGen yreGen let ra = resolveApproot yreSite req let log' = messageLoggerSource yreSite yreLogger -- We set up two environments: the first one has a "safe" error handler -- which will never throw an exception. The second one uses the -- user-provided errorHandler function. If that errorHandler function -- errors out, it will use the safeEh below to recover. rheSafe = RunHandlerEnv { rheRender = yesodRender yreSite ra , rheRoute = route , rheRouteToMaster = id , rheChild = yreSite , rheSite = yreSite , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires , rheCatchHandlerExceptions = catchHandlerExceptions yreSite } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler } yesodWithInternalState yreSite route $ \is -> do yreq' <- yreq yar <- runInternalState (runHandler rhe handler yreq') is yarToResponse yar saveSession yreq' req is sendResponse where mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' yesodRender :: Yesod y => y -> ResolvedApproot -> Route y -> [(Text, Text)] -- ^ url query string -> Text yesodRender y ar url params = decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $ fromMaybe (joinPath y ar ps $ params ++ params') (urlParamRenderOverride y url params) where (ps, params') = renderRoute url resolveApproot :: Yesod master => master -> Request -> ResolvedApproot resolveApproot master req = case approot of ApprootRelative -> "" ApprootStatic t -> t ApprootMaster f -> f master ApprootRequest f -> f master req ���������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/TH.hs���������������������������������������������������0000644�0000000�0000000�00000023406�14453667122�017412� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} module Yesod.Core.Internal.TH where import Prelude hiding (exp) import Yesod.Core.Handler import Language.Haskell.TH hiding (cxt, instanceD) import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.List (foldl') import Control.Monad (replicateM, void) import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH import Yesod.Routes.Parse import Yesod.Core.Content (ToTypedContent (..)) import Yesod.Core.Types import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter. -- Use 'parseRoutes' to create the 'Resource's. -- -- Contexts and type variables in the name of the datatype are parsed. -- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@. mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-} -- | Similar to 'mkYesod', except contexts and type variables are not parsed. -- Instead, they are explicitly provided. -- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@. mkYesodWith :: [[String]] -- ^ list of contexts -> String -- ^ name of the argument datatype -> [String] -- ^ list of type variables -> [ResourceTree String] -> Q [Dec] mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec] mkYesodData name resS = fst <$> mkYesodWithParser name False return resS mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS -- | Parses contexts and type arguments out of name before generating TH. mkYesodWithParser :: String -- ^ foundation type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodWithParser name isSub f resS = do let (name', rest, cxt) = case parse parseName "" name of Left err -> error $ show err Right a -> a mkYesodGeneral cxt name' rest isSub f resS where parseName = do cxt <- option [] parseContext name' <- parseWord args <- many parseWord spaces eof return ( name', args, cxt) parseWord = do spaces many1 alphaNum parseContext = try $ do cxts <- parseParen parseContexts spaces _ <- string "=>" return cxts parseParen p = do spaces _ <- char '(' r <- p spaces _ <- char ')' return r parseContexts = sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodWithParser name False return -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? masterTypeSyns vs site = [ TySynD (mkName "Handler") (fmap plainTV vs) $ ConT ''HandlerFor `AppT` site , TySynD (mkName "Widget") (fmap plainTV vs) $ ConT ''WidgetFor `AppT` site `AppT` ConT ''() ] mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type -> [String] -- ^ arguments for the type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral appCxt' namestr mtys isSub f resS = do let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest ) appCxt' mname <- lookupTypeName namestr arity <- case mname of Just name -> do info <- reify name return $ case info of TyConI dec -> case dec of DataD _ _ vs _ _ _ -> length vs NewtypeD _ _ vs _ _ _ -> length vs TySynD _ vs _ -> length vs _ -> 0 _ -> 0 _ -> return 0 let name = mkName namestr -- Generate as many variable names as the arity indicates vns <- replicateM (arity - length mtys) $ newName "t" -- types that you apply to get a concrete site name let argtypes = fmap nameToType mtys ++ fmap VarT vns -- typevars that should appear in synonym head let argvars = (fmap mkName . filter isTvar) mtys ++ vns -- Base type (site type with variables) let site = foldl' AppT (ConT name) argtypes res = map (fmap (parseType . dropBracket)) resS renderRouteDec <- mkRenderRouteInstance appCxt site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res dispatchDec <- mkDispatchInstance site appCxt f res parseRoute <- mkParseRouteInstance appCxt site res let rname = mkName $ "resources" ++ namestr eres <- lift resS let resourcesDec = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) , FunD rname [Clause [] (NormalB eres) []] ] let dataDec = concat [ [parseRoute] , renderRouteDec , [routeAttrsDec] , resourcesDec , if isSub then [] else masterTypeSyns argvars site ] return (dataDec, dispatchDec) mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b mkMDS f rh sd = MkDispatchSettings { mdsRunHandler = rh , mdsSubDispatcher = sd , mdsGetPathInfo = [|W.pathInfo|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsMethod = [|W.requestMethod|] , mds404 = [|void notFound|] , mds405 = [|void badMethod|] , mdsGetHandler = defaultGetHandler , mdsUnwrapper = f } -- | If the generation of @'YesodDispatch'@ instance require finer -- control of the types, contexts etc. using this combinator. You will -- hardly need this generality. However, in certain situations, like -- when writing library/plugin for yesod, this combinator becomes -- handy. mkDispatchInstance :: Type -- ^ The master site type -> Cxt -- ^ Context of the instance -> (Exp -> Q Exp) -- ^ Unwrap handler -> [ResourceTree c] -- ^ The resource -> DecsQ mkDispatchInstance master cxt f res = do clause' <- mkDispatchClause (mkMDS f [|yesodRunner|] [|\parentRunner getSub toParent env -> yesodSubDispatch YesodSubRunnerEnv { ysreParentRunner = parentRunner , ysreGetSub = getSub , ysreToParentRoute = toParent , ysreParentEnv = env } |]) res let thisDispatch = FunD 'yesodDispatch [clause'] return [instanceD cxt yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do clause' <- mkDispatchClause (mkMDS return [|subHelper|] [|subTopDispatch|]) 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) subTopDispatch :: (YesodSubDispatch sub master) => (forall content. ToTypedContent content => SubHandlerFor child master content -> YesodSubRunnerEnv child master -> Maybe (Route child) -> W.Application ) -> (mid -> sub) -> (Route sub -> Route mid) -> YesodSubRunnerEnv mid master -> W.Application subTopDispatch _ getSub toParent env = yesodSubDispatch (YesodSubRunnerEnv { ysreParentRunner = ysreParentRunner env , ysreGetSub = getSub . ysreGetSub env , ysreToParentRoute = ysreToParentRoute env . toParent , ysreParentEnv = ysreParentEnv env }) instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Internal/LiteApp.hs����������������������������������������������0000644�0000000�0000000�00000005124�14371110614�020416� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-} module Yesod.Core.Internal.LiteApp where #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Yesod.Routes.Class import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Types import Yesod.Core.Content import Data.Text (Text) import Web.PathPieces import Network.Wai import Yesod.Core.Handler import Yesod.Core.Internal.Run import Network.HTTP.Types (Method) import Data.Maybe (fromMaybe) import Control.Applicative ((<|>)) import Control.Monad.Trans.Writer newtype LiteApp = LiteApp { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent) } instance Yesod LiteApp instance YesodDispatch LiteApp where yesodDispatch yre req = yesodRunner (fromMaybe notFound $ f (requestMethod req) (pathInfo req)) yre (Just $ LiteAppRoute $ pathInfo req) req where LiteApp f = yreSite yre instance RenderRoute LiteApp where data Route LiteApp = LiteAppRoute [Text] deriving (Show, Eq, Read, Ord) renderRoute (LiteAppRoute x) = (x, []) instance ParseRoute LiteApp where parseRoute (x, _) = Just $ LiteAppRoute x instance Semigroup LiteApp where LiteApp x <> LiteApp y = LiteApp $ \m ps -> x m ps <|> y m ps instance Monoid LiteApp where mempty = LiteApp $ \_ _ -> Nothing #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif type LiteHandler = HandlerFor LiteApp type LiteWidget = WidgetFor LiteApp liteApp :: Writer LiteApp () -> LiteApp liteApp = execWriter dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp () dispatchTo handler = tell $ LiteApp $ \_ ps -> if null ps then Just $ fmap toTypedContent handler else Nothing onMethod :: Method -> Writer LiteApp () -> Writer LiteApp () onMethod method f = tell $ LiteApp $ \m ps -> if method == m then unLiteApp (liteApp f) m ps else Nothing onStatic :: Text -> Writer LiteApp () -> Writer LiteApp () onStatic p0 f = tell $ LiteApp $ \m ps0 -> case ps0 of p:ps | p == p0 -> unLiteApp (liteApp f) m ps _ -> Nothing withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp () withDynamic f = tell $ LiteApp $ \m ps0 -> case ps0 of p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps _ -> Nothing withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp () withDynamicMulti f = tell $ LiteApp $ \m ps -> case fromPathMultiPiece ps of Nothing -> Nothing Just v -> unLiteApp (liteApp $ f v) m [] ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Class/Yesod.hs���������������������������������������������������0000644�0000000�0000000�00000113074�14371110614�017440� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Yesod.Core.Class.Yesod where import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class import Data.ByteString.Builder (Builder) import Data.Text.Encoding (encodeUtf8Builder) import Control.Arrow ((***), second) import Control.Exception (bracket) import Control.Monad (forM, when, void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource, logErrorS) import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Aeson (object, (.=)) import Data.List (foldl', nub) import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TEE import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Word (Word64) import Language.Haskell.TH.Syntax (Loc (..)) import Network.HTTP.Types (encodePath) import qualified Network.Wai as W import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import Network.Wai.Logger (ZonedDate, clockDateCacher) import System.Log.FastLogger import Text.Blaze (customAttribute, textTag, toValue, (!), preEscapedToMarkup) import qualified Text.Blaze.Html5 as TBH import Text.Hamlet import Text.Julius import qualified Web.ClientSession as CS import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax, sameSiteStrict, SameSiteOption, defaultSetCookie) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget import Data.CaseInsensitive (CI) import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef import UnliftIO (SomeException, catch, MonadUnliftIO) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute site => Yesod site where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- -- Default value: 'guessApproot'. If you know your application root -- statically, it will be more efficient and more reliable to instead use -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute -- URLs, you can use 'ApprootRelative' instead. -- -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'. approot :: Approot site approot = guessApproot -- | @since 1.6.24.0 -- allows the user to specify how exceptions are cought. -- by default all async exceptions are thrown and synchronous -- exceptions render a 500 page. -- To catch all exceptions (even async) to render a 500 page, -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware -- this may have negative effects with functions like 'timeout'. catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a catchHandlerExceptions _ = catch -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. errorHandler :: ErrorResponse -> HandlerFor site TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. defaultLayout :: WidgetFor site () -> HandlerFor site Html defaultLayout w = do p <- widgetToPageContent w msgs <- getMessages withUrlRenderer [hamlet| $newline never $doctype 5 <html> <head> <title>#{pageTitle p} $maybe description <- pageDescription p <meta name="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs <p class="message #{status}">#{msg} ^{pageBody p} |] -- | Override the rendering function for a particular URL and query string -- parameters. One use case for this is to offload static hosting to a -- different domain name to avoid sending cookies. -- -- For backward compatibility default implementation is in terms of -- 'urlRenderOverride', probably ineffective -- -- Since 1.4.23 urlParamRenderOverride :: site -> Route site -> [(T.Text, T.Text)] -- ^ query string -> Maybe Builder urlParamRenderOverride _ _ _ = Nothing -- | Determine if a request is authorized or not. -- -- Return 'Authorized' if the request is authorized, -- 'Unauthorized' a message if unauthorized. -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route site -> Bool -- ^ is this a write request? -> HandlerFor site AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default, -- this assumes you are following RESTful principles, and determines this -- from request method. In particular, all except the following request -- methods are considered write: GET HEAD OPTIONS TRACE. -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'. isWriteRequest :: Route site -> HandlerFor site Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] -- | The default route for authentication. -- -- Used in particular by 'isAuthorized', but library users can do whatever -- they want with it. authRoute :: site -> Maybe (Route site) authRoute _ = Nothing -- | A function used to clean up path segments. It returns 'Right' with a -- clean path or 'Left' with a new set of pieces the user should be -- redirected to. The default implementation enforces: -- -- * No double slashes -- -- * There is no trailing slash. -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. cleanPath :: site -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . T.null) s dropDash t | T.all (== '-') t = T.drop 1 t | otherwise = t -- | Builds an absolute URL by concatenating the application root with the -- pieces of a path and a query string, if any. -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. joinPath :: site -> T.Text -- ^ application root -> [T.Text] -- ^ path pieces -> [(T.Text, T.Text)] -- ^ query string -> Builder joinPath _ ar pieces' qs' = encodeUtf8Builder ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x addDash t | T.all (== '-') t = T.cons '-' t | otherwise = t -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and -- JavaScript content in an external file; the "Yesod.Widget" module uses -- this feature. -- -- The return value is 'Nothing' if no storing was performed; this is the -- default implementation. A 'Just' 'Left' gives the absolute URL of the -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is -- necessary when you are serving the content outside the context of a -- Yesod application, such as via memcached. addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Maximum allowed length of the request body, in bytes. -- This method may be ignored if 'maximumContentLengthIO' is overridden. -- -- If @Nothing@, no maximum is applied. -- -- Default: 2 megabytes. maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64 maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes -- | Maximum allowed length of the request body, in bytes. This is similar -- to 'maximumContentLength', but the result lives in @IO@. This allows -- you to dynamically change the maximum file size based on some external -- source like a database or an @IORef@. -- -- The default implementation uses 'maximumContentLength'. Future version of yesod will -- remove 'maximumContentLength' and use this method exclusively. -- -- @since 1.6.13 maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64) maximumContentLengthIO a b = pure $ maximumContentLength a b -- | Creates a @Logger@ to use for log messages. -- -- Note that a common technique (endorsed by the scaffolding) is to create -- a @Logger@ value and place it in your foundation datatype, and have this -- method return that already created value. That way, you can use that -- same @Logger@ for printing messages during app initialization. -- -- Default: the 'defaultMakeLogger' function. makeLogger :: site -> IO Logger makeLogger _ = defaultMakeLogger -- | Send a message to the @Logger@ provided by @getLogger@. -- -- Default: the 'defaultMessageLoggerSource' function, using -- 'shouldLogIO' to check whether we should log. messageLoggerSource :: site -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site -- | Where to Load sripts from. We recommend the default value, -- 'BottomOfBody'. jsLoader :: site -> ScriptLoadPosition site jsLoader _ = BottomOfBody -- | Default attributes to put on the JavaScript <script> tag -- generated for julius files jsAttributes :: site -> [(Text, Text)] jsAttributes _ = [] -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code -- -- This is useful if you need to add a randomised nonce value to the script -- tag generated by @widgetFile@. If this function is overridden then -- @jsAttributes@ is ignored. -- -- @since 1.6.16 jsAttributesHandler :: HandlerFor site [(Text, Text)] jsAttributesHandler = jsAttributes <$> getYesod -- | Create a session backend. Returning 'Nothing' disables -- sessions. If you'd like to change the way that the session -- cookies are created, take a look at -- 'customizeSessionCookies'. -- -- Default: Uses clientsession with a 2 hour timeout. makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile -- | How to store uploaded files. -- -- Default: When the request body is greater than 50kb, store in a temp -- file. For chunked request bodies, store in a temp file. Otherwise, store -- in memory. fileUpload :: site -> W.RequestBodyLength -> FileUpload fileUpload _ (W.KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd -- | Should we log the given log source/level combination. -- -- Default: the 'defaultShouldLogIO' function. -- -- Since 1.2.4 shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool shouldLogIO _ = defaultShouldLogIO -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- -- Default: the 'defaultYesodMiddleware' function. -- -- Since: 1.1.6 yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res yesodMiddleware = defaultYesodMiddleware -- | How to allocate an @InternalState@ for each request. -- -- The default implementation is almost always what you want. However, if -- you know that you are never taking advantage of the @MonadResource@ -- instance in your handler functions, setting this to a dummy -- implementation can provide a small optimization. Only do this if you -- really know what you're doing, otherwise you can turn safe code into a -- runtime error! -- -- Since 1.4.2 yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a yesodWithInternalState _ _ = bracket createInternalState closeInternalState {-# INLINE yesodWithInternalState #-} -- | Convert a title and HTML snippet into a 'Widget'. Used -- primarily for wrapping up error messages for better display. -- -- @since 1.4.30 defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site () defaultMessageWidget title body = do setTitle title toWidget [hamlet| <h1>#{title} ^{body} |] -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write. -- -- Since 1.4.10 defaultMakeLogger :: IO Logger defaultMakeLogger = do loggerSet' <- newStdoutLoggerSet defaultBufSize (getter, _) <- clockDateCacher return $! Logger loggerSet' getter -- | Default implementation of 'messageLoggerSource'. Checks if the -- message should be logged using the provided function, and if so, -- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO' -- as the provided function. -- -- Since 1.4.10 defaultMessageLoggerSource :: (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should -- log this -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () defaultMessageLoggerSource ckLoggable logger loc source level msg = do loggable <- ckLoggable source level when loggable $ formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger -- | Default implementation of 'shouldLog'. Logs everything at or -- above 'LevelInfo'. -- -- Since 1.4.10 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool defaultShouldLogIO _ level = return $ level >= LevelInfo -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and -- performs authorization checks. -- -- Since 1.2.0 defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language" addHeader "X-XSS-Protection" "1; mode=block" authorizationCheck handler -- | Defends against session hijacking by setting the secure bit on session -- cookies so that browsers will not transmit them over http. With this -- setting on, it follows that the server will regard requests made over -- http as sessionless, because the session cookie will not be included in -- the request. Use this as part of a total security measure which also -- includes disabling HTTP traffic to the site or issuing redirects from -- HTTP urls, and composing 'sslOnlyMiddleware' with the site's -- 'yesodMiddleware'. -- -- Since 1.4.7 sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) sslOnlySessions = (fmap . fmap) secureSessionCookies where setSecureBit cookie = cookie { setCookieSecure = True } secureSessionCookies = customizeSessionCookies setSecureBit -- | Helps defend against CSRF attacks by setting the SameSite attribute on -- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site -- requests, and with cross-site top-level navigations. -- -- This option is liable to change in future versions of Yesod as the spec evolves. -- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>. -- -- @since 1.4.23 laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) laxSameSiteSessions = sameSiteSession sameSiteLax -- | Helps defend against CSRF attacks by setting the SameSite attribute on -- session cookies to Strict. With the Strict setting, the cookie will only be -- sent with same-site requests. -- -- This option is liable to change in future versions of Yesod as the spec evolves. -- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>. -- -- @since 1.4.23 strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) strictSameSiteSessions = sameSiteSession sameSiteStrict sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) sameSiteSession s = (fmap . fmap) secureSessionCookies where sameSite cookie = cookie { setCookieSameSite = Just s } secureSessionCookies = customizeSessionCookies sameSite -- | Apply a Strict-Transport-Security header with the specified timeout to -- all responses so that browsers will rewrite all http links to https -- until the timeout expires. For security, the max-age of the STS header -- should always equal or exceed the client sessions timeout. This defends -- against SSL-stripping man-in-the-middle attacks. It is only effective if -- a secure connection has already been made; Strict-Transport-Security -- headers are ignored over HTTP. -- -- Since 1.4.7 sslOnlyMiddleware :: Int -- ^ minutes -> HandlerFor site res -> HandlerFor site res sslOnlyMiddleware timeout handler = do addHeader "Strict-Transport-Security" $ T.pack $ concat [ "max-age=" , show $ timeout * 60 , "; includeSubDomains" ] handler -- | Check if a given request is authorized via 'isAuthorized' and -- 'isWriteRequest'. -- -- Since 1.2.0 authorizationCheck :: Yesod site => HandlerFor site () authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl where checkUrl url = do isWrite <- isWriteRequest url ar <- isAuthorized url isWrite case ar of Authorized -> return () AuthenticationRequired -> do master <- getYesod case authRoute master of Nothing -> void notAuthenticated Just url' -> void $ selectRep $ do provideRepType typeHtml $ do setUltDestCurrent void $ redirect url' provideRepType typeJson $ void notAuthenticated Unauthorized s' -> permissionDenied s' -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- -- Since 1.4.14 defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultCsrfCheckMiddleware handler = csrfCheckMiddleware handler (getCurrentRoute >>= maybe (return False) isWriteRequest) defaultCsrfHeaderName defaultCsrfParamName -- | Looks up the CSRF token from the request headers or POST parameters. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14 csrfCheckMiddleware :: HandlerFor site res -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from. -> HandlerFor site res csrfCheckMiddleware handler shouldCheckFn headerName paramName = do shouldCheck <- shouldCheckFn when shouldCheck (checkCsrfHeaderOrParam headerName paramName) handler -- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'. -- -- The cookie's path is set to @/@, making it valid for your whole website. -- -- Since 1.4.14 defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. -- -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- -- Since 1.4.14 csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. -- -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- You can chain this middleware together with other middleware like so: -- -- @ -- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware' -- @ -- -- or: -- -- @ -- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app -- @ -- -- Since 1.4.14 defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware -- | Convert a widget to a 'PageContent'. widgetToPageContent :: Yesod site => WidgetFor site () -> HandlerFor site (PageContent (Route site)) widgetToPageContent w = do jsAttrs <- jsAttributesHandler HandlerFor $ \hd -> do master <- unHandlerFor getYesod hd ref <- newIORef mempty unWidgetFor w WidgetData { wdRef = ref , wdHandler = hd } GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref let title = maybe mempty unTitle mTitle description = unDescription <$> mDescription scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' flip unHandlerFor hd $ do render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p css <- forM (Map.toList style) $ \(mmedia, content) -> do let rendered = toLazyText $ content render x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered return (mmedia, case x of Nothing -> Left $ preEscapedToMarkup rendered Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc regularScriptLoad = [hamlet| $newline never $forall s <- scripts ^{mkScriptTag s} $maybe j <- jscript $maybe s <- jsLoc <script src="#{s}" *{jsAttrs}> $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 description headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body where renderLoc' render' (Local url) = render' url [] renderLoc' _ (Remote s) = s addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) mkScriptTag (Script loc attrs) render' = foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () mkLinkTag (Stylesheet loc attrs) render' = foldl' addAttr TBH.link ( ("rel", "stylesheet") : ("href", renderLoc' render' loc) : attrs ) runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|] provideRep $ return $ object ["message" .= ("Not Found" :: Text)] provideRep $ return ("Not Found" :: Text) -- For API requests. -- For a user with a browser, -- if you specify an authRoute the user will be redirected there and -- this page will not be shown. defaultErrorHandler NotAuthenticated = selectRep $ do provideRep $ defaultLayout $ defaultMessageWidget "Not logged in" [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|] provideRep $ do -- 401 *MUST* include a WWW-Authenticate header -- however, there is no standard to indicate a redirection -- -- change this to Basic or Digest if you allow those forms of authentications addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\"" -- The client will just use the authentication_url in the JSON site <- getYesod rend <- getUrlRender let apair u = ["authentication_url" .= rend u] content = maybe [] apair (authRoute site) return $ object $ ("message" .= ("Not logged in"::Text)):content provideRep $ return ("Not logged in" :: Text) defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ defaultMessageWidget "Permission Denied" [hamlet|<p>#{msg}|] provideRep $ return $ object ["message" .= ("Permission Denied. " <> msg)] provideRep $ return $ "Permission Denied. " <> msg defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ defaultMessageWidget "Invalid Arguments" [hamlet| <ul> $forall msg <- ia <li>#{msg} |] provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia] provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia) defaultErrorHandler (InternalError e) = do $logErrorS "yesod-core" e selectRep $ do provideRep $ defaultLayout $ defaultMessageWidget "Internal Server Error" [hamlet|<pre>#{e}|] provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e] provideRep $ return $ "Internal Server Error: " <> e defaultErrorHandler (BadMethod m) = selectRep $ do provideRep $ defaultLayout $ defaultMessageWidget "Method Not Supported" [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|] provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m] provideRep $ return $ "Bad Method " <> TE.decodeUtf8With TEE.lenientDecode m asyncHelper :: (url -> [x] -> Text) -> [Script url] -> Maybe (JavascriptUrl url) -> Maybe Text -> (Maybe (HtmlUrl url), [Text]) asyncHelper render scripts jscript jsLoc = (mcomplete, scripts'') where scripts' = map goScript scripts scripts'' = case jsLoc of Just s -> scripts' ++ [s] Nothing -> scripts' goScript (Script (Local url) _) = render url [] goScript (Script (Remote s) _) = s mcomplete = case jsLoc of Just{} -> Nothing Nothing -> case jscript of Nothing -> Nothing Just j -> Just $ jelper j -- | Default formatting for log messages. When you use -- the template haskell logging functions for to log with information -- about the source location, that information will be appended to -- the end of the log. When you use the non-TH logging functions, -- like 'logDebugN', this function does not include source -- information. This currently works by checking to see if the -- package name is the string \"\<unknown\>\". This is a hack, -- but it removes some of the visual clutter from non-TH logs. -- -- Since 1.4.10 formatLogMessage :: IO ZonedDate -> Loc -> LogSource -> LogLevel -> LogStr -- ^ message -> IO LogStr formatLogMessage getdate loc src level msg = do now <- getdate return $ mempty `mappend` toLogStr now `mappend` " [" `mappend` (case level of LevelOther t -> toLogStr t _ -> toLogStr $ drop 5 $ show level) `mappend` (if T.null src then mempty else "#" `mappend` toLogStr src) `mappend` "] " `mappend` msg `mappend` sourceSuffix `mappend` "\n" where sourceSuffix = if loc_package loc == "<unknown>" then "" else mempty `mappend` " @(" `mappend` toLogStr (fileLocationToString loc) `mappend` ")" -- | Customize the cookies used by the session backend. You may -- use this function on your definition of 'makeSessionBackend'. -- -- For example, you could set the cookie domain so that it -- would work across many subdomains: -- -- @ -- makeSessionBackend site = -- (fmap . fmap) (customizeSessionCookies addDomain) ... -- where -- addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" } -- @ -- -- Default: Do not customize anything ('id'). customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend) customizeSessionCookies customizeCookie backend = backend' where customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie) customizeHeader other = other customizeSaveSession = (fmap . fmap . fmap) customizeHeader backend' = backend { sbLoadSession = \req -> second customizeSaveSession `fmap` sbLoadSession backend req } defaultClientSessionBackend :: Int -- ^ minutes -> FilePath -- ^ key file -> IO SessionBackend defaultClientSessionBackend minutes fp = do key <- CS.getKey fp (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes) return $ clientSessionBackend key getCachedDate -- | Create a @SessionBackend@ which reads the session key from the named -- environment variable. -- -- This can be useful if: -- -- 1. You can't rely on a persistent file system (e.g. Heroku) -- 2. Your application is open source (e.g. you can't commit the key) -- -- By keeping a consistent value in the environment variable, your users will -- have consistent sessions without relying on the file system. -- -- Note: A suitable value should only be obtained in one of two ways: -- -- 1. Run this code without the variable set, a value will be generated and -- printed on @/dev/stdout/@ -- 2. Use @clientsession-generate@ -- -- Since 1.4.5 envClientSessionBackend :: Int -- ^ minutes -> String -- ^ environment variable name -> IO SessionBackend envClientSessionBackend minutes name = do key <- CS.getKeyEnv name (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes return $ clientSessionBackend key getCachedDate minToSec :: (Integral a, Num b) => a -> b minToSec minutes = fromIntegral (minutes * 60) jsToHtml :: Javascript -> Html jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b jelper :: JavascriptUrl url -> HtmlUrl url jelper = fmap jsToHtml left :: Either a b -> Maybe a left (Left x) = Just x left _ = Nothing right :: Either a b -> Maybe b right (Right x) = Just x right _ = Nothing clientSessionBackend :: CS.Key -- ^ The encryption key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> SessionBackend clientSessionBackend key getCachedDate = SessionBackend { sbLoadSession = loadClientSession key getCachedDate "_SESSION" } justSingleton :: a -> [Maybe a] -> a justSingleton d = just . catMaybes where just [s] = s just _ = d loadClientSession :: CS.Key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> S8.ByteString -- ^ session name -> W.Request -> IO (SessionMap, SaveSession) loadClientSession key getCachedDate sessionName req = load where load = do date <- getCachedDate return (sess date, save date) sess date = justSingleton Map.empty $ do raw <- [v | (k, v) <- W.requestHeaders req, k == "Cookie"] val <- [v | (k, v) <- parseCookies raw, k == sessionName] let host = "" -- fixme, properly lock sessions to client address return $ decodeClientSession key date host val save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV return [AddCookie defaultSetCookie { setCookieName = sessionName , setCookieValue = encodeClientSession key iv date host sess' , setCookiePath = Just "/" , setCookieExpires = Just (csdcExpires date) , setCookieDomain = Nothing , setCookieHttpOnly = True }] where host = "" -- fixme, properly lock sessions to client address -- taken from file-location package -- turn the TH Loc loaction information into a human readable string -- leaving out the loc_end parameter fileLocationToString :: Loc -> String fileLocationToString loc = concat [ loc_package loc , ':' : loc_module loc , ' ' : loc_filename loc , ':' : line loc , ':' : char loc ] where line = show . fst . loc_start char = show . snd . loc_start -- | Guess the approot based on request headers. For more information, see -- "Network.Wai.Middleware.Approot" -- -- In the case of headers being unavailable, it falls back to 'ApprootRelative' -- -- Since 1.4.16 guessApproot :: Approot site guessApproot = guessApprootOr ApprootRelative -- | Guess the approot based on request headers, with fall back to the -- specified 'AppRoot'. -- -- Since 1.4.16 guessApprootOr :: Approot site -> Approot site guessApprootOr fallback = ApprootRequest $ \master req -> case W.requestHeaderHost req of Nothing -> getApprootText fallback master req Just host -> (if Network.Wai.Request.appearsSecure req then "https://" else "http://") `T.append` TE.decodeUtf8With TEE.lenientDecode host -- | Get the textual application root from an 'Approot' value. -- -- Since 1.4.17 getApprootText :: Approot site -> site -> W.Request -> Text getApprootText ar site req = case ar of ApprootRelative -> "" ApprootStatic t -> t ApprootMaster f -> f site ApprootRequest f -> f site req ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Class/Dispatch.hs������������������������������������������������0000644�0000000�0000000�00000003616�14371110614�020114� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Dispatch where import qualified Network.Wai as W import Yesod.Core.Types import Yesod.Core.Content (ToTypedContent (..)) import Yesod.Core.Handler (sendWaiApplication) import Yesod.Core.Class.Yesod -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application class YesodSubDispatch sub master where yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application instance YesodSubDispatch WaiSubsite master where yesodSubDispatch YesodSubRunnerEnv {..} = app where WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv instance YesodSubDispatch WaiSubsiteWithAuth master where yesodSubDispatch YesodSubRunnerEnv {..} req = ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req where route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) [] WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv handlert = sendWaiApplication set subHelper :: ToTypedContent content => SubHandlerFor child master content -> YesodSubRunnerEnv child master -> Maybe (Route child) -> W.Application subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute = ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute) where handler = fmap toTypedContent $ HandlerFor $ \hd -> let rhe = handlerEnv hd rhe' = rhe { rheRoute = mroute , rheChild = ysreGetSub $ yreSite ysreParentEnv , rheRouteToMaster = ysreToParentRoute } in f hd { handlerEnv = rhe' } ������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/Class/Breadcrumbs.hs���������������������������������������������0000644�0000000�0000000�00000002502�14371110614�020577� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Breadcrumbs where import Yesod.Core.Handler import Yesod.Routes.Class import Data.Text (Text) -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). class YesodBreadcrumbs site where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page. breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of Nothing -> return ("Not found", []) Just y -> do (title, next) <- breadcrumb y z <- go [] next return (title, z) where go back Nothing = return back go back (Just this) | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this | otherwise = do (title, next) <- breadcrumb this go ((this, title) : back) next ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Core/TypeCache.hs�����������������������������������������������������0000644�0000000�0000000�00000010100�14371110614�017137� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������-- | a module for caching a monadic action based on its return type -- -- The cache is a HashMap where the key uses the TypeReP from Typeable. -- The value stored is toDyn from Dynamic to support arbitrary value types in the same Map. -- -- un-exported newtype wrappers should be used to maintain unique keys in the cache. -- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name. -- -- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy' module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where import Prelude hiding (lookup) import Data.Typeable (Typeable, TypeRep, typeOf) import Data.HashMap.Strict import Data.ByteString (ByteString) import Data.Dynamic (Dynamic, toDyn, fromDynamic) type TypeMap = HashMap TypeRep Dynamic type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic -- | avoid performing the same action multiple times. -- Values are stored by their TypeRep from Typeable. -- Therefore, you should use un-exported newtype wrappers for each cache. -- -- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth. -- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts. -- -- In Yesod, this is used for a request-local cache that is cleared at the end of every request. -- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals> -- -- Since 1.4.0 cached :: (Monad m, Typeable a) => TypeMap -> m a -- ^ cache the result of this action -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit cached cache action = case cacheGet cache of Just val -> return $ Right val Nothing -> do val <- action return $ Left (cacheSet val cache, val) -- | Retrieves a value from the cache -- -- @since 1.6.10 cacheGet :: Typeable a => TypeMap -> Maybe a cacheGet cache = res where res = lookup (typeOf $ fromJust res) cache >>= fromDynamic fromJust :: Maybe a -> a fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" -- | Sets a value in the cache -- -- @since 1.6.10 cacheSet :: (Typeable a) => a -> TypeMap -> TypeMap cacheSet v cache = insert (typeOf v) (toDyn v) cache -- | similar to 'cached'. -- 'cached' can only cache a single value per type. -- 'cachedBy' stores multiple values per type by indexing on a ByteString key -- -- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user -- 'cachedBy' is required if the action has parameters and can return multiple values per type. -- You can turn those parameters into a ByteString cache key. -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. -- -- Since 1.4.0 cachedBy :: (Monad m, Typeable a) => KeyedTypeMap -> ByteString -- ^ a cache key -> m a -- ^ cache the result of this action -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit cachedBy cache k action = case cacheByGet k cache of Just val -> return $ Right val Nothing -> do val <- action return $ Left (cacheBySet k val cache, val) -- | Retrieves a value from the keyed cache -- -- @since 1.6.10 cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a cacheByGet key c = res where res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic fromJust :: Maybe a -> a fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" -- | Sets a value in the keyed cache -- -- @since 1.6.10 cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH.hs����������������������������������������������������������0000644�0000000�0000000�00000000664�14371110614�016214� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������module Yesod.Routes.TH ( module Yesod.Routes.TH.Types -- * Functions , module Yesod.Routes.TH.RenderRoute , module Yesod.Routes.TH.ParseRoute , module Yesod.Routes.TH.RouteAttrs -- ** Dispatch , module Yesod.Routes.TH.Dispatch ) where import Yesod.Routes.TH.Types import Yesod.Routes.TH.RenderRoute import Yesod.Routes.TH.ParseRoute import Yesod.Routes.TH.RouteAttrs import Yesod.Routes.TH.Dispatch ����������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/Class.hs�������������������������������������������������������0000644�0000000�0000000�00000001746�14371110614�016750� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Routes.Class ( RenderRoute (..) , ParseRoute (..) , RouteAttrs (..) ) where import Data.Text (Text) import Data.Set (Set) class Eq (Route a) => RenderRoute a where -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument. data Route a renderRoute :: Route a -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. class RenderRoute a => ParseRoute a where parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. -> Maybe (Route a) class RenderRoute a => RouteAttrs a where routeAttrs :: Route a -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>. ��������������������������yesod-core-1.6.24.5/src/Yesod/Routes/Parse.hs�������������������������������������������������������0000644�0000000�0000000�00000024501�14371110614�016747� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter module Yesod.Routes.Parse ( parseRoutes , parseRoutesFile , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType , parseTypeTree , TypeTree (..) , dropBracket , nameToType , isTvar ) where import Language.Haskell.TH.Syntax import Data.Char (isUpper, isLower, isSpace) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames) import Data.List (foldl', isPrefixOf) import Data.Maybe (mapMaybe) import qualified Data.Set as Set -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the -- checking. See documentation site for details on syntax. parseRoutes :: QuasiQuoter parseRoutes = QuasiQuoter { quoteExp = x } where x s = do let res = resourcesFromString s case findOverlapNames res of [] -> lift res z -> error $ unlines $ "Overlapping routes: " : map show z -- | Same as 'parseRoutes', but uses an external file instead of quasiquotation. -- -- The recommended file extension is @.yesodroutes@. parseRoutesFile :: FilePath -> Q Exp parseRoutesFile = parseRoutesFileWith parseRoutes -- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation. -- -- The recommended file extension is @.yesodroutes@. parseRoutesFileNoCheck :: FilePath -> Q Exp parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp parseRoutesFileWith qq fp = do qAddDependentFile fp s <- qRunIO $ readUtf8File fp quoteExp qq s readUtf8File :: FilePath -> IO String readUtf8File fp = do h <- SIO.openFile fp SIO.ReadMode SIO.hSetEncoding h SIO.utf8_bom SIO.hGetContents h -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter { quoteExp = lift . resourcesFromString } -- | Converts a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input. resourcesFromString :: String -> [ResourceTree String] resourcesFromString = fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r') where parse _ [] = ([], []) parse indent (thisLine:otherLines) | length spaces < indent = ([], thisLine : otherLines) | otherwise = (this others, remainder) where parseAttr ('!':x) = Just x parseAttr _ = Nothing stripColonLast = go id where go _ [] = Nothing go front [x] | null x = Nothing | last x == ':' = Just $ front [init x] | otherwise = Nothing go front (x:xs) = go (front . (x:)) xs spaces = takeWhile (== ' ') thisLine (others, remainder) = parse indent otherLines' (this, otherLines') = case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of (pattern:rest0) | Just (constr:rest) <- stripColonLast rest0 , Just attrs <- mapM parseAttr rest -> let (children, otherLines'') = parse (length spaces + 1) otherLines children' = addAttrs attrs children (pieces, Nothing, check) = piecesFromStringCheck pattern in ((ResourceParent constr check pieces children' :), otherLines'') (pattern:constr:rest) -> let (pieces, mmulti, check) = piecesFromStringCheck pattern (attrs, rest') = takeAttrs rest disp = dispatchFromString rest' mmulti in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine -- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). splitSpaces :: String -> [String] splitSpaces "" = [] splitSpaces str = let (rest, piece) = parse $ dropWhile isSpace str in piece:(splitSpaces rest) where parse :: String -> ( String, String) parse ('{':s) = fmap ('{':) $ parseBracket s parse (c:s) | isSpace c = (s, []) parse (c:s) = fmap (c:) $ parse s parse "" = ("", "") parseBracket :: String -> ( String, String) parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str parseBracket ('}':s) = fmap ('}':) $ parse s parseBracket (c:s) = fmap (c:) $ parseBracket s parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) piecesFromStringCheck s0 = (pieces, mmulti, check) where (s1, check1) = stripBang s0 (pieces', mmulti') = piecesFromString $ drop1Slash s1 pieces = map snd pieces' mmulti = fmap snd mmulti' check = check1 && all fst pieces' && maybe True fst mmulti' stripBang ('!':rest) = (rest, False) stripBang x = (x, True) addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String] addAttrs attrs = map goTree where goTree (ResourceLeaf res) = ResourceLeaf (goRes res) goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) goRes res = res { resourceAttrs = noDupes ++ resourceAttrs res } where usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res used attr = case toPair attr of Nothing -> False Just (key, _) -> key `Set.member` usedKeys noDupes = filter (not . used) attrs toPair s = case break (== '=') s of (x, '=':y) -> Just (x, y) _ -> Nothing -- | Take attributes out of the list and put them in the first slot in the -- result tuple. takeAttrs :: [String] -> ([String], [String]) takeAttrs = go id id where go x y [] = (x [], y []) go x y (('!':attr):rest) = go (x . (attr:)) y rest go x y (z:rest) = go x (y . (z:)) rest dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti | null rest = Methods mmulti [] | all (all isUpper) rest = Methods mmulti rest dispatchFromString [subTyp, subFun] Nothing = Subsite subTyp subFun dispatchFromString [_, _] Just{} = error "Subsites cannot have a multipiece" dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) piecesFromString "" = ([], Nothing) piecesFromString x = case (this, rest) of (Left typ, ([], Nothing)) -> ([], Just typ) (Left _, _) -> error "Multipiece must be last piece" (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) where (y, z) = break (== '/') x this = pieceFromString y rest = piecesFromString $ drop 1 z parseType :: String -> Type parseType orig = maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig parseTypeTree :: String -> Maybe TypeTree parseTypeTree orig = toTypeTree pieces where pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig addDashes [] = [] addDashes (x:xs) = front $ addDashes xs where front rest | x `elem` "()[]" = '-' : x : '-' : rest | otherwise = x : rest splitOn c s = case y' of _:y -> x : splitOn c y [] -> [x] where (x, y') = break c s data TypeTree = TTTerm String | TTApp TypeTree TypeTree | TTList TypeTree deriving (Show, Eq) toTypeTree :: [String] -> Maybe TypeTree toTypeTree orig = do (x, []) <- gos orig return x where go [] = Nothing go ("(":xs) = do (x, rest) <- gos xs case rest of ")":rest' -> Just (x, rest') _ -> Nothing go ("[":xs) = do (x, rest) <- gos xs case rest of "]":rest' -> Just (TTList x, rest') _ -> Nothing go (x:xs) = Just (TTTerm x, xs) gos xs1 = do (t, xs2) <- go xs1 (ts, xs3) <- gos' id xs2 Just (foldl' TTApp t ts, xs3) gos' front [] = Just (front [], []) gos' front (x:xs) | x `elem` words ") ]" = Just (front [], x:xs) | otherwise = do (t, xs') <- go $ x:xs gos' (front . (t:)) xs' ttToType :: TypeTree -> Type ttToType (TTTerm s) = nameToType s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t nameToType :: String -> Type nameToType t = if isTvar t then VarT $ mkName t else ConT $ mkName t isTvar :: String -> Bool isTvar (h:_) = isLower h isTvar _ = False pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652 pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x) pieceFromString ('*':'!':x) = Left (False, x) pieceFromString ('+':'!':x) = Left (False, x) pieceFromString ('!':'*':x) = Left (False, x) pieceFromString ('!':'+':x) = Left (False, x) pieceFromString ('*':x) = Left (True, x) pieceFromString ('+':x) = Left (True, x) pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) dropBracket :: String -> String dropBracket str@('{':x) = case break (== '}') x of (s, "}") -> s _ -> error $ "Unclosed bracket ('{'): " ++ str dropBracket x = x -- | If this line ends with a backslash, concatenate it together with the next line. -- -- @since 1.6.8 lineContinuations :: String -> [String] -> [String] lineContinuations this [] = [this] lineContinuations this below@(next:rest) = case unsnoc this of Just (this', '\\') -> (this'++next):rest _ -> this:below where unsnoc s = if null s then Nothing else Just (init s, last s) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/Overlap.hs�����������������������������������������������������0000644�0000000�0000000�00000005066�14371110614�017312� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������-- | Check for overlapping routes. module Yesod.Routes.Overlap ( findOverlapNames , Overlap (..) ) where import Yesod.Routes.TH.Types import Data.List (intercalate) data Flattened t = Flattened { fNames :: [String] , fPieces :: [Piece t] , fHasSuffix :: Bool , fCheck :: CheckOverlap } flatten :: ResourceTree t -> [Flattened t] flatten = go id id True where go names pieces check (ResourceLeaf r) = return Flattened { fNames = names [resourceName r] , fPieces = pieces (resourcePieces r) , fHasSuffix = hasSuffix $ ResourceLeaf r , fCheck = check && resourceCheck r } go names pieces check (ResourceParent newname check' newpieces children) = concatMap (go names' pieces' (check && check')) children where names' = names . (newname:) pieces' = pieces . (newpieces ++) data Overlap t = Overlap { overlapParents :: [String] -> [String] -- ^ parent resource trees , overlap1 :: ResourceTree t , overlap2 :: ResourceTree t } data OverlapF = OverlapF { _overlapF1 :: [String] , _overlapF2 :: [String] } overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool -- No pieces on either side, will overlap regardless of suffix overlaps [] [] _ _ = True -- No pieces on the left, will overlap if the left side has a suffix overlaps [] _ suffixX _ = suffixX -- Ditto for the right overlaps _ [] _ suffixY = suffixY -- Compare the actual pieces overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY = piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY piecesOverlap :: Piece t -> Piece t -> Bool -- Statics only match if they equal. Dynamics match with anything piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True findOverlapNames :: [ResourceTree t] -> [(String, String)] findOverlapNames = map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten where go (OverlapF x y) = (go' x, go' y) where go' = intercalate "/" findOverlapsF :: [Flattened t] -> [OverlapF] findOverlapsF [] = [] findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs findOverlapF :: Flattened t -> Flattened t -> [OverlapF] findOverlapF x y | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)] | otherwise = [] hasSuffix :: ResourceTree t -> Bool hasSuffix (ResourceLeaf r) = case resourceDispatch r of Subsite{} -> True Methods Just{} _ -> True Methods Nothing _ -> False hasSuffix ResourceParent{} = True ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH/Dispatch.hs�������������������������������������������������0000644�0000000�0000000�00000017732�14371110614�017757� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch ( MkDispatchSettings (..) , mkDispatchClause , defaultGetHandler ) where import Prelude hiding (exp) import Language.Haskell.TH.Syntax import Web.PathPieces import Data.Maybe (catMaybes) import Control.Monad (forM) import Data.List (foldl') import Control.Arrow (second) import System.Random (randomRIO) import Yesod.Routes.TH.Types import Data.Char (toLower) data MkDispatchSettings b site c = MkDispatchSettings { mdsRunHandler :: Q Exp , mdsSubDispatcher :: Q Exp , mdsGetPathInfo :: Q Exp , mdsSetPathInfo :: Q Exp , mdsMethod :: Q Exp , mds404 :: Q Exp , mds405 :: Q Exp , mdsGetHandler :: Maybe String -> String -> Q Exp , mdsUnwrapper :: Exp -> Q Exp } data SDC = SDC { clause404 :: Clause , extraParams :: [Exp] , extraCons :: [Exp] , envExp :: Exp , reqExp :: Exp } -- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on -- view patterns. -- -- Since 1.4.0 mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause mkDispatchClause MkDispatchSettings {..} resources = do suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) envName <- newName $ "env" ++ show suffix reqName <- newName $ "req" ++ show suffix helperName <- newName $ "helper" ++ show suffix let envE = VarE envName reqE = VarE reqName helperE = VarE helperName clause404' <- mkClause404 envE reqE getPathInfo <- mdsGetPathInfo let pathInfo = getPathInfo `AppE` reqE let sdc = SDC { clause404 = clause404' , extraParams = [] , extraCons = [] , envExp = envE , reqExp = reqE } clauses <- mapM (go sdc) resources return $ Clause [VarP envName, VarP reqName] (NormalB $ helperE `AppE` pathInfo) [FunD helperName $ clauses ++ [clause404']] where handlePiece :: Piece a -> Q (Pat, Maybe Exp) handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Dynamic _) = do x <- newName "dyn" let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]) return (pat, Just $ VarE x) handlePieces :: [Piece a] -> Q ([Pat], [Exp]) handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece mkCon :: String -> [Exp] -> Exp mkCon name = foldl' AppE (ConE $ mkName name) mkPathPat :: Pat -> [Pat] -> Pat mkPathPat final = foldr addPat final where addPat x y = conPCompat '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause go sdc (ResourceParent name _check pieces children) = do (pats, dyns) <- handlePieces pieces let sdc' = sdc { extraParams = extraParams sdc ++ dyns , extraCons = extraCons sdc ++ [mkCon name dyns] } childClauses <- mapM (go sdc') children restName <- newName "rest" let restE = VarE restName restP = VarP restName helperName <- newName $ "helper" ++ name let helperE = VarE helperName return $ Clause [mkPathPat restP pats] (NormalB $ helperE `AppE` restE) [FunD helperName $ childClauses ++ [clause404 sdc]] go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do (pats, dyns) <- handlePieces pieces (chooseMethod, finalPat) <- handleDispatch dispatch dyns return $ Clause [mkPathPat finalPat pats] (NormalB chooseMethod) [] where handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) handleDispatch dispatch' dyns = case dispatch' of Methods multi methods -> do (finalPat, mfinalE) <- case multi of Nothing -> return (conPCompat '[] [], Nothing) Just _ -> do multiName <- newName "multi" let pat = ViewP (VarE 'fromPathMultiPiece) (conPCompat 'Just [VarP multiName]) return (pat, Just $ VarE multiName) let dynsMulti = case mfinalE of Nothing -> dyns Just e -> dyns ++ [e] route' = foldl' AppE (ConE (mkName name)) dynsMulti route = foldr AppE route' extraCons jroute = ConE 'Just `AppE` route allDyns = extraParams ++ dynsMulti mkRunExp mmethod = do runHandlerE <- mdsRunHandler handlerE' <- mdsGetHandler mmethod name handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns return $ runHandlerE `AppE` handlerE `AppE` envExp `AppE` jroute `AppE` reqExp func <- case methods of [] -> mkRunExp Nothing _ -> do getMethod <- mdsMethod let methodE = getMethod `AppE` reqExp matches <- forM methods $ \method -> do exp <- mkRunExp (Just method) return $ Match (LitP $ StringL method) (NormalB exp) [] match405 <- do runHandlerE <- mdsRunHandler handlerE <- mds405 let exp = runHandlerE `AppE` handlerE `AppE` envExp `AppE` jroute `AppE` reqExp return $ Match WildP (NormalB exp) [] return $ CaseE methodE $ matches ++ [match405] return (func, finalPat) Subsite _ getSub -> do restPath <- newName "restPath" setPathInfoE <- mdsSetPathInfo subDispatcherE <- mdsSubDispatcher runHandlerE <- mdsRunHandler sub <- newName "sub" let allDyns = extraParams ++ dyns sroute <- newName "sroute" let sub2 = LamE [VarP sub] (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns) let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp route' = foldl' AppE (ConE (mkName name)) dyns route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons exp = subDispatcherE `AppE` runHandlerE `AppE` sub2 `AppE` route `AppE` envExp `AppE` reqExp' return (exp, VarP restPath) mkClause404 envE reqE = do handler <- mds404 runHandler <- mdsRunHandler let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE return $ Clause [WildP] (NormalB exp) [] defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s conPCompat :: Name -> [Pat] -> Pat conPCompat n pats = ConP n #if MIN_VERSION_template_haskell(2,18,0) [] #endif pats ��������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH/RenderRoute.hs����������������������������������������������0000644�0000000�0000000�00000015646�14371110614�020460� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell, CPP #-} module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRouteCons , mkRenderRouteClauses ) where import Yesod.Routes.TH.Types import Language.Haskell.TH (conT) import Language.Haskell.TH.Syntax import Data.Bits (xor) import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class -- | Generate the constructors of a route data type. mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec]) mkRouteCons rttypes = mconcat <$> mapM mkRouteCon rttypes where mkRouteCon (ResourceLeaf res) = return ([con], []) where con = NormalC (mkName $ resourceName res) $ map (\x -> (notStrict, x)) $ concat [singles, multi, sub] singles = concatMap toSingle $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] multi = maybeToList $ resourceMulti res sub = case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] mkRouteCon (ResourceParent name _check pieces children) = do (cons, decs) <- mkRouteCons children #if MIN_VERSION_template_haskell(2,12,0) dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq]) #else dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] #endif return ([con], dec : decs) where con = NormalC (mkName name) $ map (\x -> (notStrict, x)) $ singles ++ [ConT $ mkName name] singles = concatMap toSingle pieces toSingle Static{} = [] toSingle (Dynamic typ) = [typ] -- | Clauses for the 'renderRoute' method. mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses = mapM go where isDynamic Dynamic{} = True isDynamic _ = False go (ResourceParent name _check pieces children) = do let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns childRender <- newName "childRender" let rr = VarE childRender childClauses <- mkRenderRouteClauses children a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces' = foldr cons (VarE a) piecesSingle let body = LamE [TupP [VarP a, VarP b]] (TupE #if MIN_VERSION_template_haskell(2,16,0) $ map Just #endif [pieces', VarE b] ) `AppE` (rr `AppE` VarE child) return $ Clause [pat] (NormalB body) [FunD childRender childClauses] go (ResourceLeaf res) = do let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of Subsite{} -> return <$> newName "sub" _ -> return [] let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns piecesMulti <- case resourceMulti res of Nothing -> return $ ListE [] Just{} -> do tmp <- [|toPathMultiPiece|] return $ tmp `AppE` VarE (last dyns) body <- case sub of [x] -> do rr <- [|renderRoute|] a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces = foldr cons (VarE a) piecesSingle return $ LamE [TupP [VarP a, VarP b]] (TupE #if MIN_VERSION_template_haskell(2,16,0) $ map Just #endif [pieces, VarE b] ) `AppE` (rr `AppE` VarE x) _ -> do colon <- [|(:)|] let cons a b = InfixE (Just a) colon (Just b) return $ TupE #if MIN_VERSION_template_haskell(2,16,0) $ map Just #endif [foldr cons piecesMulti piecesSingle, ListE []] return $ Clause [pat] (NormalB body) [] mkPieces _ _ [] _ = [] mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120" -- | Generate the 'RenderRoute' instance. -- -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance cxt typ ress = do cls <- mkRenderRouteClauses ress (cons, decs) <- mkRouteCons ress #if MIN_VERSION_template_haskell(2,15,0) did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #elif MIN_VERSION_template_haskell(2,12,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #else did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #endif return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls ] : sds ++ decs where clazzes standalone = if standalone `xor` null cxt then clazzes' else [] clazzes' = [''Show, ''Eq, ''Read] notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing conPCompat :: Name -> [Pat] -> Pat conPCompat n pats = ConP n #if MIN_VERSION_template_haskell(2,18,0) [] #endif pats ������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH/ParseRoute.hs�����������������������������������������������0000644�0000000�0000000�00000003412�14371110614�020277� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.ParseRoute ( -- ** ParseRoute mkParseRouteInstance ) where import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax import Data.Text (Text) import Yesod.Routes.Class import Yesod.Routes.TH.Dispatch mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec mkParseRouteInstance cxt typ ress = do cls <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|\_ _ x _ -> x|] , mds404 = [|error "mds404"|] , mds405 = [|error "mds405"|] , mdsGetPathInfo = [|fst|] , mdsMethod = [|error "mdsMethod"|] , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] , mdsUnwrapper = return } (map removeMethods ress) helper <- newName "helper" fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] return $ instanceD cxt (ConT ''ParseRoute `AppT` typ) [ FunD 'parseRoute $ return $ Clause [] (NormalB $ fixer `AppE` VarE helper) [FunD helper [cls]] ] where -- We do this in order to ski the unnecessary method parsing removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res } fixDispatch (Methods x _) = Methods x [] fixDispatch x = x instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/src/Yesod/Routes/TH/RouteAttrs.hs�����������������������������������������������0000644�0000000�0000000�00000002651�14371110614�020326� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs ( mkRouteAttrsInstance ) where import Yesod.Routes.TH.Types import Yesod.Routes.Class import Language.Haskell.TH.Syntax import Data.Set (fromList) import Data.Text (pack) mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance cxt typ ress = do clauses <- mapM (goTree id) ress return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ) [ FunD 'routeAttrs $ concat clauses ] goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] goTree front (ResourceLeaf res) = return <$> goRes front res goTree front (ResourceParent name _check pieces trees) = concat <$> mapM (goTree front') trees where ignored = (replicate toIgnore WildP ++) . return toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False front' = front . ConP (mkName name) #if MIN_VERSION_template_haskell(2,18,0) [] #endif . ignored goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes front Resource {..} = return $ Clause [front $ RecP (mkName resourceName) []] (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) [] where toText s = VarE 'pack `AppE` LitE (StringL s) instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing ���������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/test.hs��������������������������������������������������������������������0000644�0000000�0000000�00000000141�14371110614�014472� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������import Test.Hspec import qualified YesodCoreTest main :: IO () main = hspec YesodCoreTest.specs �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest.hs�����������������������������������������������������������0000644�0000000�0000000�00000003524�14453667122�016273� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} module YesodCoreTest (specs) where import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Meta import YesodCoreTest.Links import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.SubSub import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import YesodCoreTest.ParameterizedSite import YesodCoreTest.Breadcrumb 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 -- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450 #if !WINDOWS import qualified YesodCoreTest.RawResponse as RawResponse #endif 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 qualified YesodCoreTest.Ssl as Ssl import qualified YesodCoreTest.Csrf as Csrf import Test.Hspec specs :: Spec specs = do headerTest cleanPathTest exceptionsTest widgetTest mediaTest linksTest noOverloadedTest subSubTest internalRequestTest errorHandlingTest cacheTest parameterizedSiteTest WaiSubsite.specs Redirect.specs JsLoader.specs RequestBodySize.specs Json.specs #if !WINDOWS RawResponse.specs #endif Streaming.specs Reps.specs Auth.specs LiteApp.specs Ssl.unsecSpec Ssl.sslOnlySpec Ssl.sameSiteSpec Csrf.csrfSpec breadcrumbTest metaTest ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/Auth.hs������������������������������������������������������0000644�0000000�0000000�00000004771�14371110614�017165� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} module YesodCoreTest.Auth ( specs , Widget , resourcesApp ) 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) import qualified Network.HTTP.Types as H 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")] , httpVersion = H.http11 } 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.6.24.5/test/YesodCoreTest/Cache.hs�����������������������������������������������������0000644�0000000�0000000�00000006646�14371110614�017272� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} module YesodCoreTest.Cache ( cacheTest , Widget , resourcesC ) where import Test.Hspec import Network.Wai import Network.Wai.Test import Yesod.Core import UnliftIO.IORef import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy.Char8 as L8 data C = C newtype V1 = V1 Int newtype V2 = V2 Int mkYesod "C" [parseRoutes| / RootR GET /key KeyR GET /nested NestedR GET /nested-key NestedKeyR GET |] instance Yesod C where errorHandler e = liftIO (print e) >> defaultErrorHandler e 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) cacheBySet "3" (V2 3) V2 v3a <- cacheByGet "3" >>= \x -> case x of Just y -> return y Nothing -> error "must be Just" V2 v3b <- cachedBy "3" $ (pure $ V2 4) return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b] getKeyR :: Handler RepPlain getKeyR = do ref <- newIORef 0 V1 v1a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) V1 v1b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) V2 v2a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) V2 v2b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) cacheBySet "4" (V2 4) V2 v4a <- cacheByGet "4" >>= \x -> case x of Just y -> return y Nothing -> error "must be Just" V2 v4b <- cachedBy "4" $ (pure $ V2 5) return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b] getNestedR :: Handler RepPlain getNestedR = getNested cached getNestedKeyR :: Handler RepPlain getNestedKeyR = getNested $ cachedBy "3" -- | Issue #1266 getNested :: (forall a. Typeable a => (Handler a -> Handler a)) -> Handler RepPlain getNested cacheMethod = do ref <- newIORef 0 let getV2 = atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) V1 _ <- cacheMethod $ do V2 val <- cacheMethod $ getV2 return $ V1 val V2 v2 <- cacheMethod $ getV2 return $ RepPlain $ toContent $ show v2 cacheTest :: Spec cacheTest = describe "Test.Cache" $ do it "cached" $ runner $ do res <- request defaultRequest assertStatus 200 res assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res it "cachedBy" $ runner $ do res <- request defaultRequest { pathInfo = ["key"] } assertStatus 200 res assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res it "nested cached" $ runner $ do res <- request defaultRequest { pathInfo = ["nested"] } assertStatus 200 res assertBody (L8.pack $ show (1 :: Int)) res it "nested cachedBy" $ runner $ do res <- request defaultRequest { pathInfo = ["nested-key"] } assertStatus 200 res assertBody (L8.pack $ show (1 :: Int)) res runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f ������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/CleanPath.hs�������������������������������������������������0000644�0000000�0000000�00000011524�14371110614�020115� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE CPP #-} module YesodCoreTest.CleanPath ( cleanPathTest , Widget , resourcesY ) 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 Data.Text.Encoding (encodeUtf8Builder) 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 f = f $ 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' = encodeUtf8Builder ar `Data.Monoid.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.6.24.5/test/YesodCoreTest/Header.hs����������������������������������������������������0000644�0000000�0000000�00000004104�14371110614�017442� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Header ( headerTest , Widget , resourcesApp ) where import Data.Text (Text) import Network.HTTP.Types (decodePathSegments) import Network.Wai import Network.Wai.Test import Test.Hspec import Yesod.Core data App = App mkYesod "App" [parseRoutes| /header1 Header1R GET /header2 Header2R GET /header3 Header3R GET |] instance Yesod App getHeader1R :: Handler RepPlain getHeader1R = do addHeader "hello" "world" return $ RepPlain $ toContent ("header test" :: Text) getHeader2R :: Handler RepPlain getHeader2R = do addHeader "hello" "world" replaceOrAddHeader "hello" "sibi" return $ RepPlain $ toContent ("header test" :: Text) getHeader3R :: Handler RepPlain getHeader3R = do addHeader "hello" "world" addHeader "michael" "snoyman" addHeader "yesod" "framework" replaceOrAddHeader "yesod" "book" return $ RepPlain $ toContent ("header test" :: Text) runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f addHeaderTest :: IO () addHeaderTest = runner $ do res <- request defaultRequest {pathInfo = decodePathSegments "/header1"} assertHeader "hello" "world" res multipleHeaderTest :: IO () multipleHeaderTest = runner $ do res <- request defaultRequest {pathInfo = decodePathSegments "/header2"} assertHeader "hello" "sibi" res header3Test :: IO () header3Test = do runner $ do res <- request defaultRequest {pathInfo = decodePathSegments "/header3"} assertHeader "hello" "world" res assertHeader "michael" "snoyman" res assertHeader "yesod" "book" res xssHeaderTest :: IO () xssHeaderTest = do runner $ do res <- request defaultRequest {pathInfo = decodePathSegments "/header1"} assertHeader "X-XSS-Protection" "1; mode=block" res headerTest :: Spec headerTest = describe "Test.Header" $ do it "addHeader" addHeaderTest it "multiple header" multipleHeaderTest it "persist headers" header3Test it "has X-XSS-Protection: 1; mode=block" xssHeaderTest ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/Csrf.hs������������������������������������������������������0000644�0000000�0000000�00000006720�14371110614�017155� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.Csrf (csrfSpec, Widget, resourcesApp) where import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import Web.Cookie import qualified Data.Map as Map import Data.ByteString.Lazy (fromStrict) import Data.Monoid ((<>)) data App = App mkYesod "App" [parseRoutes| / HomeR GET POST |] instance Yesod App where yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware getHomeR :: Handler Html getHomeR = defaultLayout [whamlet| <p> Welcome to my test application. |] postHomeR :: Handler Html postHomeR = defaultLayout [whamlet| <p> Welcome to my test application. |] runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f csrfSpec :: Spec csrfSpec = describe "A Yesod application with the defaultCsrfMiddleware" $ do it "serves a includes a cookie in a GET request" $ runner $ do res <- request defaultRequest assertStatus 200 res assertClientCookieExists "Should have an XSRF-TOKEN cookie" defaultCsrfCookieName it "uses / as the path of the cookie" $ runner $ do -- https://github.com/yesodweb/yesod/issues/1247 res <- request defaultRequest assertStatus 200 res cookiePath <- fmap setCookiePath requireCsrfCookie liftIO $ cookiePath `shouldBe` Just "/" it "200s write requests with the correct CSRF header, but no param" $ runner $ do getRes <- request defaultRequest assertStatus 200 getRes csrfValue <- fmap setCookieValue requireCsrfCookie postRes <- request (defaultRequest { requestMethod = "POST", requestHeaders = [(defaultCsrfHeaderName, csrfValue)] }) assertStatus 200 postRes it "200s write requests with the correct CSRF param, but no header" $ runner $ do getRes <- request defaultRequest assertStatus 200 getRes csrfValue <- fmap setCookieValue requireCsrfCookie let body = "_token=" <> csrfValue postRes <- srequest $ SRequest (defaultRequest { requestMethod = "POST", requestHeaders = [("Content-Type","application/x-www-form-urlencoded")] }) (fromStrict body) assertStatus 200 postRes it "403s write requests without the CSRF header" $ runner $ do res <- request (defaultRequest { requestMethod = "POST" }) assertStatus 403 res it "403s write requests with the wrong CSRF header" $ runner $ do getRes <- request defaultRequest assertStatus 200 getRes csrfValue <- fmap setCookieValue requireCsrfCookie res <- request (defaultRequest { requestMethod = "POST", requestHeaders = [(defaultCsrfHeaderName, csrfValue <> "foo")] }) assertStatus 403 res it "403s write requests with the wrong CSRF param" $ runner $ do getRes <- request defaultRequest assertStatus 200 getRes csrfValue <- fmap setCookieValue requireCsrfCookie let body = "_token=" <> (csrfValue <> "foo") postRes <- srequest $ SRequest (defaultRequest { requestMethod = "POST", requestHeaders = [("Content-Type","application/x-www-form-urlencoded")] }) (fromStrict body) assertStatus 403 postRes requireCsrfCookie :: Session SetCookie requireCsrfCookie = do cookies <- getClientCookies case Map.lookup defaultCsrfCookieName cookies of Just c -> return c Nothing -> error "Failed to lookup CSRF cookie" ������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/ErrorHandling.hs���������������������������������������������0000644�0000000�0000000�00000031207�14371110614�021014� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget , resourcesApp ) where import Data.Typeable(cast) import qualified System.Mem as Mem import qualified Control.Concurrent.Async as Async import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try, AsyncException(..)) import UnliftIO.Exception(finally) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString) import Data.Monoid (mconcat) import Data.Text (Text, pack) import Control.Monad (forM_) import qualified Network.Wai.Handler.Warp as Warp import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom import Control.Monad.Trans.State (StateT (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import qualified UnliftIO.Exception as E import System.Timeout(timeout) 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 /override-status OverrideStatusR GET /error/#Int ErrorR GET -- https://github.com/yesodweb/yesod/issues/658 /builder BuilderR GET /file-bad-len FileBadLenR GET /file-bad-name FileBadNameR GET /good-builder GoodBuilderR GET /auth-not-accepted AuthNotAcceptedR GET /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET /thread-killed ThreadKilledR GET /connection-closed-by-peer ConnectionClosedPeerR GET /sleep-sec SleepASecR GET |] overrideStatus :: Status overrideStatus = mkStatus 15 "OVERRIDE" instance Yesod App where errorHandler (InvalidArgs ["OVERRIDE"]) = sendResponseStatus overrideStatus ("OH HAI" :: String) errorHandler x = defaultErrorHandler x getHomeR :: Handler Html getHomeR = do $logDebug "Testing logging" defaultLayout $ toWidget [hamlet| $doctype 5 <html> <body> <form method=post action=@{NotFoundR}> <input type=submit value="Not found"> <form method=post action=@{FirstThingR}> <input type=submit value="Error is thrown first thing in handler"> <form method=post action=@{AfterRunRequestBodyR}> <input type=submit value="BUGGY: Error thrown after runRequestBody"> |] 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 getOverrideStatusR :: Handler () getOverrideStatusR = invalidArgs ["OVERRIDE"] getBuilderR :: Handler TypedContent getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing getFileBadLenR :: Handler TypedContent getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen") getFileBadNameR :: Handler TypedContent getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing goodBuilderContent :: Builder goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent -- this handler kills it's own thread getThreadKilledR :: Handler Html getThreadKilledR = do x <- liftIO Conc.myThreadId liftIO $ Async.withAsync (Conc.killThread x) Async.wait pure "unreachablle" getSleepASecR :: Handler Html getSleepASecR = do liftIO $ Conc.threadDelay 1000000 pure "slept a second" getConnectionClosedPeerR :: Handler Html getConnectionClosedPeerR = do x <- liftIO Conc.myThreadId liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait pure "unreachablle" getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined getErrorR 3 = deleteSession undefined getErrorR 4 = addHeader undefined "foo" getErrorR 5 = addHeader "foo" undefined getErrorR 6 = expiresAt undefined getErrorR 7 = setLanguage undefined getErrorR 8 = cacheSeconds undefined getErrorR 9 = setUltDest (undefined :: Text) getErrorR 10 = setMessage undefined getErrorR x = error $ "getErrorR: " ++ show x getAuthNotAcceptedR :: Handler TypedContent getAuthNotAcceptedR = notAuthenticated getAuthNotAdequateR :: Handler TypedContent getAuthNotAdequateR = permissionDenied "That doesn't belong to you. " postArgsNotValidR :: Handler TypedContent postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."] getOnlyPlainTextR :: Handler TypedContent getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text) 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 it "can override status code" caseOverrideStatus it "builder" caseBuilder it "file with bad len" caseFileBadLen it "file with bad name" caseFileBadName it "builder includes content-length" caseGoodBuilder forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i) it "accept DVI file, invalid args -> 400" caseDviInvalidArgs it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated it "accept CSS, permission denied -> 403" caseCssPermissionDenied it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows it "custom config rethrows an exception" caseCustomExceptionRethrows it "thread killed rethrow" caseThreadKilledRethrow it "can timeout a runner" canTimeoutARunner runner :: Session a -> IO a 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"] } case eres of Left (_ :: SomeException) -> return () Right x -> error $ "Expected an exception, got: " ++ show x caseOverrideStatus :: IO () caseOverrideStatus = runner $ do res <- request defaultRequest { pathInfo = ["override-status"] } assertStatus 15 res caseBuilder :: IO () caseBuilder = runner $ do res <- request defaultRequest { pathInfo = ["builder"] } assertStatus 500 res assertBodyContains "builder-3.14159" res caseFileBadLen :: IO () caseFileBadLen = runner $ do res <- request defaultRequest { pathInfo = ["file-bad-len"] } assertStatus 500 res assertBodyContains "filebadlen" res caseFileBadName :: IO () caseFileBadName = runner $ do res <- request defaultRequest { pathInfo = ["file-bad-name"] } assertStatus 500 res assertBodyContains "filebadname" res caseGoodBuilder :: IO () caseGoodBuilder = runner $ do res <- request defaultRequest { pathInfo = ["good-builder"] } assertStatus 200 res let lbs = toLazyByteString goodBuilderContent assertBody lbs res assertHeader "content-length" (S8.pack $ show $ L.length lbs) res caseError :: Int -> IO () caseError i = runner $ do res <- request defaultRequest { pathInfo = ["error", pack $ show i] } ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do liftIO $ print res E.throwIO (e :: E.SomeException) caseDviInvalidArgs :: IO () caseDviInvalidArgs = runner $ do res <- request defaultRequest { pathInfo = ["args-not-valid"] , requestMethod = "POST" , requestHeaders = ("accept", "application/x-dvi") : requestHeaders defaultRequest } assertStatus 400 res caseAudioNotAuthenticated :: IO () caseAudioNotAuthenticated = runner $ do res <- request defaultRequest { pathInfo = ["auth-not-accepted"] , requestHeaders = ("accept", "audio/mpeg") : requestHeaders defaultRequest } assertStatus 401 res caseCssPermissionDenied :: IO () caseCssPermissionDenied = runner $ do res <- request defaultRequest { pathInfo = ["auth-not-adequate"] , requestHeaders = ("accept", "text/css") : requestHeaders defaultRequest } assertStatus 403 res caseImageNotFound :: IO () caseImageNotFound = runner $ do res <- request defaultRequest { pathInfo = ["not_a_path"] , requestHeaders = ("accept", "image/jpeg") : requestHeaders defaultRequest } assertStatus 404 res caseVideoBadMethod :: IO () caseVideoBadMethod = runner $ do res <- request defaultRequest { pathInfo = ["good-builder"] , requestMethod = "DELETE" , requestHeaders = ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 res fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e fromExceptionUnwrap se | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e | otherwise = E.fromException se caseThreadKilledRethrow :: IO () caseThreadKilledRethrow = shouldThrow testcode $ \e -> case fromExceptionUnwrap e of (Just ThreadKilled) -> True _ -> False where testcode = runner $ do res <- request defaultRequest { pathInfo = ["thread-killed"] } assertStatus 500 res assertBodyContains "Internal Server Error" res caseDefaultConnectionCloseRethrows :: IO () caseDefaultConnectionCloseRethrows = shouldThrow testcode $ \e -> case fromExceptionUnwrap e of Just Warp.ConnectionClosedByPeer -> True _ -> False where testcode = runner $ do _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] } pure () caseCustomExceptionRethrows :: IO () caseCustomExceptionRethrows = shouldThrow testcode $ \case Custom.MkMyException -> True where testcode = customAppRunner $ do _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] } pure () customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f canTimeoutARunner :: IO () canTimeoutARunner = do res <- timeout 1000 $ runner $ do res <- request defaultRequest { pathInfo = ["sleep-sec"] } assertStatus 200 res -- if 500, it's catching the timeout exception pure () -- it should've timeout by now, either being 500 or Nothing res `shouldBe` Nothing -- make sure that pure statement didn't happen. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/ErrorHandling/CustomApp.hs�����������������������������������0000644�0000000�0000000�00000002051�14371110614�022722� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} -- | a custom app that throws an exception module YesodCoreTest.ErrorHandling.CustomApp (CustomApp(..) , MyException(..) -- * unused , Widget , resourcesCustomApp ) where import Yesod.Core.Types import Yesod.Core import qualified UnliftIO.Exception as E data CustomApp = CustomApp mkYesod "CustomApp" [parseRoutes| /throw-custom-exception CustomHomeR GET |] getCustomHomeR :: Handler Html getCustomHomeR = E.throwIO MkMyException data MyException = MkMyException deriving (Show, E.Exception) instance Yesod CustomApp where -- something we couldn't do before, rethrow custom exceptions catchHandlerExceptions _ action handler = action `E.catch` \exception -> do case E.fromException exception of Just MkMyException -> E.throwIO MkMyException Nothing -> handler exception ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/Exceptions.hs������������������������������������������������0000644�0000000�0000000�00000003460�14371110614�020377� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Exceptions ( exceptionsTest , Widget , resourcesY ) where import Test.Hspec import Yesod.Core import Yesod.Core.Types (HandlerContents (HCError)) import Control.Exception (throwIO) import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status301) data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /redirect RedirR GET /impure ImpureR GET |] instance Yesod Y where approot = ApprootStatic "http://test" errorHandler (InternalError e) = do _ <- return $! e addHeader "ERROR" "HANDLER" return $ toTypedContent e errorHandler x = defaultErrorHandler x getRootR :: Handler () getRootR = error "FOOBAR" >> return () getRedirR :: Handler () getRedirR = do addHeader "foo" "bar" redirectWith status301 RootR getImpureR :: Handler () getImpureR = liftIO $ throwIO $ HCError $ InternalError $ error "impure!" exceptionsTest :: Spec exceptionsTest = describe "Test.Exceptions" $ do it "500" case500 it "redirect keeps headers" caseRedirect it "deals with impure InternalError values" caseImpure runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case500 :: IO () case500 = runner $ do res <- request defaultRequest assertStatus 500 res assertBodyContains "FOOBAR" res caseRedirect :: IO () caseRedirect = runner $ do res <- request defaultRequest { pathInfo = ["redirect"] } assertStatus 301 res assertHeader "foo" "bar" res caseImpure :: IO () caseImpure = runner $ do res <- request defaultRequest { pathInfo = ["impure"] } assertStatus 500 res assertBodyContains "impure!" res assertHeader "ERROR" "HANDLER" res ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.6.24.5/test/YesodCoreTest/InternalRequest.hs�������������������������������������������0000644�0000000�0000000�00000007723�14371110614�021411� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} module YesodCoreTest.InternalRequest (internalRequestTest) where import Data.List (nub) import Network.Wai as W import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) import Yesod.Core import Data.Word (Word64) import System.IO.Unsafe (unsafePerformIO) import Control.Monad (replicateM) import System.Random gen :: IO Int gen = getStdRandom next 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 :: IO () _looksRandom = do s <- randomString 20 gen s `shouldBe` "VH9SkhtptqPs6GqtofVg" noRepeat :: Int -> Int -> IO () noRepeat len n = do ss <- replicateM n $ randomString len gen length (nub ss) `shouldBe` n -- For convenience instead of "(undefined :: StdGen)". g :: IO Int g = error "test/YesodCoreTest/InternalRequest.g" parseWaiRequest' :: Request -> SessionMap -> Bool -> Word64 -> YesodRequest parseWaiRequest' a b c d = unsafePerformIO $ -- ugly hack, just to ease migration, should be removed 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 Data.Monoid.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.6.24.5/test/YesodCoreTest/JsLoader.hs��������������������������������������������������0000644�0000000�0000000�00000002135�14371110614�017757� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoader ( specs , Widget , resourcesH ) 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.6.24.5/test/YesodCoreTest/JsLoaderSites/Bottom.hs0000644000000000000000000000073214371110614022234 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoaderSites.Bottom ( B(..) , Widget , resourcesB -- avoid warning ) 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" yesod-core-1.6.24.5/test/YesodCoreTest/Json.hs0000644000000000000000000000277714371110614017201 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Json ( specs , Widget , resourcesApp ) 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 <- requireInsecureJsonBody 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.6.24.5/test/YesodCoreTest/Links.hs0000644000000000000000000000557414371110614017346 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Links ( linksTest , Widget , resourcesY ) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Data.Text (Text) import Data.ByteString.Builder (toLazyByteString) 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 /route-test-4-spaces/#{Foo Int Int} RT4Spaces GET |] data Vector a = Vector deriving (Show, Read, Eq) instance PathMultiPiece (Vector a) where toPathMultiPiece = error "toPathMultiPiece" fromPathMultiPiece = error "fromPathMultiPiece" data Foo x y = Foo deriving (Show, Read, Eq) instance PathPiece (Foo x y) where toPathPiece = error "toPathPiece" fromPathPiece = error "fromPathPiece" 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 () getRT4Spaces :: Foo Int Int -> Handler () getRT4Spaces _ = 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 toLazyByteString $ 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.6.24.5/test/YesodCoreTest/LiteApp.hs0000644000000000000000000000276114371110614017617 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.6.24.5/test/YesodCoreTest/Media.hs0000644000000000000000000000340014371110614017267 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# 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 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.6.24.5/test/YesodCoreTest/MediaData.hs0000644000000000000000000000046414371110614020070 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.6.24.5/test/YesodCoreTest/Meta.hs0000644000000000000000000000306214371110614017142 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.Meta ( metaTest ) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test data App = App mkYesod "App" [parseRoutes| /title TitleR GET /desc DescriptionR GET |] instance Yesod App where getTitleR :: Handler Html getTitleR = defaultLayout $ do setTitle "First title" setTitle "Second title" getDescriptionR :: Handler Html getDescriptionR = defaultLayout $ do setDescriptionIdemp "First description" setDescriptionIdemp "Second description" metaTest :: Spec metaTest = describe "Setting page metadata" $ do describe "Yesod.Core.Widget.setTitle" $ do it "is idempotent" $ runner $ do res <- request defaultRequest { pathInfo = ["title"] } assertBody "\nSecond title" res describe "Yesod.Core.Widget.setDescriptionIdemp" $ do it "is idempotent" $ runner $ do res <- request defaultRequest { pathInfo = ["desc"] } assertBody "\n" res runner :: Session () -> IO () runner f = toWaiAppPlain App >>= runSession f yesod-core-1.6.24.5/test/YesodCoreTest/NoOverloadedStrings.hs0000644000000000000000000000514714371110614022215 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! module YesodCoreTest.NoOverloadedStrings ( noOverloadedTest , Widget , resourcesY ) 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 :: MonadHandler m => m T.Text getBarR = return $ T.pack "BarR" getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|] getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html getBinR = do routeToParent <- getRouteToParent liftHandler $ defaultLayout [whamlet|

Used defaultLayoutT Baz |] 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 Data.Monoid.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.6.24.5/test/YesodCoreTest/NoOverloadedStringsSub.hs0000644000000000000000000000171014371110614022657 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed... -- Not actually a problem, we're now requiring overloaded strings, we just need -- to make the docs more explicit about it. module YesodCoreTest.NoOverloadedStringsSub where import Yesod.Core import Yesod.Core.Types data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> 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 master where yesodSubDispatch ysre = f ysre where Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre yesod-core-1.6.24.5/test/YesodCoreTest/ParameterizedSite.hs0000644000000000000000000000256014371110614021677 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module YesodCoreTest.ParameterizedSite ( parameterizedSiteTest ) where import Data.ByteString.Lazy (ByteString) import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains) import Test.Hspec (Spec, describe, it) import Yesod.Core (YesodDispatch) import Yesod.Core.Dispatch (toWaiApp) import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..)) import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..)) import YesodCoreTest.ParameterizedSite.Compat (Compat (..)) -- These are actually tests for template haskell. So if it compiles, it works parameterizedSiteTest :: Spec parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do it "Polymorphic unconstrained stub" $ runStub (PolyAny ()) it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow 1337) it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ()) runStub :: YesodDispatch a => a -> IO () runStub stub = let actions = do res <- request defaultRequest assertBodyContains "Stub" res in toWaiApp stub >>= runSession actions runStub' :: YesodDispatch a => ByteString -> a -> IO () runStub' body stub = let actions = do res <- request defaultRequest assertBodyContains "Stub" res assertBodyContains body res in toWaiApp stub >>= runSession actions yesod-core-1.6.24.5/test/YesodCoreTest/ParameterizedSite/Compat.hs0000644000000000000000000000111414371110614023114 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses , OverloadedStrings, StandaloneDeriving, FlexibleInstances #-} module YesodCoreTest.ParameterizedSite.Compat ( Compat (..) ) where import Yesod.Core -- | Parameterized without constraints, and we call mkYesod without type vars, -- like people used to do before the last 3 commits data Compat a b = Compat a b mkYesod "Compat" [parseRoutes| / HomeR GET |] instance Yesod (Compat a b) getHomeR :: Handler a b Html getHomeR = defaultLayout [whamlet|

Stub |] yesod-core-1.6.24.5/test/YesodCoreTest/ParameterizedSite/PolyAny.hs0000644000000000000000000000076014371110614023272 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses , OverloadedStrings, StandaloneDeriving, FlexibleInstances #-} module YesodCoreTest.ParameterizedSite.PolyAny ( PolyAny (..) ) where import Yesod.Core -- | Parameterized without constraints data PolyAny a = PolyAny a mkYesod "PolyAny a" [parseRoutes| / HomeR GET |] instance Yesod (PolyAny a) getHomeR :: Handler a Html getHomeR = defaultLayout [whamlet|

Stub |] yesod-core-1.6.24.5/test/YesodCoreTest/ParameterizedSite/PolyShow.hs0000644000000000000000000000112514371110614023457 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses , OverloadedStrings, StandaloneDeriving, FlexibleInstances #-} module YesodCoreTest.ParameterizedSite.PolyShow ( PolyShow (..) ) where import Yesod.Core -- | Parameterized with 'Show' constraint data PolyShow a = PolyShow a mkYesod "(Show a) => PolyShow a" [parseRoutes| / HomeR GET |] instance Show a => Yesod (PolyShow a) getHomeR :: Show a => Handler a Html getHomeR = do PolyShow x <- getYesod defaultLayout [whamlet|

Stub #{show x} |] yesod-core-1.6.24.5/test/YesodCoreTest/RawResponse.hs0000644000000000000000000000607014371110614020526 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} module YesodCoreTest.RawResponse ( specs , Widget , resourcesApp ) where import Yesod.Core import Test.Hspec import Network.Wai (responseStream) import qualified Data.Conduit.List as CL import qualified Data.ByteString.Char8 as S8 import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Char (toUpper) import Data.Conduit.Network import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race) import Control.Monad.Trans.Resource (register) import Data.IORef import Network.HTTP.Types (status200) import Network.Wai.Handler.Warp (testWithApplication) mkYesod "App" [parseRoutes| / HomeR GET /wai-stream WaiStreamR GET /wai-app-stream WaiAppStreamR GET |] data App = App instance Yesod App getHomeR :: Handler () getHomeR = do ref <- liftIO $ newIORef (0 :: Int) _ <- register $ writeIORef ref 1 sendRawResponse $ \src sink -> liftIO $ do val <- readIORef ref runConduit $ yield (S8.pack $ show val) .| sink runConduit $ src .| CL.map (S8.map toUpper) .| sink getWaiStreamR :: Handler () getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do flush send "hello" flush send " world" getWaiAppStreamR :: Handler () getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do flush send "hello" flush send " world" allowFiveSeconds :: IO a -> IO a allowFiveSeconds = fmap (either id id) . race (threadDelay 5000000 >> error "timed out") specs :: Spec specs = do describe "RawResponse" $ do it "works" $ allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO") runConduit $ yield "WORLd" .| appSink ad runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD") let body req = allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runConduit $ yield req .| appSink ad runConduit $ appSource ad .| CB.lines .| do let loop = do x <- await case x of Nothing -> return () Just "\r" -> return () _ -> loop loop Just "0005\r" <- await Just "hello\r" <- await Just "0006\r" <- await Just " world\r" <- await return () it "sendWaiResponse + responseStream" $ do body "GET /wai-stream HTTP/1.1\r\n\r\n" it "sendWaiApplication + responseStream" $ do body "GET /wai-app-stream HTTP/1.1\r\n\r\n" yesod-core-1.6.24.5/test/YesodCoreTest/Redirect.hs0000644000000000000000000001056414371110614020022 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.Redirect ( specs , Widget , resourcesY ) where import YesodCoreTest.YesodTest import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag) import qualified Network.HTTP.Types as H data Y = Y mkYesod "Y" [parseRoutes| / RootR GET POST /r301 R301 GET /r303 R303 GET /r307 R307 GET /rregular RRegular GET /etag EtagR GET /weak-etag WeakEtagR GET |] instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO () app = yesod Y getRootR :: Handler () getRootR = return () postRootR :: Handler () postRootR = return () getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR getEtagR = setEtag "hello world" getWeakEtagR = setWeakEtag "hello world" specs :: Spec specs = describe "Redirect" $ do it "no redirect" $ app $ do res <- request defaultRequest { pathInfo = [], requestMethod = "POST" } assertStatus 200 res assertBodyContains "" res 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"], httpVersion = H.http11 } 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 describe "etag" $ do it "no if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] } assertStatus 200 res assertHeader "etag" "\"hello world\"" res -- Note: this violates the RFC around ETag format, but is being left as is -- out of concerns that it might break existing users with misbehaving clients. it "single, unquoted if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "hello world")] } assertStatus 304 res it "different if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "hello world!")] } assertStatus 200 res assertHeader "etag" "\"hello world\"" res it "single, quoted if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"hello world\"")] } assertStatus 304 res it "multiple quoted if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")] } assertStatus 304 res it "ignore weak when provided normal etag" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] } assertStatus 200 res it "weak etag" $ app $ do res <- request defaultRequest { pathInfo = ["weak-etag"] , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] } assertStatus 304 res it "different if-none-match for weak etag" $ app $ do res <- request defaultRequest { pathInfo = ["weak-etag"] , requestHeaders = [("if-none-match", "W/\"foo\"")] } assertStatus 200 res it "ignore strong when expecting weak" $ app $ do res <- request defaultRequest { pathInfo = ["weak-etag"] , requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")] } assertStatus 200 res yesod-core-1.6.24.5/test/YesodCoreTest/Reps.hs0000644000000000000000000000537714371110614017200 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Reps ( specs , Widget , resourcesApp ) 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\"}" 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.6.24.5/test/YesodCoreTest/RequestBodySize.hs0000644000000000000000000000606614371110614021364 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.RequestBodySize ( specs , Widget , resourcesY ) 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 <- runConduit $ rawRequestBody .| consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do body <- runConduit $ 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 "total consume- large" "consume" "this is longer than 10" 413 413 caseHelper "total 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.6.24.5/test/YesodCoreTest/Ssl.hs0000644000000000000000000000577014371110614017025 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where import qualified YesodCoreTest.StubSslOnly as Ssl import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite import qualified YesodCoreTest.StubStrictSameSite as StrictSameSite import qualified YesodCoreTest.StubUnsecured as Unsecured import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import qualified Data.ByteString.Char8 as C8 import qualified Web.Cookie as Cookie import qualified Data.List as DL type CookieSpec = Cookie.SetCookie -> Bool type ResponseExpectation = SResponse -> Session () homeFixtureFor :: YesodDispatch a => a -> ResponseExpectation -> IO () homeFixtureFor app assertion = do wa <- toWaiApp app runSession (getHome >>= assertion) wa where getHome = request defaultRequest cookieShouldSatisfy :: String -> CookieSpec -> ResponseExpectation cookieShouldSatisfy name spec response = liftIO $ case DL.filter matchesName $ cookiesIn response of [] -> expectationFailure $ DL.concat [ "Expected a cookie named " , name , " but none is set" ] [c] -> c `shouldSatisfy` spec _ -> expectationFailure $ DL.concat [ "Expected one cookie named " , name , " but found more than one" ] where matchesName c = (Cookie.setCookieName c) == C8.pack name cookiesIn r = DL.map (Cookie.parseSetCookie . snd) (DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders r) sslOnlySpec :: Spec sslOnlySpec = describe "A Yesod application with sslOnly on" $ do it "serves a Strict-Transport-Security header in all responses" $ atHome $ assertHeader "Strict-Transport-Security" "max-age=7200; includeSubDomains" it "sets the Secure flag on its session cookie" $ atHome $ "_SESSION" `cookieShouldSatisfy` Cookie.setCookieSecure where atHome = homeFixtureFor Ssl.App unsecSpec :: Spec unsecSpec = describe "A Yesod application with sslOnly off" $ do it "never serves a Strict-Transport-Security header" $ do atHome $ assertNoHeader "Strict-Transport-Security" it "does not set the Secure flag on its session cookie" $ do atHome $ "_SESSION" `cookieShouldSatisfy` isNotSecure where atHome = homeFixtureFor Unsecured.App isNotSecure c = not $ Cookie.setCookieSecure c sameSiteSpec :: Spec sameSiteSpec = describe "A Yesod application" $ do it "can set a Lax SameSite option" $ laxHome $ "_SESSION" `cookieShouldSatisfy` isLax it "can set a Strict SameSite option" $ strictHome $ "_SESSION" `cookieShouldSatisfy` isStrict where laxHome = homeFixtureFor LaxSameSite.App strictHome = homeFixtureFor StrictSameSite.App isLax = (== Just Cookie.sameSiteLax) . Cookie.setCookieSameSite isStrict = (== Just Cookie.sameSiteStrict) . Cookie.setCookieSameSite yesod-core-1.6.24.5/test/YesodCoreTest/Streaming.hs0000644000000000000000000000137414371110614020211 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.6.24.5/test/YesodCoreTest/StubLaxSameSite.hs0000644000000000000000000000125214371110614021270 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubLaxSameSite ( App ( App ) , Widget , resourcesApp ) where import Yesod.Core import qualified Web.ClientSession as CS data App = App mkYesod "App" [parseRoutes| / HomeR GET |] instance Yesod App where yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120) makeSessionBackend _ = laxSameSiteSessions $ fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] yesod-core-1.6.24.5/test/YesodCoreTest/StubSslOnly.hs0000644000000000000000000000124214371110614020513 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubSslOnly ( App ( App ) , Widget , resourcesApp ) where import Yesod.Core import qualified Web.ClientSession as CS data App = App mkYesod "App" [parseRoutes| / HomeR GET |] instance Yesod App where yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120) makeSessionBackend _ = sslOnlySessions $ fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] yesod-core-1.6.24.5/test/YesodCoreTest/StubStrictSameSite.hs0000644000000000000000000000126014371110614022013 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubStrictSameSite ( App ( App ) , Widget , resourcesApp ) where import Yesod.Core import qualified Web.ClientSession as CS data App = App mkYesod "App" [parseRoutes| / HomeR GET |] instance Yesod App where yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120) makeSessionBackend _ = strictSameSiteSessions $ fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] yesod-core-1.6.24.5/test/YesodCoreTest/StubUnsecured.hs0000644000000000000000000000065214371110614021051 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubUnsecured ( App ( App ) , Widget , resourcesApp ) where import Yesod.Core data App = App mkYesod "App" [parseRoutes| / HomeR GET |] instance Yesod App getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] yesod-core-1.6.24.5/test/YesodCoreTest/SubSub.hs0000644000000000000000000000236214460174107017467 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module YesodCoreTest.SubSub where import Test.Hspec import Yesod.Core import Network.Wai.Test import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 import YesodCoreTest.SubSubData data App = App { getOuter :: OuterSubSite } mkYesod "App" [parseRoutes| / OuterSubSiteR OuterSubSite getOuter |] instance Yesod App getSubR :: SubHandlerFor InnerSubSite master T.Text getSubR = return $ T.pack "sub" instance YesodSubDispatch OuterSubSite master where yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite) instance YesodSubDispatch InnerSubSite master where yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite) app :: App app = App { getOuter = OuterSubSite { getInner = InnerSubSite }} runner :: Session () -> IO () runner f = toWaiApp app >>= runSession f case_subSubsite :: IO () case_subSubsite = runner $ do res <- request defaultRequest assertBody (L8.pack "sub") res assertStatus 200 res subSubTest :: Spec subSubTest = describe "YesodCoreTest.SubSub" $ do it "sub_subsite" case_subSubsiteyesod-core-1.6.24.5/test/YesodCoreTest/SubSubData.hs0000644000000000000000000000061014453667122020261 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} module YesodCoreTest.SubSubData where import Yesod.Core data OuterSubSite = OuterSubSite { getInner :: InnerSubSite } data InnerSubSite = InnerSubSite mkYesodSubData "InnerSubSite" [parseRoutes| / SubR GET |] mkYesodSubData "OuterSubSite" [parseRoutes| / InnerSubSiteR InnerSubSite getInner |]yesod-core-1.6.24.5/test/YesodCoreTest/WaiSubsite.hs0000644000000000000000000000346214371110614020337 0ustar0000000000000000{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-} module YesodCoreTest.WaiSubsite ( specs , Widget , resourcesY ) where import YesodCoreTest.YesodTest import Yesod.Core import qualified Network.HTTP.Types as H import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B (concat) import qualified Data.ByteString.Lazy.Char8 as B8 (pack) myApp :: ByteString -> Application myApp s _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] s getApp :: a -> WaiSubsite getApp _ = WaiSubsite $ myApp "WAI" getAppArgs :: a -> Int -> Int -> WaiSubsite getAppArgs _ i j = WaiSubsite $ myApp $ B.concat ["WAI - ", B8.pack $ show i, " - ", B8.pack $ show j ] data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /sub WaiSubsiteR WaiSubsite getApp /nested NestedR: /sub NestedWaiSubsiteR WaiSubsite getApp /nestedargs/#Int NestedArgsR: /sub/#Int NestedArgsWaiSubsiteR WaiSubsite getAppArgs |] 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 it "nested subsite" $ app $ do res <- request defaultRequest { pathInfo = ["nested", "sub", "foo"] } assertStatus 200 res assertBodyContains "WAI" res it "nested subsite with arguments" $ app $ do res <- request defaultRequest { pathInfo = ["nestedargs", "1", "sub", "2", "foo"] } assertStatus 200 res assertBodyContains "WAI - 1 - 2" res yesod-core-1.6.24.5/test/YesodCoreTest/Widget.hs0000644000000000000000000001037714371110614017506 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Widget ( widgetTest , resourcesY ) where import Test.Hspec import Yesod.Core 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 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");|] getTowidgetR :: Handler Html getTowidgetR = defaultLayout $ do toWidget [julius|toWidget|] :: Widget toWidgetHead [julius|toHead|] toWidgetBody [julius|toBody|] toWidget [lucius|toWidget{bar:baz}|] toWidgetHead [lucius|toHead{bar:baz}|] toWidget [hamlet|

toWidget|] toWidgetHead [hamlet||] toWidgetBody [hamlet|

toBody|] 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 it "toWidget" $ runner $ do res <- request defaultRequest { pathInfo = ["towidget"] } assertBody "\n\n

toWidget

\n

toBody

\n" res runner :: Session () -> IO () runner f = toWaiAppPlain 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.6.24.5/test/YesodCoreTest/YesodTest.hs0000644000000000000000000000073014371110614020176 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.6.24.5/test/RouteSpec.hs0000644000000000000000000003242514371110614015436 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns#-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -ddump-splices #-} import Test.Hspec import Test.HUnit ((@?=)) import Data.Text (Text, pack, unpack, singleton) import Yesod.Routes.Class hiding (Route) import qualified Yesod.Routes.Class as YRC import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..)) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import Hierarchy import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set data MyApp = MyApp data MySub = MySub instance RenderRoute MySub where data Route MySub = MySubRoute ([Text], [(Text, Text)]) deriving (Show, Eq, Read) renderRoute (MySubRoute x) = x instance ParseRoute MySub where parseRoute = Just . MySubRoute getMySub :: MyApp -> MySub getMySub MyApp = MySub data MySubParam = MySubParam Int instance RenderRoute MySubParam where data Route MySubParam = ParamRoute Char deriving (Show, Eq, Read) renderRoute (ParamRoute x) = ([singleton x], []) instance ParseRoute MySubParam where parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x parseRoute _ = Nothing getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam do texts <- [t|[Text]|] let resLeaves = map ResourceLeaf [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True ] resParent = ResourceParent "ParentR" True [ Static "foo" , Dynamic $ ConT ''Text ] [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True ] ress = resParent : resLeaves rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|] , mdsGetPathInfo = [|fst|] , mdsMethod = [|snd|] , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] , mds404 = [|pack "404"|] , mds405 = [|pack "405"|] , mdsGetHandler = defaultGetHandler , mdsUnwrapper = return } ress return #if MIN_VERSION_template_haskell(2,11,0) $ InstanceD Nothing #else $ InstanceD #endif [] (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] : prinst : rainst : rrinst instance Dispatcher MySub master where dispatcher env (pieces, _method) = ( pack $ "subsite: " ++ show pieces , Just $ envToMaster env route ) where route = MySubRoute (pieces, []) instance Dispatcher MySubParam master where dispatcher env (pieces, _method) = case map unpack pieces of [[c]] -> let route = ParamRoute c toMaster = envToMaster env MySubParam i = envSub env in ( pack $ "subparam " ++ show i ++ ' ' : [c] , Just $ toMaster route ) _ -> (pack "404", Nothing) {- thDispatchAlias :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp))) => master -> sub -> (YRC.Route sub -> YRC.Route master) -> app -- ^ 404 page -> handler -- ^ 405 page -> Text -- ^ method -> [Text] -> app --thDispatchAlias = thDispatch thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = case dispatch pieces0 of Just f -> f master sub toMaster app404 handler405 method0 Nothing -> app404 where dispatch = toDispatch [ Route [] False $ \pieces -> case pieces of [] -> do Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsRootR of Just f -> f Nothing -> handler405' in runHandler handler master' sub' RootR toMaster' _ -> error "Invariant violated" , Route [D.Static "blog", D.Dynamic] False $ \pieces -> case pieces of [_, x2] -> do y2 <- fromPathPiece x2 Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsBlogPostR of Just f -> f y2 Nothing -> handler405' in runHandler handler master' sub' (BlogPostR y2) toMaster' _ -> error "Invariant violated" , Route [D.Static "wiki"] True $ \pieces -> case pieces of _:x2 -> do y2 <- fromPathMultiPiece x2 Just $ \master' sub' toMaster' _app404' _handler405' _method -> let handler = handleWikiR y2 in runHandler handler master' sub' (WikiR y2) toMaster' _ -> error "Invariant violated" , Route [D.Static "subsite"] True $ \pieces -> case pieces of _:x2 -> do Just $ \master' sub' toMaster' app404' handler405' method -> dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2 _ -> error "Invariant violated" , Route [D.Static "subparam", D.Dynamic] True $ \pieces -> case pieces of _:x2:x3 -> do y2 <- fromPathPiece x2 Just $ \master' sub' toMaster' app404' handler405' method -> dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3 _ -> error "Invariant violated" ] methodsRootR = Map.fromList [("GET", getRootR)] methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)] -} main :: IO () main = hspec $ do describe "RenderRoute instance" $ do it "renders root correctly" $ renderRoute RootR @?= ([], []) it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], []) it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], []) it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")])) @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")]) it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c') @?= (map pack ["subparam", "6", "c"], []) describe "thDispatch" $ do let disp m ps = dispatcher (Env { envToMaster = id , envMaster = MyApp , envSub = MyApp }) (map pack ps, S8.pack m) it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR) it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR) it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp)) it "routes to blog post" $ disp "GET" ["blog", "somepost"] @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2") it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"] @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"]) it "routes to subsite" $ disp "PUT" ["subsite", "baz"] @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], [])) it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') describe "route parsing" $ do it "subsites work" $ do parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?= Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")])) describe "routing table parsing" $ do it "recognizes trailing backslashes as line continuation directives" $ do let routes :: [ResourceTree String] routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes") length routes @?= 3 describe "overlap checking" $ do it "catches overlapping statics" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping dynamics" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /#Int Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping statics and dynamics" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping multi" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /##*Strings Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping subsite" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 Subsite getSubsite |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "no false positives" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /bar/#String Foo2 |] findOverlapNames routes @?= [] it "obeys ignore rules" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /#!String Foo2 /!foo Foo3 |] findOverlapNames routes @?= [] it "obeys multipiece ignore rules #779" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 /+![String] Foo2 |] findOverlapNames routes @?= [] it "ignore rules for entire route #779" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /foo Foo1 !/+[String] Foo2 !/#String Foo3 !/foo Foo4 |] findOverlapNames routes @?= [] it "ignore rules for hierarchy" $ do let routes :: [ResourceTree String] routes = [parseRoutesNoCheck| /+[String] Foo1 !/foo Foo2: /foo Foo3 /foo Foo4: /!#foo Foo5 |] findOverlapNames routes @?= [] it "proper boolean logic" $ do let routes = [parseRoutesNoCheck| /foo/bar Foo1 /foo/baz Foo2 /bar/baz Foo3 |] findOverlapNames routes @?= [] describe "routeAttrs" $ do it "works" $ do routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"] it "hierarchy" $ do routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") hierarchy describe "parseRouteType" $ do let success s t = it s $ parseTypeTree s @?= Just t failure s = it s $ parseTypeTree s @?= Nothing success "Int" $ TTTerm "Int" success "(Int)" $ TTTerm "Int" failure "(Int" failure "(Int))" failure "[Int" failure "[Int]]" success "[Int]" $ TTList $ TTTerm "Int" success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" getRootR :: Text getRootR = pack "this is the root" getBlogPostR :: Text -> String getBlogPostR t = "some blog post: " ++ unpack t postBlogPostR :: Text -> Text postBlogPostR t = pack $ "POST some blog post: " ++ unpack t handleWikiR :: [Text] -> String handleWikiR ts = "the wiki: " ++ show ts getChildR :: Text -> Text getChildR = id yesod-core-1.6.24.5/test/Hierarchy.hs0000644000000000000000000001512114371110614015435 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Hierarchy ( hierarchy , Dispatcher (..) , runHandler , Handler2 , App , toText , Env (..) , subDispatch -- to avoid warnings , deleteDelete2 , deleteDelete3 ) where import Test.Hspec import Test.HUnit import Yesod.Routes.Parse import Yesod.Routes.TH import Yesod.Routes.Class import Language.Haskell.TH.Syntax import Data.Text (Text, pack, unpack, append) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set class ToText a where toText :: a -> Text instance ToText Text where toText = id instance ToText String where toText = pack type Handler2 sub master a = a type Handler site a = Handler2 site site a type Request = ([Text], ByteString) -- path info, method type App sub master = Request -> (Text, Maybe (Route master)) data Env sub master = Env { envToMaster :: Route sub -> Route master , envSub :: sub , envMaster :: master } subDispatch :: (Env sub master -> App sub master) -> (Handler2 sub master Text -> Env sub master -> Maybe (Route sub) -> App sub master) -> (master -> sub) -> (Route sub -> Route master) -> Env master master -> App sub master subDispatch handler _runHandler getSub toMaster env req = handler env' req where env' = env { envToMaster = envToMaster env . toMaster , envSub = getSub $ envMaster env } class Dispatcher sub master where dispatcher :: Env sub master -> App sub master runHandler :: ToText a => Handler2 sub master a -> Env sub master -> Maybe (Route sub) -> App sub master runHandler h Env {..} route _ = (toText h, fmap envToMaster route) data Hierarchy = Hierarchy do let resources = [parseRoutes| / HomeR GET ---------------------------------------- /!#Int BackwardsR GET /admin/#Int AdminR: / AdminRootR GET /login LoginR GET POST /table/#Text TableR GET /nest/ NestR !NestingAttr: /spaces SpacedR GET !NonNested /nest2 Nest2: / GetPostR GET POST /get Get2 GET /post Post2 POST -- /#Int Delete2 DELETE /nest3 Nest3: /get Get3 GET /post Post3 POST -- /#Int Delete3 DELETE /afterwards AfterR !parent !key=value1: / After GET !child !key=value2 -- /trailing-nest TrailingNestR: -- /foo TrailingFooR GET -- /#Int TrailingIntR GET |] rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|] , mdsGetPathInfo = [|fst|] , mdsMethod = [|snd|] , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] , mds404 = [|pack "404"|] , mds405 = [|pack "405"|] , mdsGetHandler = defaultGetHandler , mdsUnwrapper = return } resources return #if MIN_VERSION_template_haskell(2,11,0) $ InstanceD Nothing #else $ InstanceD #endif [] (ConT ''Dispatcher `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]] : prinst : rainst : rrinst getSpacedR :: Handler site String getSpacedR = "root-leaf" getGet2 :: Handler site String; getGet2 = "get" postPost2 :: Handler site String; postPost2 = "post" deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete" getGet3 :: Handler site String; getGet3 = "get" postPost3 :: Handler site String; postPost3 = "post" deleteDelete3 :: Int -> Handler site String; deleteDelete3 = const "delete" getAfter :: Handler site String; getAfter = "after" getHomeR :: Handler site String getHomeR = "home" getBackwardsR :: Int -> Handler site Text getBackwardsR _ = pack "backwards" getAdminRootR :: Int -> Handler site Text getAdminRootR i = pack $ "admin root: " ++ show i getLoginR :: Int -> Handler site Text getLoginR i = pack $ "login: " ++ show i postLoginR :: Int -> Handler site Text postLoginR i = pack $ "post login: " ++ show i getTableR :: Int -> Text -> Handler site Text getTableR _ = append "TableR " getGetPostR :: Handler site Text getGetPostR = pack "get" postGetPostR :: Handler site Text postGetPostR = pack "post" hierarchy :: Spec hierarchy = describe "hierarchy" $ do it "nested with spacing" $ renderRoute (NestR SpacedR) @?= (["nest", "spaces"], []) it "renders root correctly" $ renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) it "renders table correctly" $ renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) let disp m ps = dispatcher (Env { envToMaster = id , envMaster = Hierarchy , envSub = Hierarchy }) (map pack ps, S8.pack m) let testGetPost route getRes postRes = do let routeStrs = map unpack $ fst (renderRoute route) disp "GET" routeStrs @?= (getRes, Just route) disp "POST" routeStrs @?= (postRes, Just route) it "dispatches routes with multiple METHODs: admin" $ testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1" it "dispatches routes with multiple METHODs: nesting" $ testGetPost (NestR $ Nest2 GetPostR) "get" "post" it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR) it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar") it "parses" $ do parseRoute ([], []) @?= Just HomeR parseRoute ([], [("foo", "bar")]) @?= Just HomeR parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR) parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy)) it "inherited attributes" $ do routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"] it "pair attributes" $ routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"] yesod-core-1.6.24.5/bench/widget.hs0000644000000000000000000000352014371110614015102 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | BigTable benchmark implemented using Hamlet. -- {-# LANGUAGE QuasiQuotes #-} module Main where import Gauge.Main import Text.Hamlet import qualified Data.ByteString.Lazy as L import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import Data.Monoid (mconcat) import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html (toHtml) import Data.Int main :: IO () main = defaultMain [ bench "bigTable html" $ nf bigTableHtml bigTableData , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData --, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) , bench "bigTable blaze" $ nf bigTableBlaze bigTableData ] where rows :: Int rows = 1000 bigTableData :: [[Int]] bigTableData = replicate rows [1..10] {-# NOINLINE bigTableData #-} bigTableHtml :: Show a => [[a]] -> Int64 bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows $forall cell <- row
#{show cell} |] bigTableHamlet :: Show a => [[a]] -> Int64 bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows $forall cell <- row
#{show cell} |] {- bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| $forall row <- rows $forall cell <- row
#{show cell} |]) where render _ _ = "foo" run (WidgetT w) = do (_, GWData { gwdBody = Body x }) <- w undefined return x -} bigTableBlaze :: Show a => [[a]] -> Int64 bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t where row r = tr $ mconcat $ map (td . toHtml . show) r yesod-core-1.6.24.5/LICENSE0000644000000000000000000000207514371110614013215 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.6.24.5/Setup.lhs0000755000000000000000000000016214371110614014016 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-core-1.6.24.5/yesod-core.cabal0000644000000000000000000002024114500472205015241 0ustar0000000000000000name: yesod-core version: 1.6.24.5 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Creation of type-safe, RESTful web applications. description: API docs and the README are available at category: Web, Yesod stability: Stable cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: test/YesodCoreTest.hs test/YesodCoreTest/*.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs test/en.msg test/test.hs test/fixtures/routes_with_line_continuations.yesodroutes ChangeLog.md README.md library default-language: Haskell2010 hs-source-dirs: src build-depends: base >= 4.10 && < 5 , aeson >= 1.0 , attoparsec-aeson >= 2.1 , auto-update , blaze-html >= 0.5 , blaze-markup >= 0.7.1 , bytestring >= 0.10.2 , case-insensitive >= 0.2 , cereal >= 0.3 , clientsession >= 0.9.1 && < 0.10 , conduit >= 1.3 , conduit-extra , containers >= 0.2 , cookie >= 0.4.3 && < 0.5 , deepseq >= 1.3 , entropy , fast-logger >= 2.2 , http-types >= 0.7 , memory , monad-logger >= 0.3.10 && < 0.4 , mtl , parsec >= 2 && < 3.2 , path-pieces >= 0.1.2 && < 0.3 , primitive >= 0.6 , random >= 1.0.0.2 && < 1.3 , resourcet >= 1.2 , shakespeare >= 2.0 , template-haskell >= 2.11 , text >= 0.7 , time >= 1.5 , transformers >= 0.4 , unix-compat , unliftio , unordered-containers >= 0.2 , vector >= 0.9 && < 0.14 , wai >= 3.2 , wai-extra >= 3.0.7 , wai-logger >= 0.2 , warp >= 3.0.2 , word8 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 Yesod.Core.Unsafe Yesod.Routes.TH.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 Yesod.Core.TypeCache Paths_yesod_core Yesod.Routes.TH Yesod.Routes.Class Yesod.Routes.Parse Yesod.Routes.Overlap Yesod.Routes.TH.Dispatch Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.ParseRoute Yesod.Routes.TH.RouteAttrs ghc-options: -Wall -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 other-extensions: TemplateHaskell test-suite test-routes default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: RouteSpec.hs hs-source-dirs: test, src other-modules: Hierarchy Yesod.Routes.Class Yesod.Routes.Overlap Yesod.Routes.Parse Yesod.Routes.TH Yesod.Routes.TH.Dispatch Yesod.Routes.TH.ParseRoute Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.RouteAttrs Yesod.Routes.TH.Types -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 other-extensions: TemplateHaskell build-depends: base , hspec , containers , bytestring , template-haskell , text , random , path-pieces , HUnit test-suite tests default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test other-modules: YesodCoreTest YesodCoreTest.Auth YesodCoreTest.Cache YesodCoreTest.CleanPath YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions YesodCoreTest.InternalRequest YesodCoreTest.JsLoader YesodCoreTest.JsLoaderSites.Bottom YesodCoreTest.Json YesodCoreTest.Links YesodCoreTest.LiteApp YesodCoreTest.Media YesodCoreTest.MediaData YesodCoreTest.Meta YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite YesodCoreTest.ParameterizedSite.Compat YesodCoreTest.ParameterizedSite.PolyAny YesodCoreTest.ParameterizedSite.PolyShow YesodCoreTest.RawResponse YesodCoreTest.Redirect YesodCoreTest.Reps YesodCoreTest.RequestBodySize YesodCoreTest.Ssl YesodCoreTest.Streaming YesodCoreTest.StubLaxSameSite YesodCoreTest.StubSslOnly YesodCoreTest.StubStrictSameSite YesodCoreTest.StubUnsecured YesodCoreTest.SubSub YesodCoreTest.SubSubData YesodCoreTest.WaiSubsite YesodCoreTest.Widget YesodCoreTest.YesodTest cpp-options: -DTEST if os(windows) cpp-options: -DWINDOWS build-depends: base , async , bytestring , clientsession , conduit , conduit-extra , containers , cookie >= 0.4.1 && < 0.5 , hspec >= 1.3 , hspec-expectations , http-types , network , random , resourcet , shakespeare , streaming-commons , text , transformers , unliftio , wai >= 3.0 , wai-extra , warp , yesod-core ghc-options: -Wall -threaded other-extensions: TemplateHaskell benchmark widgets default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench build-depends: base , blaze-html , bytestring , gauge , shakespeare , text main-is: widget.hs ghc-options: -Wall -O2 source-repository head type: git location: https://github.com/yesodweb/yesod yesod-core-1.6.24.5/test/YesodCoreTest/Breadcrumb.hs0000644000000000000000000000245314371110614020325 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module YesodCoreTest.Breadcrumb ( breadcrumbTest, ) where import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Text (Text) import Data.Typeable (Typeable) import Network.Wai import Network.Wai.Test import Test.Hspec import UnliftIO.IORef import Yesod.Core data A = A mkYesod "A" [parseRoutes| / RootR GET /loop LoopR GET |] instance Yesod A instance YesodBreadcrumbs A where breadcrumb r = case r of RootR -> pure ("Root", Nothing) LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop getRootR :: Handler Text getRootR = fst <$> breadcrumbs getLoopR :: Handler Text getLoopR = fst <$> breadcrumbs breadcrumbTest :: Spec breadcrumbTest = describe "Test.Breadcrumb" $ do it "can fetch the root which contains breadcrumbs" $ runner $ do res <- request defaultRequest assertStatus 200 res it "gets a 500 for a route with a looping breadcrumb" $ runner $ do res <- request defaultRequest {pathInfo = ["loop"]} assertStatus 500 res runner :: Session () -> IO () runner f = toWaiApp A >>= runSession f yesod-core-1.6.24.5/test/en.msg0000644000000000000000000000002014371110614014265 0ustar0000000000000000Another: String yesod-core-1.6.24.5/test/fixtures/routes_with_line_continuations.yesodroutes0000644000000000000000000000040514371110614025702 0ustar0000000000000000-- This fixture to test line continuations is in a separate file -- because when I put it in an in-line quasi-quotation, the compiler -- performed the line continuations processing itself. /foo1 \ Foo1 /foo2 Foo2 /foo3 \ Foo3 \ GET POST \ !foo yesod-core-1.6.24.5/ChangeLog.md0000644000000000000000000003254214500472205014364 0ustar0000000000000000# ChangeLog for yesod-core ## 1.6.24.5 * Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818) ## 1.6.24.4 * Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812) ## 1.6.24.3 * Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805) ## 1.6.24.2 * No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797) ## 1.6.24.1 * Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796) ## 1.6.24.0 * Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772). ## 1.6.23.1 * Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) ## 1.6.23 * Add idempotent versions of `setDescription`, `setDescriptionI`. These functions have odd behaviour when called multiple times, so they are now warned against. This can't be a silent change - if you want to switch to the new functions, make sure your layouts are updated to use `pageDescription` as well as `pageTitle`. [#1765](https://github.com/yesodweb/yesod/pull/1765) ## 1.6.22.1 + Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) ## 1.6.22.0 * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) * Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752) * Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) * Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754) ## 1.6.21.0 * Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734) ## 1.6.20.2 * Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729) ## 1.6.20.1 * Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727) ## 1.6.20 * Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726) * Change semantics of `yreGen` and `defaultGen` ## 1.6.19.0 * Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721) ## 1.6.18.8 * Fix test suite for wai-extra change around vary header ## 1.6.18.7 * Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709) ## 1.6.18.6 * Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703) ## 1.6.18.5 Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698) ## 1.6.18.4 * Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697) ## 1.6.18.3 * Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695) ## 1.6.18.2 * Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686) ## 1.6.18.1 * Increase the size of CSRF token ## 1.6.18 * Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663) * Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`, `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or later. [#1664](https://github.com/yesodweb/yesod/pull/1664) ## 1.6.17.3 * Support for `unliftio-core` 0.2 ## 1.6.17.2 * Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657) ## 1.6.17.1 * Remove unnecessary deriving of Typeable ## 1.6.17 * Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646) ## 1.6.16.1 * Compiles with GHC 8.8.1 ## 1.6.16 * Add `jsAttributesHandler` to run arbitrary Handler code before building the attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622) ## 1.6.15 * Move `redirectToPost` JavaScript form submission from HTML element to `