yesod-core-1.4.25/0000755000000000000000000000000012772120703012043 5ustar0000000000000000yesod-core-1.4.25/ChangeLog.md0000644000000000000000000001025112772120703014213 0ustar0000000000000000## 1.4.25 * Add instance of MonadHandler and MonadWidget for ExceptT [#1278](https://github.com/yesodweb/yesod/pull/1278) ## 1.4.24 * cached and cachedBy will not overwrite global state changes [#1268](https://github.com/yesodweb/yesod/pull/1268) ## 1.4.23.1 * Don't allow sending multiple cookies with the same name to the client, in accordance with [RFC 6265](https://tools.ietf.org/html/rfc6265). This fixes an issue where multiple CSRF tokens were sent to the client. [#1258](https://github.com/yesodweb/yesod/pull/1258) * Default CSRF tokens to the root path "/", fixing an issue where multiple tokens were stored in cookies, and using the wrong one led to CSRF errors [#1248](https://github.com/yesodweb/yesod/pull/1248) ## 1.4.23 * urlParamRenderOverride method for Yesod class [#1257](https://github.com/yesodweb/yesod/pull/1257) * Add laxSameSiteSessions and strictSameSiteSessions [#1226](https://github.com/yesodweb/yesod/pull/1226) ## 1.4.22 * Proper handling of impure exceptions within `HandlerError` values ## 1.4.21 * Add support for `Encoding` from `aeson-0.11` [#1241](https://github.com/yesodweb/yesod/pull/1241) ## 1.4.20.2 * GHC 8 support ## 1.4.20.1 * Log a warning when a CSRF error occurs [#1200](https://github.com/yesodweb/yesod/pull/1200) ## 1.4.20 * `addMessage`, `addMessageI`, and `getMessages` functions ## 1.4.19.1 * Allow lines of dashes in route files [#1182](https://github.com/yesodweb/yesod/pull/1182) ## 1.4.19 * Auth logout not working with defaultCsrfMiddleware [#1151](https://github.com/yesodweb/yesod/issues/1151) ## 1.4.18.2 * Allow subsites within hierarchical routes [#1144](https://github.com/yesodweb/yesod/pull/1144) ## 1.4.18 * Add hook to apply arbitrary function to all handlers [#1122](https://github.com/yesodweb/yesod/pull/1122) ## 1.4.17 * Add `getApprootText` ## 1.4.16 * Add `guessApproot` and `guessApprootOr` ## 1.4.15.1 * bugfix neverExpires leaked threads ## 1.4.15 * mkYesod avoids using reify when it isn't necessary. This avoids needing to define the site type below the call to mkYesod. ## 1.4.14 * Add CSRF protection functions and middleware based on HTTP cookies and headers [#1017](https://github.com/yesodweb/yesod/pull/1017) * Add mkYesodWith, which allows creating sites with polymorphic type parameters [#1055](https://github.com/yesodweb/yesod/pull/1055) * Do not define the site type below a call to mkYesod (or any variant), as it will be required at splicing time for reification. This was allowed before because reification was not in use. Reification was introduced to allow parametrized types to be used by mkYesod (and variants), with potentially polymorphic variables. ## 1.4.13 * Add getsYesod function [#1042](https://github.com/yesodweb/yesod/pull/1042) * Add IsString instance for WidgetT site m () [#1038](https://github.com/yesodweb/yesod/pull/1038) ## 1.4.12 * Don't show source location for logs that don't have that information [#1027](https://github.com/yesodweb/yesod/pull/1027) ## 1.4.11 * Expose `stripHandlerT` and `subHelper` ## 1.4.10 * Export log formatting [#1001](https://github.com/yesodweb/yesod/pull/1001) ## 1.4.9.1 * Deal better with multiple cookie headers ## 1.4.9 * Add simple authentication helpers [#962](https://github.com/yesodweb/yesod/pull/962) ## 1.4.8.3 * Use 307 redirect for cleaning paths and non-GET requests [#951](https://github.com/yesodweb/yesod/issues/951) ## 1.4.8.2 * Allow blaze-builder 0.4 ## 1.4.8.1 * Bump upper bound on path-pieces ## 1.4.8 * Add a bunch of `Semigroup` instances ## 1.4.7.3 * Remove defunct reference to SpecialResponse [#925](https://github.com/yesodweb/yesod/issues/925) ## 1.4.7 SSL-only session security [#894](https://github.com/yesodweb/yesod/pull/894) ## 1.4.6.2 monad-control 1.0 ## 1.4.6 Added the `Yesod.Core.Unsafe` module. ## 1.4.5 * `envClientSessionBackend` * Add `MonadLoggerIO` instances (conditional on monad-logger 0.3.10 being used). ## 1.4.4.5 Support time 1.5 ## 1.4.4.2 `neverExpires` uses dates one year in the future (instead of in 2037). ## 1.4.4.1 Improvements to etag/if-none-match support #868 #869 ## 1.4.4 Add the `notModified` and `setEtag` functions. ## 1.4.3 Switch to mwc-random for token generation. yesod-core-1.4.25/LICENSE0000644000000000000000000000207512772120703013054 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.4.25/README.md0000644000000000000000000000036712772120703013330 0ustar0000000000000000## yesod-core This is the main package for Yesod, providing all core functionality on which other packages can be built. It provides dispatch, handler functions, widgets, etc. Yesod is well documented on [its website](http://www.yesodweb.com/). yesod-core-1.4.25/Setup.lhs0000644000000000000000000000016212772120703013652 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-core-1.4.25/test.hs0000644000000000000000000000014112772120703013352 0ustar0000000000000000import Test.Hspec import qualified YesodCoreTest main :: IO () main = hspec YesodCoreTest.specs yesod-core-1.4.25/yesod-core.cabal0000644000000000000000000001503312772120703015102 0ustar0000000000000000name: yesod-core version: 1.4.25 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.8 build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: test.hs test/YesodCoreTest.hs test/YesodCoreTest/*.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs test/en.msg test/test.hs ChangeLog.md README.md library build-depends: base >= 4.6 && < 5 , time >= 1.1.4 , wai >= 3.0 , wai-extra >= 3.0.7 , bytestring >= 0.10 , text >= 0.7 , template-haskell , path-pieces >= 0.1.2 && < 0.3 , shakespeare >= 2.0 , blaze-builder >= 0.2.1.4 && < 0.5 , transformers >= 0.2.2 , mtl , clientsession >= 0.9.1 && < 0.10 , random >= 1.0.0.2 && < 1.2 , cereal >= 0.3 , old-locale >= 1.0.0.2 && < 1.1 , containers >= 0.2 , unordered-containers >= 0.2 , monad-control >= 0.3 && < 1.1 , transformers-base >= 0.4 , cookie >= 0.4.2 && < 0.5 , http-types >= 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 , vector >= 0.9 && < 0.12 , aeson >= 0.5 , fast-logger >= 2.2 , wai-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 , conduit >= 1.2 , resourcet >= 0.4.9 && < 1.2 , lifted-base >= 0.1.2 , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , data-default , safe , warp >= 3.0.2 , unix-compat , conduit-extra , exceptions >= 0.6 , deepseq >= 1.3 , deepseq-generics , mwc-random , primitive , word8 , auto-update , semigroups , byteable 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 -- Following line added due to: https://github.com/yesodweb/yesod/issues/545 -- This looks like a GHC bug extensions: MultiParamTypeClasses -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 extensions: TemplateHaskell test-suite test-routes type: exitcode-stdio-1.0 main-is: RouteSpec.hs hs-source-dirs: test, . other-modules: Hierarchy -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 extensions: TemplateHaskell build-depends: base , hspec , containers , bytestring , template-haskell , text , random , path-pieces , HUnit test-suite tests type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test cpp-options: -DTEST build-depends: base ,hspec >= 1.3 ,hspec-expectations ,clientsession ,wai >= 3.0 ,yesod-core ,bytestring ,text ,http-types , random , blaze-builder ,HUnit ,QuickCheck >= 2 && < 3 ,transformers , conduit , containers , lifted-base , resourcet , network , async , conduit-extra , shakespeare , streaming-commons , wai-extra , mwc-random , cookie >= 0.4.1 && < 0.5 ghc-options: -Wall extensions: TemplateHaskell benchmark widgets type: exitcode-stdio-1.0 hs-source-dirs: bench build-depends: base , criterion , bytestring , text , transformers , yesod-core , blaze-html , shakespeare main-is: widget.hs ghc-options: -Wall -O2 source-repository head type: git location: https://github.com/yesodweb/yesod yesod-core-1.4.25/bench/0000755000000000000000000000000012772120703013122 5ustar0000000000000000yesod-core-1.4.25/bench/widget.hs0000644000000000000000000000347212772120703014747 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | BigTable benchmark implemented using Hamlet. -- {-# LANGUAGE QuasiQuotes #-} module Main where import Criterion.Main import Text.Hamlet import Numeric (showInt) 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 Yesod.Core.Widget import Control.Monad.Trans.Writer import Control.Monad.Trans.RWS import Data.Functor.Identity import Yesod.Core.Types import Data.Monoid import Data.IORef 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 rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows $forall cell <- row
#{show cell} |] bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows $forall cell <- row
#{show cell} |] 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 t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t where row r = tr $ mconcat $ map (td . toHtml . show) r yesod-core-1.4.25/test/0000755000000000000000000000000012772120703013022 5ustar0000000000000000yesod-core-1.4.25/test/en.msg0000644000000000000000000000002012772120703014124 0ustar0000000000000000Another: String yesod-core-1.4.25/test/Hierarchy.hs0000644000000000000000000001500712772120703015277 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 ) 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.4.25/test/RouteSpec.hs0000644000000000000000000003067512772120703015302 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 (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 #if MIN_VERSION_base(4,5,0) Route #else YRC.Route #endif 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 #if MIN_VERSION_base(4,5,0) Route #else YRC.Route #endif 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 "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 "overlap checking" $ do it "catches overlapping statics" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping dynamics" $ do let routes = [parseRoutesNoCheck| /#Int Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping statics and dynamics" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping multi" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /##*Strings Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping subsite" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 Subsite getSubsite |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "no false positives" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /bar/#String Foo2 |] findOverlapNames routes @?= [] it "obeys ignore rules" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /#!String Foo2 /!foo Foo3 |] findOverlapNames routes @?= [] it "obeys multipiece ignore rules #779" $ do let routes = [parseRoutesNoCheck| /foo Foo1 /+![String] Foo2 |] findOverlapNames routes @?= [] it "ignore rules for entire route #779" $ do let routes = [parseRoutesNoCheck| /foo Foo1 !/+[String] Foo2 !/#String Foo3 !/foo Foo4 |] findOverlapNames routes @?= [] it "ignore rules for hierarchy" $ do let 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 "parseRouteTyoe" $ 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" 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.4.25/test/test.hs0000644000000000000000000000014112772120703014331 0ustar0000000000000000import Test.Hspec import qualified YesodCoreTest main :: IO () main = hspec YesodCoreTest.specs yesod-core-1.4.25/test/YesodCoreTest.hs0000644000000000000000000000272212772120703016115 0ustar0000000000000000{-# LANGUAGE CPP #-} module YesodCoreTest (specs) where import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Links import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json import qualified YesodCoreTest.RawResponse as RawResponse 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 cleanPathTest exceptionsTest widgetTest mediaTest linksTest noOverloadedTest internalRequestTest errorHandlingTest cacheTest WaiSubsite.specs Redirect.specs JsLoader.specs RequestBodySize.specs Json.specs RawResponse.specs Streaming.specs Reps.specs Auth.specs LiteApp.specs Ssl.unsecSpec Ssl.sslOnlySpec Ssl.sameSiteSpec Csrf.csrfSpec yesod-core-1.4.25/test/YesodCoreTest/0000755000000000000000000000000012772120703015556 5ustar0000000000000000yesod-core-1.4.25/test/YesodCoreTest/Auth.hs0000644000000000000000000000472712772120703017025 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} module YesodCoreTest.Auth (specs, Widget) where import Yesod.Core import Test.Hspec import Network.Wai.Test import Network.Wai import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import Data.List (isSuffixOf) 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.4.25/test/YesodCoreTest/Cache.hs0000644000000000000000000000607012772120703017120 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec import Network.Wai import Network.Wai.Test import Yesod.Core import Data.IORef.Lifted import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy.Char8 as L8 data C = C newtype V1 = V1 Int deriving Typeable newtype V2 = V2 Int deriving Typeable mkYesod "C" [parseRoutes| / RootR GET /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) return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b] 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) return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b] 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 :: Int]) res it "cachedBy" $ runner $ do res <- request defaultRequest { pathInfo = ["key"] } assertStatus 200 res assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: 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.4.25/test/YesodCoreTest/CleanPath.hs0000644000000000000000000001144612772120703017757 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE CPP #-} module YesodCoreTest.CleanPath (cleanPathTest, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status200, decodePathSegments) import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow ((***)) import Network.HTTP.Types (encodePath) import Data.Monoid (mappend) import Blaze.ByteString.Builder.Char.Utf8 (fromText) data Subsite = Subsite getSubsite :: a -> Subsite getSubsite = const Subsite instance RenderRoute Subsite where data Route Subsite = SubsiteRoute [TS.Text] deriving (Eq, Show, Read) renderRoute (SubsiteRoute x) = (x, []) instance ParseRoute Subsite where parseRoute (x, _) = Just $ SubsiteRoute x instance YesodSubDispatch Subsite master where yesodSubDispatch _ req 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' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x getFooR :: Handler RepPlain getFooR = return $ RepPlain "foo" getFooStringR :: String -> Handler RepPlain getFooStringR = return . RepPlain . toContent getBarR, getPlainR :: Handler RepPlain getBarR = return $ RepPlain "bar" getPlainR = return $ RepPlain "plain" cleanPathTest :: Spec cleanPathTest = describe "Test.CleanPath" $ do it "remove trailing slash" removeTrailingSlash it "noTrailingSlash" noTrailingSlash it "add trailing slash" addTrailingSlash it "has trailing slash" hasTrailingSlash it "/foo/something" fooSomething it "subsite dispatch" subsiteDispatch it "redirect with query string" redQueryString it "parsing" $ do parseRoute (["foo"], []) `shouldBe` Just FooR parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar") parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"]) parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y)) runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f removeTrailingSlash :: IO () removeTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo/" } assertStatus 301 res assertHeader "Location" "http://test/foo" res noTrailingSlash :: IO () noTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "foo" res addTrailingSlash :: IO () addTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/bar" } assertStatus 301 res assertHeader "Location" "http://test/bar/" res hasTrailingSlash :: IO () hasTrailingSlash = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/bar/" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "bar" res fooSomething :: IO () fooSomething = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/foo/something" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "something" res subsiteDispatch :: IO () subsiteDispatch = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/subsite/1/2/3/" } assertStatus 200 res assertContentType "SUBSITE" res assertBody "[\"1\",\"2\",\"3\",\"\"]" res redQueryString :: IO () redQueryString = runner $ do res <- request defaultRequest { pathInfo = decodePathSegments "/plain/" , rawQueryString = "?foo=bar" } assertStatus 301 res assertHeader "Location" "http://test/plain?foo=bar" res yesod-core-1.4.25/test/YesodCoreTest/Csrf.hs0000644000000000000000000000672012772120703017014 0ustar0000000000000000{-# 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|

Welcome to my test application. |] postHomeR :: Handler Html postHomeR = defaultLayout [whamlet|

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.4.25/test/YesodCoreTest/ErrorHandling.hs0000644000000000000000000001602012772120703020647 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget ) where 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) import Network.HTTP.Types (Status, mkStatus) import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) import Data.Monoid (mconcat) import Data.Text (Text, pack) import Control.Monad (forM_) import qualified Control.Exception.Lifted as E 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 |] 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

|] 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 = mconcat $ replicate 100 $ fromByteString "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent 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 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) 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] } assertStatus 500 res `E.catch` \e -> do liftIO $ print res E.throwIO (e :: E.SomeException) yesod-core-1.4.25/test/YesodCoreTest/Exceptions.hs0000644000000000000000000000342012772120703020232 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Exceptions (exceptionsTest, Widget) 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.4.25/test/YesodCoreTest/InternalRequest.hs0000644000000000000000000001001212772120703021231 0ustar0000000000000000{-# 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 qualified System.Random.MWC as MWC import Control.Monad.ST import Control.Monad (replicateM) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do --it "looks reasonably random" looksRandom it "does not repeat itself" $ noRepeat 10 100 -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?). looksRandom :: Bool looksRandom = runST $ do gen <- MWC.create s <- randomString 20 gen return $ s == "VH9SkhtptqPs6GqtofVg" noRepeat :: Int -> Int -> Bool noRepeat len n = runST $ do gen <- MWC.create ss <- replicateM n $ randomString len gen return $ length (nub ss) == n -- For convenience instead of "(undefined :: StdGen)". g :: MWC.GenIO 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 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.4.25/test/YesodCoreTest/JsLoader.hs0000644000000000000000000000207512772120703017621 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoader (specs, Widget) where import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec import Yesod.Core import Network.Wai.Test data H = H mkYesod "H" [parseRoutes| / HeadR GET |] instance Yesod H where jsLoader _ = BottomOfHeadBlocking getHeadR :: Handler Html getHeadR = defaultLayout $ addScriptRemote "load.js" specs :: Spec specs = describe "Test.JsLoader" $ do it "link from head" $ runner H $ do res <- request defaultRequest assertBody "\n" 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.4.25/test/YesodCoreTest/Json.hs0000644000000000000000000000272512772120703017031 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Json (specs, Widget) where import Yesod.Core import Test.Hspec import qualified Data.Map as Map import Network.Wai.Test import Data.Text (Text) import Data.ByteString.Lazy (ByteString) data App = App mkYesod "App" [parseRoutes| / HomeR GET /has-multiple-pieces/#Int/#Int MultiplePiecesR GET |] instance Yesod App getHomeR :: Handler RepPlain getHomeR = do val <- requireJsonBody 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.4.25/test/YesodCoreTest/Links.hs0000644000000000000000000000503512772120703017175 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Links (linksTest, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Data.Text (Text) import Blaze.ByteString.Builder (toByteString) data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /single/#Text TextR GET /multi/*Texts TextsR GET /route-test-1/+[Text] RT1 GET /route-test-2/*Vector-String RT2 GET /route-test-3/*Vector-(Maybe-Int) RT3 GET /route-test-4/#(Foo-Int-Int) RT4 GET |] data Vector a = Vector deriving (Show, Read, Eq) instance PathMultiPiece (Vector a) data Foo x y = Foo deriving (Show, Read, Eq) instance PathPiece (Foo x y) instance Yesod Y getRootR :: Handler Html getRootR = defaultLayout $ toWidget [hamlet||] getTextR :: Text -> Handler Html getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|] getTextsR :: [Text] -> Handler Html getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|] getRT1 :: [Text] -> Handler () getRT1 _ = return () getRT2 :: Vector String -> Handler () getRT2 _ = return () getRT3 :: Vector (Maybe Int) -> Handler () getRT3 _ = return () getRT4 :: Foo Int Int -> Handler () getRT4 _ = return () linksTest :: Spec linksTest = describe "Test.Links" $ do it "linkToHome" case_linkToHome it "blank path pieces" case_blanks runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_linkToHome :: IO () case_linkToHome = runner $ do res <- request defaultRequest assertBody "\n\n" res case_blanks :: IO () case_blanks = runner $ do liftIO $ do let go r = let (ps, qs) = renderRoute r in toByteString $ joinPath Y "" ps qs (go $ TextR "-") `shouldBe` "/single/--" (go $ TextR "") `shouldBe` "/single/-" (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar" res1 <- request defaultRequest { pathInfo = ["single", "-"] , rawPathInfo = "dummy1" } assertBody "\n%%" res1 res2 <- request defaultRequest { pathInfo = ["multi", "foo", "-", "bar"] , rawPathInfo = "dummy2" } assertBody "\n%["foo","","bar"]%" res2 yesod-core-1.4.25/test/YesodCoreTest/LiteApp.hs0000644000000000000000000000276112772120703017456 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.4.25/test/YesodCoreTest/Media.hs0000644000000000000000000000340012772120703017126 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.4.25/test/YesodCoreTest/MediaData.hs0000644000000000000000000000046412772120703017727 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.4.25/test/YesodCoreTest/NoOverloadedStrings.hs0000644000000000000000000000476012772120703022054 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec import YesodCoreTest.NoOverloadedStringsSub import Yesod.Core import Network.Wai import Network.Wai.Test import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 getSubsite :: a -> Subsite getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBinR = do widget <- widgetToParentWidget [whamlet|

Used defaultLayoutT Baz |] lift $ defaultLayout widget getOnePiecesR :: Monad m => Int -> m () getOnePiecesR _ = return () getTwoPiecesR :: Monad m => Int -> Int -> m () getTwoPiecesR _ _ = return () getThreePiecesR :: Monad m => Int -> Int -> Int -> m () getThreePiecesR _ _ _ = return () data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /foo FooR GET /subsite SubsiteR Subsite getSubsite |] instance Yesod Y getRootR :: Handler () getRootR = return () getFooR :: Handler () getFooR = return () runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_sanity :: IO () case_sanity = runner $ do res <- request defaultRequest assertBody mempty res case_subsite :: IO () case_subsite = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "bar"] } assertBody (L8.pack "BarR") res assertStatus 200 res case_deflayout :: IO () case_deflayout = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "baz"] } assertBodyContains (L8.pack "Used Default Layout") res assertStatus 200 res case_deflayoutT :: IO () case_deflayoutT = runner $ do res <- request defaultRequest { pathInfo = map T.pack ["subsite", "bin"] } assertBodyContains (L8.pack "Used defaultLayoutT") res assertStatus 200 res noOverloadedTest :: Spec noOverloadedTest = describe "Test.NoOverloadedStrings" $ do it "sanity" case_sanity it "subsite" case_subsite it "deflayout" case_deflayout it "deflayoutT" case_deflayoutT yesod-core-1.4.25/test/YesodCoreTest/NoOverloadedStringsSub.hs0000644000000000000000000000175312772120703022525 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 (HandlerT master IO) -> Application) mkYesodSubData "Subsite" [parseRoutes| /bar BarR GET /baz BazR GET /bin BinR GET /has-one-piece/#Int OnePiecesR GET /has-two-pieces/#Int/#Int TwoPiecesR GET /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET |] instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where yesodSubDispatch ysre = f ysre where Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre yesod-core-1.4.25/test/YesodCoreTest/RawResponse.hs0000644000000000000000000000710212772120703020362 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} module YesodCoreTest.RawResponse (specs, Widget) where import Yesod.Core import Test.Hspec import qualified Data.Map as Map import Network.Wai.Test import Network.Wai (responseStream) import Data.Text (Text) import Data.ByteString.Lazy (ByteString) 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 Control.Exception (try, IOException) import Data.Conduit.Network import Network.Socket (sClose) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (withAsync) import Control.Monad.Trans.Resource (register) import Data.IORef import Data.Streaming.Network (bindPortTCP) import Network.HTTP.Types (status200) import Blaze.ByteString.Builder (fromByteString) 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 _ <- register $ writeIORef ref 1 sendRawResponse $ \src sink -> liftIO $ do val <- readIORef ref yield (S8.pack $ show val) $$ sink src $$ CL.map (S8.map toUpper) =$ sink getWaiStreamR :: Handler () getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do flush send $ fromByteString "hello" flush send $ fromByteString " world" getWaiAppStreamR :: Handler () getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do flush send $ fromByteString "hello" flush send $ fromByteString " world" getFreePort :: IO Int getFreePort = do loop 43124 where loop port = do esocket <- try $ bindPortTCP port "*" case esocket of Left (_ :: IOException) -> loop (succ port) Right socket -> do sClose socket return port specs :: Spec specs = do describe "RawResponse" $ do it "works" $ do port <- getFreePort withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") yield "WORLd" $$ appSink ad (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") let body req = do port <- getFreePort withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do yield req $$ appSink ad 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.4.25/test/YesodCoreTest/Redirect.hs0000644000000000000000000000653012772120703017657 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.Redirect (specs, Widget) where import YesodCoreTest.YesodTest import Yesod.Core.Handler (redirectWith, setEtag) 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 |] 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 :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR getEtagR = setEtag "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 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" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] } assertStatus 200 res yesod-core-1.4.25/test/YesodCoreTest/Reps.hs0000644000000000000000000000545712772120703017036 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} module YesodCoreTest.Reps (specs, Widget) where import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.String (IsString) import Data.Text (Text) import Data.Maybe (fromJust) import Data.Monoid (Endo (..)) import qualified Control.Monad.Trans.Writer as Writer import qualified Data.Set as Set data App = App mkYesod "App" [parseRoutes| / HomeR GET !home /json JsonR GET /parent/#Int ParentR: /#Text/child ChildR !child |] instance Yesod App specialHtml :: IsString a => a specialHtml = "text/html; charset=special" getHomeR :: Handler TypedContent getHomeR = selectRep $ do rep typeHtml "HTML" rep specialHtml "HTMLSPECIAL" rep typeXml "XML" rep typeJson "JSON" rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) () rep ct t = provideRepType ct $ return (t :: Text) getJsonR :: Handler TypedContent getJsonR = selectRep $ do rep typeHtml "HTML" provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] handleChildR :: Int -> Text -> Handler () handleChildR _ _ = return () testRequest :: Int -- ^ http status code -> Request -> ByteString -- ^ expected body -> Spec testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do app <- toWaiApp App flip runSession app $ do sres <- request req assertStatus status sres assertBody expected sres test :: String -- ^ accept header -> ByteString -- ^ expected body -> Spec test accept expected = testRequest 200 (acceptRequest accept) expected acceptRequest :: String -> Request acceptRequest accept = defaultRequest { requestHeaders = [("Accept", S8.pack accept)] } specs :: Spec specs = do describe "selectRep" $ do test "application/json" "JSON" test (S8.unpack typeJson) "JSON" test "text/xml" "XML" test (S8.unpack typeXml) "XML" test "text/xml,application/json" "XML" test "text/xml;q=0.9,application/json;q=1.0" "JSON" test (S8.unpack typeHtml) "HTML" test "text/html" "HTML" test specialHtml "HTMLSPECIAL" testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}" testRequest 406 (acceptRequest "text/foo") "no match found for accept header" test "text/*" "HTML" test "*/*" "HTML" describe "routeAttrs" $ do it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home" it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty it "ChildR" $ routeAttrs (ParentR 5 $ ChildR "ignored") `shouldBe` Set.singleton "child" yesod-core-1.4.25/test/YesodCoreTest/RequestBodySize.hs0000644000000000000000000000577412772120703021230 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.RequestBodySize (specs, Widget) where import Test.Hspec import Yesod.Core import Network.Wai import Network.Wai.Test import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Data.Text (Text) import qualified Data.Text as T import Data.Conduit import Data.Conduit.List (consume) import Data.Conduit.Binary (isolate) data Y = Y mkYesod "Y" [parseRoutes| /post PostR POST /consume ConsumeR POST /partial-consume PartialConsumeR POST /unused UnusedR POST |] instance Yesod Y where maximumContentLength _ _ = Just 10 postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain postPostR = do val <- lookupPostParams "foobarbaz" return $ RepPlain $ toContent $ T.concat val postConsumeR = do body <- rawRequestBody $$ consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do body <- rawRequestBody $$ isolate 5 =$ consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain "" runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f caseHelper :: String -- ^ name -> Text -- ^ pathinfo -> ByteString -- ^ request body -> Int -- ^ expected status code, chunked -> Int -- ^ expected status code, non-chunked -> Spec caseHelper name path body statusChunked statusNonChunked = describe name $ do it "chunked" $ runner $ do res <- mkRequest False assertStatus statusChunked res it "non-chunked" $ runner $ do res <- mkRequest True assertStatus statusNonChunked res where mkRequest includeLength = srequest $ SRequest defaultRequest { pathInfo = [path] , requestHeaders = ("content-type", "application/x-www-form-urlencoded") : if includeLength then [("content-length", S8.pack $ show $ S.length body)] else [] , requestMethod = "POST" , requestBodyLength = if includeLength then KnownLength $ fromIntegral $ S.length body else ChunkedBody } $ L.fromChunks $ map S.singleton $ S.unpack body specs :: Spec specs = describe "Test.RequestBodySize" $ do caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413 caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200 caseHelper "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.4.25/test/YesodCoreTest/Ssl.hs0000644000000000000000000000577012772120703016664 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.4.25/test/YesodCoreTest/Streaming.hs0000644000000000000000000000137412772120703020050 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.4.25/test/YesodCoreTest/StubLaxSameSite.hs0000644000000000000000000000120212772120703021122 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubLaxSameSite ( App ( App ) ) 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.4.25/test/YesodCoreTest/StubSslOnly.hs0000644000000000000000000000117212772120703020354 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubSslOnly ( App ( App ) ) 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.4.25/test/YesodCoreTest/StubStrictSameSite.hs0000644000000000000000000000121012772120703021645 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubStrictSameSite ( App ( App ) ) 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.4.25/test/YesodCoreTest/StubUnsecured.hs0000644000000000000000000000060212772120703020703 0ustar0000000000000000{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.StubUnsecured ( App ( App ) ) 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.4.25/test/YesodCoreTest/WaiSubsite.hs0000644000000000000000000000342212772120703020172 0ustar0000000000000000{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-} module YesodCoreTest.WaiSubsite (specs, Widget) 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.4.25/test/YesodCoreTest/Widget.hs0000644000000000000000000001033712772120703017341 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Widget (widgetTest) 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 = toWaiApp Y >>= runSession f case_addJuliusBody :: IO () case_addJuliusBody = runner $ do res <- request defaultRequest assertBody "\n" res case_whamlet :: IO () case_whamlet = runner $ do res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

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

Test

http://test/whamlet

Adios

String

Embed

" res case_auto :: IO () case_auto = runner $ do res <- request defaultRequest { pathInfo = ["auto"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\nsomehtml" res case_jshead :: IO () case_jshead = runner $ do res <- request defaultRequest { pathInfo = ["jshead"] } assertBody "\n" res assertHeader "Vary" "Accept, Accept-Language" res yesod-core-1.4.25/test/YesodCoreTest/YesodTest.hs0000644000000000000000000000073012772120703020035 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.4.25/test/YesodCoreTest/JsLoaderSites/0000755000000000000000000000000012772120703020271 5ustar0000000000000000yesod-core-1.4.25/test/YesodCoreTest/JsLoaderSites/Bottom.hs0000644000000000000000000000065112772120703022073 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoaderSites.Bottom (B(..), Widget) where import Yesod.Core data B = B mkYesod "B" [parseRoutes| / BottomR GET |] instance Yesod B where jsLoader _ = BottomOfBody getBottomR :: Handler Html getBottomR = defaultLayout $ addScriptRemote "load.js" yesod-core-1.4.25/Yesod/0000755000000000000000000000000012772120703013126 5ustar0000000000000000yesod-core-1.4.25/Yesod/Core.hs0000644000000000000000000001313012772120703014350 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 (..) -- * Utitlities , maybeAuthorized , widgetToPageContent -- * Defaults , defaultErrorHandler , defaultYesodMiddleware , authorizationCheck -- * Data types , AuthResult (..) , unauthorizedI -- * Logging , defaultMakeLogger , defaultMessageLoggerSource , defaultShouldLog , 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 -- * Subsites , MonadHandler (..) , MonadWidget (..) , getRouteToParent , defaultLayoutSub -- * 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 (..) , MonadBase (..) , MonadBaseControl , MonadResource (..) , MonadLogger -- * Commonly referenced functions/datatypes , Application -- * Utilities , showIntegral , readIntegral -- * Shakespeare -- ** Hamlet , hamlet , shamlet , xhamlet , HtmlUrl -- ** Julius , julius , JavascriptUrl , renderJavascriptUrl -- ** Cassius/Lucius , cassius , lucius , CssUrl , renderCssUrl ) where import Yesod.Core.Content import Yesod.Core.Dispatch import Yesod.Core.Handler import Yesod.Core.Class.Handler import Yesod.Core.Widget import Yesod.Core.Json import Yesod.Core.Types import Text.Shakespeare.I18N import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup) import Control.Monad.Logger import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Core.Internal.Session import Yesod.Core.Internal.Run (yesodRunner, 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 Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp import Text.Hamlet import Text.Cassius import Text.Lucius import Text.Julius import Network.Wai (Application) 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 getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent) getRouteToParent = HandlerT $ return . handlerToParent defaultLayoutSub :: Yesod parent => WidgetT child IO () -> HandlerT child (HandlerT parent IO) Html defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) readIntegral :: Num a => String -> Maybe a readIntegral s = case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing yesod-core-1.4.25/Yesod/Core/0000755000000000000000000000000012772120703014016 5ustar0000000000000000yesod-core-1.4.25/Yesod/Core/Content.hs0000644000000000000000000002506612772120703015775 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Yesod.Core.Content ( -- * Content Content (..) , emptyContent , ToContent (..) , ToFlushBuilder (..) -- * Mime types -- ** Data type , ContentType , typeHtml , typePlain , typeJson , typeXml , typeAtom , typeRss , typeJpeg , typePng , typeGif , typeSvg , typeJavascript , typeCss , typeFlv , typeOgv , typeOctet -- * Utilities , simpleContentType , contentTypeTypes -- * Evaluation strategy , DontFullyEvaluate (..) -- * Representations , TypedContent (..) , ToTypedContent (..) , HasContentType (..) -- ** Specific content types , RepHtml , RepJson (..) , RepPlain (..) , RepXml (..) -- ** Smart constructors , repJson , repPlain , repXml ) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput) import Control.Monad (liftM) import Control.Monad.Trans.Resource (ResourceT) import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J #if MIN_VERSION_aeson(0, 7, 0) import Data.Aeson.Encode (encodeToTextBuilder) #else import Data.Aeson.Encode (fromValue) #endif import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) import Data.Word8 (_semicolon, _slash) -- | Zero-length enumerator. emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy -- bytestring and then calling 'toContent' on that. -- -- Please note that the built-in instances for lazy data structures ('String', -- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include -- the content length for the 'ContentBuilder' constructor. class ToContent a where toContent :: a -> Content instance ToContent Content where toContent = id instance ToContent Builder where toContent = flip ContentBuilder Nothing instance ToContent B.ByteString where toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs instance ToContent L.ByteString where toContent = flip ContentBuilder Nothing . fromLazyByteString instance ToContent T.Text where toContent = toContent . Blaze.fromText instance ToContent Text where toContent = toContent . Blaze.fromLazyText instance ToContent String where toContent = toContent . Blaze.fromString instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where toContent () = toContent B.empty instance ToContent (ContentType, Content) where toContent = snd instance ToContent TypedContent where toContent (TypedContent _ c) = c instance 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.ConduitM (CI.mapOutput toFlushBuilder src >>=) instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where toContent src = ContentSource $ mapOutput toFlushBuilder src instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where toContent (ResumableSource src _) = toContent src -- | A class for all data which can be sent in a streaming response. Note that -- for textual data, instances must use UTF-8 encoding. -- -- Since 1.2.0 class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder repJson :: ToContent a => a -> RepJson repJson = RepJson . toContent repPlain :: ToContent a => a -> RepPlain repPlain = RepPlain . toContent repXml :: ToContent a => a -> RepXml repXml = RepXml . toContent class ToTypedContent a => HasContentType a where getContentType :: Monad m => m a -> ContentType instance HasContentType RepJson where getContentType _ = typeJson deriving instance ToContent RepJson instance HasContentType RepPlain where getContentType _ = typePlain deriving instance ToContent RepPlain instance HasContentType RepXml where getContentType _ = typeXml deriving instance ToContent RepXml typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" typePlain :: ContentType typePlain = "text/plain; charset=utf-8" typeJson :: ContentType typeJson = "application/json; charset=utf-8" typeXml :: ContentType typeXml = "text/xml" typeAtom :: ContentType typeAtom = "application/atom+xml" typeRss :: ContentType typeRss = "application/rss+xml" typeJpeg :: ContentType typeJpeg = "image/jpeg" typePng :: ContentType typePng = "image/png" typeGif :: ContentType typeGif = "image/gif" typeSvg :: ContentType typeSvg = "image/svg+xml" typeJavascript :: ContentType typeJavascript = "text/javascript; charset=utf-8" typeCss :: ContentType typeCss = "text/css; charset=utf-8" typeFlv :: ContentType typeFlv = "video/x-flv" typeOgv :: ContentType typeOgv = "video/ogg" typeOctet :: ContentType typeOctet = "application/octet-stream" -- | Removes \"extra\" information at the end of a content type string. In -- particular, removes everything after the semicolon, if present. -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.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 ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub)) where tailEmpty x = if B.null x then "" else B.tail x (main, sub) = B.break (== _slash) ct instance HasContentType a => HasContentType (DontFullyEvaluate a) where getContentType = getContentType . liftM unDontFullyEvaluate instance ToContent a => ToContent (DontFullyEvaluate a) where toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a instance ToContent J.Value where toContent = flip ContentBuilder Nothing . Blaze.fromLazyText . toLazyText #if MIN_VERSION_aeson(0, 7, 0) . encodeToTextBuilder #else . fromValue #endif #if MIN_VERSION_aeson(0, 11, 0) instance ToContent J.Encoding where toContent = flip ContentBuilder Nothing . J.fromEncoding #endif instance HasContentType J.Value where getContentType _ = typeJson #if MIN_VERSION_aeson(0, 11, 0) instance HasContentType J.Encoding where getContentType _ = typeJson #endif instance HasContentType Html where getContentType _ = typeHtml instance HasContentType Text where getContentType _ = typePlain instance HasContentType T.Text where getContentType _ = typePlain instance HasContentType Css where getContentType _ = typeCss instance HasContentType Javascript where getContentType _ = typeJavascript -- | Any type which can be converted to 'TypedContent'. -- -- Since 1.2.0 class ToContent a => ToTypedContent a where toTypedContent :: a -> TypedContent instance ToTypedContent TypedContent where toTypedContent = id instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where toTypedContent (RepJson c) = TypedContent typeJson c instance ToTypedContent RepPlain where toTypedContent (RepPlain c) = TypedContent typePlain c instance ToTypedContent RepXml where toTypedContent (RepXml c) = TypedContent typeXml c instance ToTypedContent J.Value where toTypedContent v = TypedContent typeJson (toContent v) #if MIN_VERSION_aeson(0, 11, 0) instance ToTypedContent J.Encoding where toTypedContent e = TypedContent typeJson (toContent e) #endif instance ToTypedContent Html where toTypedContent h = TypedContent typeHtml (toContent h) instance ToTypedContent T.Text where toTypedContent t = TypedContent typePlain (toContent t) instance ToTypedContent [Char] where toTypedContent = toTypedContent . pack instance ToTypedContent Text where toTypedContent t = TypedContent typePlain (toContent t) instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where toTypedContent (DontFullyEvaluate a) = let TypedContent ct c = toTypedContent a in TypedContent ct (ContentDontEvaluate c) instance ToTypedContent Css where toTypedContent = TypedContent typeCss . toContent instance ToTypedContent Javascript where toTypedContent = TypedContent typeJavascript . toContent yesod-core-1.4.25/Yesod/Core/Dispatch.hs0000644000000000000000000002002012772120703016103 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} module Yesod.Core.Dispatch ( -- * Quasi-quoted routing parseRoutes , parseRoutesNoCheck , parseRoutesFile , parseRoutesFileNoCheck , mkYesod , mkYesodWith -- ** More fine-grained , mkYesodData , mkYesodSubData , mkYesodDispatch , mkYesodSubDispatch -- ** Path pieces , PathPiece (..) , PathMultiPiece (..) , Texts -- * Convert to WAI , toWaiApp , toWaiAppPlain , warp , warpDebug , warpEnv , mkDefaultMiddlewares , defaultMiddlewaresNoLogging -- * WAI subsites , WaiSubsite (..) , subHelper ) where import Prelude hiding (exp) import Yesod.Core.Internal.TH import Language.Haskell.TH.Syntax (qLocation) import Web.PathPieces import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) #endif import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Blaze.ByteString.Builder 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 Safe (readMay) import System.Environment (getEnvironment) 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) import qualified System.Random.MWC as MWC -- | 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 gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires return $ toWaiAppYre YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = gen , yreGetMaxExpires = getMaxExpires } 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", Blaze.ByteString.Builder.toByteString 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` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env) -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers: -- -- * Logging -- -- * GZIP compression -- -- * Automatic HEAD method handling -- -- * Request method override with the _method query string parameter -- -- * Accept header override with the _accept query string parameter toWaiApp :: YesodDispatch site => site -> IO W.Application toWaiApp site = do logger <- makeLogger site toWaiAppLogger logger site toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger logger site = do sb <- makeSessionBackend site gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = gen , yreGetMaxExpires = getMaxExpires } messageLoggerSource site logger $(qLocation >>= liftLoc) "yesod-core" LevelInfo (toLogStr ("Application launched" :: S.ByteString)) middleware <- mkDefaultMiddlewares logger return $ middleware $ toWaiAppYre yre -- | A convenience method to run an application using the Warp webserver on the -- specified port. Automatically calls 'toWaiApp'. Provides a default set of -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: -- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. -- -- Since 1.2.0 warp :: YesodDispatch site => Int -> site -> IO () warp port site = do logger <- makeLogger site toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings ( Network.Wai.Handler.Warp.setPort port $ Network.Wai.Handler.Warp.setServerName serverValue $ Network.Wai.Handler.Warp.setOnException (\_ e -> when (shouldLog' e) $ messageLoggerSource site logger $(qLocation >>= liftLoc) "yesod-core" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) Network.Wai.Handler.Warp.defaultSettings) where shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException serverValue :: S8.ByteString serverValue = S8.pack $ concat [ "Warp/" , Network.Wai.Handler.Warp.warpVersion , " + Yesod/" , showVersion Paths_yesod_core.version , " (core)" ] -- | A default set of middlewares. -- -- Since 1.2.0 mkDefaultMiddlewares :: Logger -> IO W.Middleware mkDefaultMiddlewares logger = do logWare <- mkRequestLogger def { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger , outputFormat = Apache FromSocket } return $ logWare . defaultMiddlewaresNoLogging -- | All of the default middlewares, excluding logging. -- -- Since 1.2.12 defaultMiddlewaresNoLogging :: W.Middleware defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride -- | Deprecated synonym for 'warp'. warpDebug :: YesodDispatch site => Int -> site -> IO () warpDebug = warp {-# DEPRECATED warpDebug "Please use warp instead" #-} -- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It -- reads port information from the PORT environment variable, as used by tools -- such as Keter and the FP Complete School of Haskell. -- -- Note that the exact behavior of this function may be modified slightly over -- time to work correctly with external tools, without a change to the type -- signature. warpEnv :: YesodDispatch site => site -> IO () warpEnv site = do env <- getEnvironment case lookup "PORT" env of Nothing -> error "warpEnv: no PORT environment variable found" Just portS -> case readMay portS of Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Just port -> warp port site getGetMaxExpires :: IO (IO Text) getGetMaxExpires = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentMaxExpiresRFC1123 , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day } yesod-core-1.4.25/Yesod/Core/Handler.hs0000644000000000000000000014714512772120703015743 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Yesod.Handler -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : stable -- Portability : portable -- -- Define Handler stuff. -- --------------------------------------------------------- module Yesod.Core.Handler ( -- * Handler monad HandlerT -- ** Read information from handler , getYesod , getsYesod , getUrlRender , getUrlRenderParams , getCurrentRoute , getRequest , waiRequest , runRequestBody , rawRequestBody -- ** Request information -- *** Request datatype , RequestBodyContents , YesodRequest (..) , FileInfo , fileName , fileContentType , fileSource , fileMove -- *** Convenience functions , languages -- *** Lookup parameters , lookupGetParam , lookupPostParam , lookupCookie , lookupFile , lookupHeader -- **** Lookup authentication data , lookupBasicAuth , lookupBearerAuth -- **** Multi-lookup , lookupGetParams , lookupPostParams , lookupCookies , lookupFiles , lookupHeaders -- * Responses -- ** Pure , respond -- ** Streaming , respondSource , sendChunk , sendFlush , sendChunkBS , sendChunkLBS , sendChunkText , sendChunkLazyText , sendChunkHtml -- ** Redirecting , RedirectUrl (..) , redirect , redirectWith , redirectToPost , Fragment(..) -- ** Errors , notFound , badMethod , notAuthenticated , permissionDenied , permissionDeniedI , invalidArgs , invalidArgsI -- ** Short-circuit responses. , sendFile , sendFilePart , sendResponse , sendResponseStatus -- ** Type specific response with custom status , sendStatusJSON , sendResponseCreated , sendWaiResponse , sendWaiApplication , sendRawResponse , sendRawResponseNoConduit , notModified -- * Different representations -- $representations , selectRep , provideRep , provideRepType , ProvidedRep -- * Setting headers , setCookie , getExpires , deleteCookie , addHeader , setHeader , setLanguage -- ** Content caching and expiration , cacheSeconds , neverExpires , alreadyExpired , expiresAt , setEtag -- * Session , SessionMap , lookupSession , lookupSessionBS , getSession , setSession , setSessionBS , deleteSession , clearSession -- ** Ultimate destination , setUltDest , setUltDestCurrent , setUltDestReferer , redirectUltDest , clearUltDest -- ** Messages , addMessage , addMessageI , getMessages , setMessage , setMessageI , getMessage -- * Helpers for specific content -- ** Hamlet , hamletToRepHtml , giveUrlRenderer , withUrlRenderer -- ** Misc , newIdent -- * Lifting , handlerToIO , forkHandler -- * i18n , getMessageRender -- * Per-request caching , cached , cachedBy , stripHandlerT -- * 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) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mempty, mappend) #endif import Control.Applicative ((<|>)) import Control.Exception (evaluate, SomeException, throwIO) import Control.Exception.Lifted (handle) import Control.Monad (void, liftM, unless) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad.IO.Class (MonadIO, liftIO) 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) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Hamlet (Html, HtmlUrl, hamlet) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.HashMap.Strict as HM import Data.Byteable (constEqBytes) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Monoid (Endo (..)) import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) 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.Lifted as I import Data.Maybe (listToMaybe, mapMaybe) import Data.Typeable (Typeable) import Web.PathPieces (PathPiece(..)) import Yesod.Core.Class.Handler import Yesod.Core.Types import Yesod.Routes.Class (Route) import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI) 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 Control.Monad.Trans.Control (control, MonadBaseControl) import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink) import qualified Yesod.Core.TypeCache as Cache import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold import Data.Default import Control.Monad.Logger (MonadLogger, logWarnS) get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState put :: MonadHandler m => GHState -> m () put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState modify :: MonadHandler m => (GHState -> GHState) -> m () modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState tell :: MonadHandler m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } handlerError :: MonadHandler m => HandlerContents -> m a handlerError = liftIO . throwIO hcError :: MonadHandler m => ErrorResponse -> m a hcError = handlerError . HCError getRequest :: MonadHandler m => m YesodRequest getRequest = liftHandlerT $ HandlerT $ return . handlerRequest runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody = do HandlerData { handlerEnv = RunHandlerEnv {..} , handlerRequest = req } <- liftHandlerT $ HandlerT return let len = W.requestBodyLength $ reqWaiRequest req upload = rheUpload len x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest 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)) askHandlerEnv = liftHandlerT $ HandlerT $ 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 the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) getCurrentRoute = rheRoute <$> askHandlerEnv -- | Returns a function that runs 'HandlerT' actions inside @IO@. -- -- Sometimes you want to run an inner 'HandlerT' action outside -- the control flow of an HTTP request (on the outer 'HandlerT' -- action). For example, you may want to spawn a new thread: -- -- @ -- getFooR :: Handler RepHtml -- getFooR = do -- runInnerHandler <- handlerToIO -- liftIO $ forkIO $ runInnerHandler $ do -- /Code here runs inside GHandler but on a new thread./ -- /This is the inner GHandler./ -- ... -- /Code here runs inside the request's control flow./ -- /This is the outer GHandler./ -- ... -- @ -- -- Another use case for this function is creating a stream of -- server-sent events using 'GHandler' actions (see -- @yesod-eventsource@). -- -- Most of the environment from the outer 'GHandler' is preserved -- on the inner 'GHandler', however: -- -- * The request body is cleared (otherwise it would be very -- difficult to prevent huge memory leaks). -- -- * The cache is cleared (see 'CacheKey'). -- -- Changes to the response made inside the inner 'GHandler' are -- ignored (e.g., session variables, cookies, response headers). -- This allows the inner 'GHandler' to outlive the outer -- 'GHandler' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread). handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a) handlerToIO = HandlerT $ \oldHandlerData -> do -- Take just the bits we need from oldHandlerData. let newReq = oldReq { reqWaiRequest = newWaiReq } where oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq newWaiReq = oldWaiReq { W.requestBody = return mempty , W.requestBodyLength = W.KnownLength 0 } oldEnv = handlerEnv oldHandlerData newState <- liftIO $ do oldState <- I.readIORef (handlerState oldHandlerData) return $ oldState { ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty , ghsCacheBy = mempty , ghsHeaders = mempty } -- xx From this point onwards, no references to oldHandlerData xx liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) -- Return GHandler running function. return $ \(HandlerT f) -> liftIO $ runResourceT $ withInternalState $ \resState -> do -- The state IORef needs to be created here, otherwise it -- will be shared by different invocations of this function. newStateIORef <- liftIO (I.newIORef newState) let newHandlerData = HandlerData { handlerRequest = newReq , handlerEnv = oldEnv , handlerState = newStateIORef , handlerToParent = const () , handlerResource = resState } liftIO (f newHandlerData) -- | 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 -> HandlerT site IO ()) -- ^ error handler -> HandlerT site IO () -> HandlerT site IO () forkHandler onErr handler = do yesRunner <- handlerToIO void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr 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 . headMay) getMessages -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: MonadHandler m => ContentType -> FilePath -> m a sendFile ct fp = handlerError $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. sendFilePart :: MonadHandler m => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count -> m a sendFilePart ct fp off count = do fs <- liftIO $ PC.getFileStatus fp handlerError $ HCSendFile ct fp $ Just W.FilePart { W.filePartOffset = off , W.filePartByteCount = count , W.filePartFileSize = fromIntegral $ PC.fileSize fs } -- | Bypass remaining handler code and output the given content with a 200 -- status code. sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a sendResponse = handlerError . HCContent H.status200 . toTypedContent -- | Bypass remaining handler code and output the given content with the given -- status code. sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Bypass remaining handler code and output the given JSON with the given -- status code. -- -- Since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a #if MIN_VERSION_aeson(0, 11, 0) sendStatusJSON s v = sendResponseStatus s (toEncoding v) #else sendStatusJSON s v = sendResponseStatus s (toJSON v) #endif -- | Send a 201 "Created" response with the given route as the Location -- response header. sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a sendResponseCreated url = do r <- getUrlRender handlerError $ HCCreated $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't. sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai -- | 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, MonadBaseControl IO m) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) -> m a sendRawResponseNoConduit raw = control $ \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, MonadBaseControl IO m) => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) -> m a sendRawResponse raw = control $ \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 an arbitrary response header. -- -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -- -- Since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m () addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: MonadHandler m => Int -> m () cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age=" , T.pack $ show i , ", public" ] -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. neverExpires :: MonadHandler m => m () neverExpires = 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 -- | 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 value 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 if encodeUtf8 etag `elem` matches then notModified else addHeader "etag" $ T.concat ["\"", etag, "\""] -- | Parse an if-none-match field according to the spec. Does not parsing on -- weak matches, which are not supported by setEtag. parseMatch :: S.ByteString -> [S.ByteString] parseMatch = map clean . S.split W8._comma where clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace stripQuotes bs | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl = S.init $ S.tail bs | otherwise = bs -- | Set a variable in the user's session. -- -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. setSession :: MonadHandler m => Text -- ^ key -> Text -- ^ value -> m () setSession k = setSessionBS k . encodeUtf8 -- | Same as 'setSession', but uses binary data for the value. setSessionBS :: MonadHandler m => Text -> S.ByteString -> m () setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: MonadHandler m => Text -> m () deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- -- Since: 1.0.1 clearSession :: MonadHandler m => m () clearSession = modify $ \x -> x { ghsSession = Map.empty } modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'. addHeaderInternal :: MonadHandler m => Header -> m () addHeaderInternal = tell . Endo . (:) -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text instance RedirectUrl master Text where toTextUrl = return instance RedirectUrl master String where toTextUrl = toTextUrl . T.pack instance RedirectUrl master (Route master) where toTextUrl url = do r <- getUrlRender return $ r url instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where toTextUrl (url, params) = do r <- getUrlRenderParams return $ r url params instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where toTextUrl (url, params) = toTextUrl (url, Map.toList params) -- | Add a fragment identifier to a route to be used when -- redirecting. For example: -- -- > redirect (NewsfeedR :#: storyId) -- -- Since 1.2.9. data Fragment a b = a :#: b deriving (Show, Typeable) instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a -- | Lookup for session data. lookupSession :: MonadHandler m => Text -> m (Maybe Text) lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do m <- fmap ghsSession get return $ Map.lookup n m -- | Get all session variables. getSession :: MonadHandler m => m SessionMap getSession = fmap ghsSession get -- | Get a unique identifier. newIdent :: MonadHandler m => m Text newIdent = do x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' } return $ T.pack $ "hident" ++ show i' -- | Redirect to a POST resource. -- -- This is not technically a redirect; instead, it returns an HTML page with a -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m a redirectToPost url = do urlText <- toTextUrl url req <- getRequest withUrlRenderer [hamlet| $newline never $doctype 5 Redirecting... <body onload="document.getElementById('form').submit()"> <form id="form" method="post" action=#{urlText}> $maybe token <- reqToken req <input type=hidden name=#{defaultCsrfParamName} value=#{token}> <noscript> <p>Javascript has been disabled; please click on the button below to be redirected. <input type="submit" value="Continue"> |] >>= sendResponse -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html hamletToRepHtml = withUrlRenderer {-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-} -- | Deprecated synonym for 'withUrlRenderer'. -- -- Since 1.2.0 giveUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output giveUrlRenderer = withUrlRenderer {-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-} -- | Provide a URL rendering function to the given function and return the -- result. Useful for processing Shakespearean templates. -- -- Since 1.2.20 withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output withUrlRenderer f = do render <- getUrlRenderParams return $ f render -- | Get the request\'s 'W.Request' value. waiRequest :: MonadHandler m => m W.Request waiRequest = reqWaiRequest <$> getRequest getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) => m (message -> Text) getMessageRender = do env <- askHandlerEnv l <- reqLangs <$> getRequest 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 -- | 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 -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order -- of preference): -- -- * The _LANG get parameter. -- -- * The _LANG cookie. -- -- * The _LANG user session variable. -- -- * Accept-Language HTTP header. -- -- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates. -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). languages :: MonadHandler m => m [Text] languages = reqLangs <$> 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, MonadResource m) => Text -> m (Maybe FileInfo) lookupFile = fmap listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: (MonadHandler m, MonadResource m) => Text -> m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. lookupCookie :: MonadHandler m => Text -> m (Maybe Text) lookupCookie = 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:_ -> if null cts then returnRep rep else sendResponseStatus H.status406 explainUnaccepted rep:_ -> returnRep rep where explainUnaccepted :: Text explainUnaccepted = "no match found for accept header" returnRep (ProvidedRep ct mcontent) = 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 headMay reps else Map.lookup mainType mainTypeMap else lookupAccept ct where (mainType, subType) = contentTypeTypes ct lookupAccept ct = Map.lookup ct repMap <|> Map.lookup (noSpace ct) repMap <|> Map.lookup (simpleContentType ct) repMap -- Mime types such as "text/html; charset=foo" get converted to -- "text/html;charset=foo" noSpace = S8.filter (/= ' ') -- | Internal representation of a single provided representation. -- -- Since 1.2.0 data ProvidedRep m = ProvidedRep !ContentType !(m Content) -- | Provide a single representation to be used, based on the request of the -- client. Should be used together with 'selectRep'. -- -- Since 1.2.0 provideRep :: (Monad m, HasContentType a) => m a -> Writer.Writer (Endo [ProvidedRep m]) () provideRep handler = provideRepType (getContentType handler) handler -- | Same as 'provideRep', but instead of determining the content type from the -- type of the value itself, you provide the content type separately. This can -- be a convenience instead of creating newtype wrappers for uncommonly used -- content types. -- -- > provideRepType "application/x-special-format" "This is the content" -- -- Since 1.2.0 provideRepType :: (Monad m, ToContent a) => ContentType -> m a -> Writer.Writer (Endo [ProvidedRep m]) () provideRepType ct handler = Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):) -- | Stream in the raw request body without any parsing. -- -- Since 1.2.0 rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest 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 -> Source m S.ByteString fileSource = transPipe liftResourceT . fileSourceRaw -- | Provide a pure value for the response body. -- -- > respond ct = return . TypedContent ct . toContent -- -- Since 1.2.0 respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent respond ct = return . TypedContent ct . toContent -- | Use a @Source@ for the response body. -- -- Note that, for ease of use, the underlying monad is a @HandlerT@. This -- implies that you can run any @HandlerT@ action. However, since a streaming -- response occurs after the response headers have already been sent, some -- actions make no sense here. For example: short-circuit responses, setting -- headers, changing status codes, etc. -- -- Since 1.2.0 respondSource :: ContentType -> Source (HandlerT site IO) (Flush Builder) -> HandlerT site IO TypedContent respondSource ctype src = HandlerT $ \hd -> -- Note that this implementation relies on the fact that the ResourceT -- environment provided by the server is the same one used in HandlerT. -- This is a safe assumption assuming the HandlerT is run correctly. return $ TypedContent ctype $ ContentSource $ transPipe (lift . flip unHandlerT hd) src -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. -- -- Since 1.2.0 sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder) sendChunk = yield . toFlushBuilder -- | In a streaming response, send a flush command, causing all buffered data -- to be immediately sent to the client. -- -- Since 1.2.0 sendFlush :: Monad m => Producer m (Flush Builder) sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- -- Since 1.2.0 sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder) sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- -- Since 1.2.0 sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder) sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- -- Since 1.2.0 sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder) sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- -- Since 1.2.0 sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder) sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- -- Since 1.2.0 sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml = sendChunk -- | Converts a child handler to a parent handler -- -- Exported since 1.4.11 stripHandlerT :: HandlerT child (HandlerT parent m) a -> (parent -> child) -> (Route child -> Route parent) -> Maybe (Route child) -> HandlerT parent m a stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do let env = handlerEnv hd ($ hd) $ unHandlerT $ f hd { handlerEnv = env { rheSite = getSub $ rheSite env , rheRoute = newRoute , rheRender = \url params -> rheRender env (toMaster url) params } , handlerToParent = toMaster } -- $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. -- | 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 def { 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 <- hasValidCsrfHeaderNamed headerName unless valid (permissionDenied csrfErrorMessage) -- | 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 = do mCsrfToken <- reqToken <$> getRequest mXsrfHeader <- lookupHeader headerName return $ validCsrf mCsrfToken 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 <- hasValidCsrfParamNamed paramName unless valid (permissionDenied csrfErrorMessage) -- | 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 = do mCsrfToken <- reqToken <$> getRequest mCsrfParam <- lookupPostParam paramName return $ validCsrf mCsrfToken (encodeUtf8 <$> 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 <- hasValidCsrfHeaderNamed headerName validParam <- hasValidCsrfParamNamed paramName unless (validHeader || validParam) $ do $logWarnS "yesod-core" csrfErrorMessage permissionDenied csrfErrorMessage validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks. validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param validCsrf Nothing _param = True validCsrf (Just _token) Nothing = False csrfErrorMessage :: Text csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Because the request could have been forged, it's been rejected altogether. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection." ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Internal.hs������������������������������������������������������������0000644�0000000�0000000�00000000436�12772120703�016131� 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.4.25/Yesod/Core/Json.hs����������������������������������������������������������������0000644�0000000�0000000�00000014115�12772120703�015265� 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 #if MIN_VERSION_aeson(0, 11, 0) , returnJsonEncoding #endif , provideJson -- * Convert to a JSON value , parseJsonBody , parseJsonBody_ , requireJsonBody -- * Produce JSON values , J.Value (..) , J.ToJSON (..) , J.FromJSON (..) , array , object , (.=) , (J..:) -- * Convenience functions , jsonOrRedirect #if MIN_VERSION_aeson(0, 11, 0) , jsonEncodingOrRedirect #endif , acceptsJson ) where import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep) import Control.Monad.Trans.Writer (Writer) import Data.Monoid (Endo) import Yesod.Core.Content (TypedContent) import Yesod.Core.Types (reqAccept) import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Handler import Yesod.Core.Widget (WidgetT) import Yesod.Routes.Class import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP import Data.Aeson ((.=), object) import Data.Conduit.Attoparsec (sinkParser) import Data.Text (pack) import qualified Data.Vector as V import Data.Conduit import 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) => WidgetT site IO () -- ^ HTML -> HandlerT site IO a -- ^ JSON -> HandlerT site IO TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w #if MIN_VERSION_aeson(0, 11, 0) provideRep $ fmap J.toEncoding json #else provideRep $ fmap J.toJSON json #endif -- | 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 #if MIN_VERSION_aeson(0, 11, 0) -- | 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 #endif -- | 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]) () #if MIN_VERSION_aeson(0, 11, 0) provideJson = provideRep . return . J.toEncoding #else provideJson = provideRep . return . J.toJSON #endif -- | 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'@. -- -- 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 parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseJsonBody = do eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value') return $ case eValue of Left e -> J.Error $ show e Right value -> J.fromJSON value -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a parseJsonBody_ = requireJsonBody {-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-} -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireJsonBody = do ra <- parseJsonBody case ra of J.Error s -> invalidArgs [pack s] J.Success a -> return a -- | Convert a list of values to an 'J.Array'. array :: J.ToJSON a => [a] -> J.Value array = J.Array . V.fromList . map J.toJSON -- | jsonOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: -- -- 1. 200 with JSON data if the client prefers -- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. jsonOrRedirect :: (MonadHandler m, J.ToJSON a) => Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON -> m J.Value jsonOrRedirect = jsonOrRedirect' J.toJSON #if MIN_VERSION_aeson(0, 11, 0) -- | 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 #endif jsonOrRedirect' :: (MonadHandler m, J.ToJSON a) => (a -> b) -> Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON -> m b jsonOrRedirect' f r j = do q <- acceptsJson if q then return (f j) else redirect r -- | Returns @True@ if the client prefers @application\/json@ as -- indicated by the @Accept@ HTTP header. acceptsJson :: MonadHandler m => m Bool acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';')) . listToMaybe . reqAccept) `liftM` getRequest ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/TypeCache.hs�����������������������������������������������������������0000644�0000000�0000000�00000007470�12772120703�016227� 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, cachedBy, 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 clookup cache of Just val -> return $ Right val Nothing -> do val <- action return $ Left (cinsert val cache, val) where clookup :: Typeable a => TypeMap -> Maybe a clookup c = res where res = lookup (typeOf $ fromJust res) c >>= fromDynamic fromJust :: Maybe a -> a fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" cinsert :: Typeable a => a -> TypeMap -> TypeMap cinsert v = insert (typeOf v) (toDyn v) -- | 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 clookup k cache of Just val -> return $ Right val Nothing -> do val <- action return $ Left (cinsert k val cache, val) where clookup :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a clookup 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" cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap cinsert key v = insert (typeOf v, key) (toDyn v) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Types.hs���������������������������������������������������������������0000644�0000000�0000000�00000053467�12772120703�015475� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Types where import qualified Blaze.ByteString.Builder as BBuilder import qualified Blaze.ByteString.Builder.Char.Utf8 #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative (..)) import Control.Applicative ((<$>)) import Data.Monoid (Monoid (..)) #endif import Control.Arrow (first) import Control.Exception (Exception) import Control.Monad (liftM, ap) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Catch (MonadMask (..), MonadCatch (..)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, Source) import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map import Data.Monoid (Endo (..), Last (..)) import Data.Serialize (Serialize (..), putByteString) import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TBuilder import Data.Time (UTCTime) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H import Network.Wai (FilePart, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr) import qualified System.Random.MWC as MWC 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 Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..)) #if !MIN_VERSION_base(4, 6, 0) import Prelude hiding (catch) #endif import Control.DeepSeq (NFData (rnf)) import Control.DeepSeq.Generics (genericRnf) import Data.Conduit.Lazy (MonadActive, monadActive) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) #if MIN_VERSION_monad_logger(0, 3, 10) import Control.Monad.Logger (MonadLoggerIO (..)) #endif import Data.Semigroup (Semigroup) -- 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 :: !(Source (ResourceT IO) ByteString) , fileMove :: !(FilePath -> IO ()) } data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath) | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString)) -- | How to determine the root of the application for constructing URLs. -- -- Note that future versions of Yesod may add new constructors without bumping -- the major version number. As a result, you should /not/ pattern match on -- @Approot@ values. data Approot master = ApprootRelative -- ^ No application root. | ApprootStatic !Text | ApprootMaster !(master -> Text) | ApprootRequest !(master -> W.Request -> Text) type ResolvedApproot = Text data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text deriving (Eq, Show, Read) data ScriptLoadPosition master = BottomOfBody | BottomOfHeadBlocking | BottomOfHeadAsync (BottomOfHeadAsync master) type BottomOfHeadAsync master = [Text] -- ^ urls to load asynchronously -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head> type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } data RunHandlerEnv site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route site)) , rheSite :: !site , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheOnError :: !(ErrorResponse -> YesodApp) -- ^ How to respond when an error is thrown internally. -- -- Since 1.2.0 , rheMaxExpires :: !Text } data HandlerData site parentRoute = HandlerData { handlerRequest :: !YesodRequest , handlerEnv :: !(RunHandlerEnv site) , handlerState :: !(IORef GHState) , handlerToParent :: !(Route site -> parentRoute) , handlerResource :: !InternalState } data YesodRunnerEnv site = YesodRunnerEnv { yreLogger :: !Logger , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) , yreGen :: !MWC.GenIO , yreGetMaxExpires :: IO Text } data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv { ysreParentRunner :: !(ParentRunner parent parentMonad) , ysreGetSub :: !(parent -> sub) , ysreToParentRoute :: !(Route sub -> Route parent) , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner? } type ParentRunner parent m = m TypedContent -> YesodRunnerEnv parent -> Maybe (Route parent) -> W.Application -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. newtype HandlerT site m a = HandlerT { unHandlerT :: HandlerData site (MonadRoute m) -> m a } type family MonadRoute (m :: * -> *) type instance MonadRoute IO = () type instance MonadRoute (HandlerT site m) = (Route site) data GHState = GHState { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents , ghsIdent :: Int , ghsCache :: TypeMap , ghsCacheBy :: KeyedTypeMap , ghsHeaders :: Endo [Header] } -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as -- the 'HandlerT' monad and template haskell code should hide it away. type YesodApp = YesodRequest -> ResourceT IO YesodResponse -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for -- better error messages. newtype WidgetT site m a = WidgetT { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site)) } instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where mempty = return () mappend x y = x >> y instance (a ~ (), Monad m) => Semigroup (WidgetT site m a) -- | 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 (Monad m, a ~ ()) => IsString (WidgetT site m a) where fromString = toWidget . toHtml . T.pack where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x)) mempty mempty mempty mempty mempty mempty) type RY master = Route master -> [(Text, Text)] -> Text -- | Newtype wrapper allowing injection of arbitrary content into CSS. -- -- Usage: -- -- > toWidget $ CssBuilder "p { color: red }" -- -- Since: 1.1.3 newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent { pageTitle :: Html , pageHead :: HtmlUrl url , pageBody :: HtmlUrl url } data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length. | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder)) | ContentFile !FilePath !(Maybe FilePart) | ContentDontEvaluate !Content data TypedContent = TypedContent !ContentType !Content type RepHtml = Html {-# DEPRECATED RepHtml "Please use Html instead" #-} newtype RepJson = RepJson Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content type ContentType = ByteString -- FIXME Text? -- | Prevents a response body from being fully evaluated before sending the -- request. -- -- Since 1.1.0 newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } -- | Responses to indicate some form of an error occurred. data ErrorResponse = NotFound | InternalError Text | InvalidArgs [Text] | NotAuthenticated | PermissionDenied Text | BadMethod H.Method deriving (Show, Eq, Typeable, Generic) instance NFData ErrorResponse where rnf = genericRnf ----- header stuff -- | Headers to be added to a 'Result'. data Header = AddCookie SetCookie | DeleteCookie ByteString ByteString | Header ByteString ByteString deriving (Eq, Show) -- FIXME In the next major version bump, let's just add strictness annotations -- to Header (and probably everywhere else). We can also add strictness -- annotations to SetCookie in the cookie package. instance NFData Header where rnf (AddCookie x) = rnf x rnf (DeleteCookie x y) = x `seq` y `seq` () rnf (Header x y) = x `seq` y `seq` () data Location url = Local url | Remote Text deriving (Show, Eq) -- | A diff list that does not directly enforce uniqueness. -- When creating a widget Yesod will use nub to make it unique. newtype UniqueList x = UniqueList ([x] -> [x]) data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } deriving (Show, Eq) data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } newtype Head url = Head (HtmlUrl url) deriving Monoid instance Semigroup (Head a) newtype Body url = Body (HtmlUrl url) deriving Monoid instance Semigroup (Body a) type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder data GWData a = GWData { gwdBody :: !(Body a) , gwdTitle :: !(Last Title) , gwdScripts :: !(UniqueList (Script a)) , gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type , gwdJavascript :: !(Maybe (JavascriptUrl a)) , gwdHead :: !(Head a) } instance Monoid (GWData a) where mempty = GWData mempty mempty mempty mempty mempty mempty mempty mappend (GWData a1 a2 a3 a4 a5 a6 a7) (GWData b1 b2 b3 b4 b5 b6 b7) = GWData (a1 `mappend` b1) (a2 `mappend` b2) (a3 `mappend` b3) (a4 `mappend` b4) (unionWith mappend a5 b5) (a6 `mappend` b6) (a7 `mappend` b7) instance Semigroup (GWData a) data HandlerContents = HCContent H.Status !TypedContent | HCError ErrorResponse | HCSendFile ContentType FilePath (Maybe FilePart) | HCRedirect H.Status Text | HCCreated Text | HCWai W.Response | HCWaiApp W.Application deriving Typeable instance Show HandlerContents where show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t) show (HCError e) = "HCError " ++ show e show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp) show (HCRedirect s t) = "HCRedirect " ++ show (s, t) show (HCCreated t) = "HCCreated " ++ show t show (HCWai _) = "HCWai" show (HCWaiApp _) = "HCWaiApp" instance Exception HandlerContents -- Instances for WidgetT instance Monad m => Functor (WidgetT site m) where fmap = liftM instance Monad m => Applicative (WidgetT site m) where pure = return (<*>) = ap instance Monad m => Monad (WidgetT site m) where return a = WidgetT $ const $ return (a, mempty) WidgetT x >>= f = WidgetT $ \r -> do (a, wa) <- x r (b, wb) <- unWidgetT (f a) r return (b, wa `mappend` wb) instance MonadIO m => MonadIO (WidgetT site m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (WidgetT site m) where liftBase = WidgetT . const . liftBase . fmap (, mempty) instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where #if MIN_VERSION_monad_control(1,0,0) type StM (WidgetT site m) a = StM m (a, GWData (Route site)) liftBaseWith f = WidgetT $ \reader' -> liftBaseWith $ \runInBase -> fmap (\x -> (x, mempty)) (f $ runInBase . flip unWidgetT reader') restoreM = WidgetT . const . restoreM #else data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site))) liftBaseWith f = WidgetT $ \reader' -> liftBaseWith $ \runInBase -> fmap (\x -> (x, mempty)) (f $ fmap StW . runInBase . flip unWidgetT reader') restoreM (StW base) = WidgetT $ const $ restoreM base #endif instance Monad m => MonadReader site (WidgetT site m) where ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty) local f (WidgetT g) = WidgetT $ \hd -> g hd { handlerEnv = (handlerEnv hd) { rheSite = f $ rheSite $ handlerEnv hd } } instance MonadTrans (WidgetT site) where lift = WidgetT . const . liftM (, mempty) instance MonadThrow m => MonadThrow (WidgetT site m) where throwM = lift . throwM instance MonadCatch m => MonadCatch (HandlerT site m) where catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r instance MonadMask m => MonadMask (HandlerT site m) where mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e where q u (HandlerT b) = HandlerT (u . b) uninterruptibleMask a = HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e where q u (HandlerT b) = HandlerT (u . b) instance MonadCatch m => MonadCatch (WidgetT site m) where catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r instance MonadMask m => MonadMask (WidgetT site m) where mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e where q u (WidgetT b) = WidgetT (u . b) uninterruptibleMask a = WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e where q u (WidgetT b) = WidgetT (u . b) instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (WidgetT site m) where monadLoggerLog a b c d = WidgetT $ \hd -> liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d) #if MIN_VERSION_monad_logger(0, 3, 10) instance MonadIO m => MonadLoggerIO (WidgetT site m) where askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty) #endif instance MonadActive m => MonadActive (WidgetT site m) where monadActive = lift monadActive instance MonadActive m => MonadActive (HandlerT site m) where monadActive = lift monadActive instance MonadTrans (HandlerT site) where lift = HandlerT . const -- Instances for HandlerT instance Monad m => Functor (HandlerT site m) where fmap = liftM instance Monad m => Applicative (HandlerT site m) where pure = return (<*>) = ap instance Monad m => Monad (HandlerT site m) where return = HandlerT . const . return HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r instance MonadIO m => MonadIO (HandlerT site m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (HandlerT site m) where liftBase = lift . liftBase instance Monad m => MonadReader site (HandlerT site m) where ask = HandlerT $ return . rheSite . handlerEnv local f (HandlerT g) = HandlerT $ \hd -> g hd { handlerEnv = (handlerEnv hd) { rheSite = f $ rheSite $ handlerEnv hd } } -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- @fork@ function is incompatible with the underlying @ResourceT@ system. -- Instead, if you must fork a separate thread, you should use -- @resourceForkIO@. -- -- Using fork usually leads to an exception that says -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- after cleanup. Please contact the maintainers.\" instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where #if MIN_VERSION_monad_control(1,0,0) type StM (HandlerT site m) a = StM m a liftBaseWith f = HandlerT $ \reader' -> liftBaseWith $ \runInBase -> f $ runInBase . (\(HandlerT r) -> r reader') restoreM = HandlerT . const . restoreM #else data StM (HandlerT site m) a = StH (StM m a) liftBaseWith f = HandlerT $ \reader' -> liftBaseWith $ \runInBase -> f $ fmap StH . runInBase . (\(HandlerT r) -> r reader') restoreM (StH base) = HandlerT $ const $ restoreM base #endif instance MonadThrow m => MonadThrow (HandlerT site m) where throwM = lift . monadThrow instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (HandlerT site m) where monadLoggerLog a b c d = HandlerT $ \hd -> liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) #if MIN_VERSION_monad_logger(0, 3, 10) instance MonadIO m => MonadLoggerIO (HandlerT site m) where askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd)) #endif instance Monoid (UniqueList x) where mempty = UniqueList id UniqueList x `mappend` UniqueList y = UniqueList $ x . y instance Semigroup (UniqueList x) instance IsString Content where fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString instance RenderRoute WaiSubsite where data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] deriving (Show, Eq, Read, Ord) renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y data Logger = Logger { loggerSet :: !LoggerSet , loggerDate :: !DateCacheGetter } loggerPutStr :: Logger -> LogStr -> IO () loggerPutStr (Logger ls _) = pushLogStr ls ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Unsafe.hs��������������������������������������������������������������0000644�0000000�0000000�00000001562�12772120703�015577� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} -- | This is designed to be used as -- -- > qualified import 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 #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty, mappend) #endif import Control.Monad.IO.Class (MonadIO) -- | designed to be used as -- -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger fakeHandlerGetLogger :: (Yesod site, MonadIO m) => (site -> Logger) -> site -> HandlerT site IO a -> m a fakeHandlerGetLogger getLogger app f = runFakeHandler mempty getLogger app f >>= either (error . ("runFakeHandler issue: " `mappend`) . show) return ����������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Widget.hs��������������������������������������������������������������0000644�0000000�0000000�00000027127�12772120703�015606� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Core.Widget ( -- * Datatype WidgetT , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets , whamlet , whamletFile , ihamletToRepHtml , ihamletToHtml -- * Convert to Widget , ToWidget (..) , ToWidgetHead (..) , ToWidgetBody (..) , ToWidgetMedia (..) -- * Creating -- ** Head of page , setTitle , setTitleI -- ** CSS , addStylesheet , addStylesheetAttrs , addStylesheetRemote , addStylesheetRemoteAttrs , addStylesheetEither , CssBuilder (..) -- ** Javascript , addScript , addScriptAttrs , addScriptRemote , addScriptRemoteAttrs , addScriptEither -- * Subsites , widgetToParentWidget , handlerToWidget -- * Internal , whamletFileWithSettings , 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) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL import Yesod.Core.Types import Yesod.Core.Class.Handler preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup class ToWidget site a where toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidget site (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where toWidget = liftWidgetT instance ToWidget site Html where toWidget = toWidget . const -- | Allows adding some CSS to the page with a specific media type. -- -- Since 1.2 class ToWidgetMedia site a where -- | Add the given content to the page, but only for the given media type. -- -- Since 1.2 toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site) => Text -- ^ media value -> a -> m () instance render ~ RY site => ToWidgetMedia site (render -> Css) where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x instance ToWidgetMedia site Css where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget instance render ~ RY site => ToWidgetBody site (render -> Javascript) where toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetBody site Javascript where toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetBody site Html where toWidgetBody = toWidget class ToWidgetHead site a where toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget instance ToWidgetHead site Css where toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where toWidgetHead = toWidget instance ToWidgetHead site CssBuilder where toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> Javascript) where toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetHead site Javascript where toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetHead site Html where toWidgetHead = toWidgetHead . const -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: MonadWidget m => Html -> m () setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setTitleI msg = do mr <- getMessageRender setTitle $ toHtml $ mr msg -- | Link to the specified local stylesheet. addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet. addStylesheetAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: MonadWidget m => Text -> m () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetEither :: MonadWidget m => Either (Route (HandlerSite m)) Text -> m () addStylesheetEither = either addStylesheet addStylesheetRemote addScriptEither :: MonadWidget m => Either (Route (HandlerSite m)) Text -> m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. addScript :: MonadWidget m => Route (HandlerSite m) -> m () addScript = flip addScriptAttrs [] -- | Link to the specified local script. addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: MonadWidget m => Text -> m () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings whamletFile :: FilePath -> Q Exp whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp whamletFileWithSettings = NP.hamletFileWithSettings rules asWidgetT :: WidgetT site m () -> WidgetT site m () asWidgetT = id rules :: Q NP.HamletRules rules = do ah <- [|asWidgetT . toWidget|] let helper qg f = do x <- newName "urender" e <- f $ VarE x let e' = LamE [VarP x] e g <- qg bind <- [|(>>=)|] return $ InfixE (Just g) bind (Just e') let ur f = do let env = NP.Env (Just $ helper [|getUrlRenderParams|]) (Just $ helper [|fmap (toHtml .) getMessageRender|]) f env return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) => HtmlUrlI18n message (Route (HandlerSite m)) -> m Html ihamletToRepHtml = ihamletToHtml {-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-} -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- -- Since 1.2.1 ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) => HtmlUrlI18n message (Route (HandlerSite m)) -> m Html ihamletToHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender return $ ih (toHtml . mrender) urender tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () tell w = liftWidgetT $ WidgetT $ const $ return ((), w) toUnique :: x -> UniqueList x toUnique = UniqueList . (:) handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f widgetToParentWidget :: MonadIO m => WidgetT child IO a -> HandlerT child (HandlerT parent m) (WidgetT parent m a) widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do (a, gwd) <- liftIO $ f hd { handlerToParent = const () } return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd) liftGWD :: (child -> parent) -> GWData child -> GWData parent liftGWD tp gwd = GWData { gwdBody = fixBody $ gwdBody gwd , gwdTitle = gwdTitle gwd , gwdScripts = fixUnique fixScript $ gwdScripts gwd , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd , gwdCss = fixCss <$> gwdCss gwd , gwdJavascript = fixJS <$> gwdJavascript gwd , gwdHead = fixHead $ gwdHead gwd } where fixRender f route = f (tp route) fixBody (Body h) = Body $ h . fixRender fixHead (Head h) = Head $ h . fixRender fixUnique go (UniqueList f) = UniqueList (map go (f []) ++) fixScript (Script loc attrs) = Script (fixLoc loc) attrs fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs fixLoc (Local url) = Local $ tp url fixLoc (Remote t) = Remote t fixCss f = f . fixRender fixJS f = f . fixRender �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Class/�����������������������������������������������������������������0000755�0000000�0000000�00000000000�12772120703�015063� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Class/Breadcrumbs.hs���������������������������������������������������0000644�0000000�0000000�00000002172�12772120703�017652� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE OverloadedStrings #-} module Yesod.Core.Class.Breadcrumbs where import Yesod.Core.Handler import Yesod.Routes.Class import Data.Text (Text) -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). class YesodBreadcrumbs site where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page. breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of Nothing -> return ("Not found", []) Just y -> do (title, next) <- breadcrumb y z <- go [] next return (title, z) where go back Nothing = return back go back (Just this) = do (title, next) <- breadcrumb this go ((this, title) : back) next ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Class/Dispatch.hs������������������������������������������������������0000644�0000000�0000000�00000003342�12772120703�017160� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Dispatch where import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Core.Types import Yesod.Core.Content import Yesod.Core.Handler (stripHandlerT) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Handler -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application class YesodSubDispatch sub m where yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m -> W.Application instance YesodSubDispatch WaiSubsite master where yesodSubDispatch YesodSubRunnerEnv {..} = app where WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. This function has been exported since 1.4.11. -- It promotes a subsite handler to a wai application. subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained. => HandlerT child (HandlerT parent m) TypedContent -> YesodSubRunnerEnv child parent (HandlerT parent m) -> Maybe (Route child) -> W.Application subHelper handlert YesodSubRunnerEnv {..} route = ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) where base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Class/Handler.hs�������������������������������������������������������0000644�0000000�0000000�00000006752�12772120703�017006� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Class.Handler ( MonadHandler (..) , MonadWidget (..) ) where import Yesod.Core.Types import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase) import Control.Monad.Trans.Class (lift) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid, mempty) #endif import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT, Error) #if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except ( ExceptT ) #endif import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) class MonadResource m => MonadHandler m where type HandlerSite m liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a replaceToParent :: HandlerData site route -> HandlerData site () replaceToParent hd = hd { handlerToParent = const () } instance MonadResourceBase m => MonadHandler (HandlerT site m) where type HandlerSite (HandlerT site m) = site liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent {-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} instance MonadResourceBase m => MonadHandler (WidgetT site m) where type HandlerSite (WidgetT site m) = site liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent {-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-} #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) #if MIN_VERSION_transformers(0,4,0) GO(ExceptT e) #endif 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 liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a instance MonadResourceBase m => MonadWidget (WidgetT site m) where liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) #if MIN_VERSION_transformers(0,4,0) GO(ExceptT e) #endif 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.4.25/Yesod/Core/Class/Yesod.hs���������������������������������������������������������0000644�0000000�0000000�00000111225�12772120703�016504� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Yesod.Core.Class.Yesod where import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class import Blaze.ByteString.Builder (Builder, toByteString) import Blaze.ByteString.Builder.ByteString (copyByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar) import Control.Arrow ((***), second) import Control.Exception (bracket) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif 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.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, renderQueryText) import qualified Network.Wai as W import Data.Default (def) import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import Network.Wai.Logger (ZonedDate, clockDateCacher) import System.Log.FastLogger import Text.Blaze (customAttribute, textTag, toValue, (!), 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) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget import Control.Monad.Trans.Class (lift) import Data.CaseInsensitive (CI) import qualified Network.Wai.Request -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute site => Yesod site where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- -- Default value: 'ApprootRelative'. This is valid under the following -- conditions: -- -- * Your application is served from the root of the domain. -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. -- -- If this is not true, you should override with a different -- implementation. approot :: Approot site approot = ApprootRelative -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. defaultLayout :: WidgetT site IO () -> HandlerT site IO Html defaultLayout w = do p <- widgetToPageContent w msgs <- getMessages withUrlRenderer [hamlet| $newline never $doctype 5 <html> <head> <title>#{pageTitle p} ^{pageHead p} <body> $forall (status, msg) <- msgs <p class="message #{status}">#{msg} ^{pageBody p} |] -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. urlRenderOverride :: site -> Route site -> Maybe Builder urlRenderOverride _ _ = Nothing -- | 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 y route params = addParams params <$> urlRenderOverride y route where addParams [] routeBldr = routeBldr addParams nonEmptyParams routeBldr = let routeBS = toByteString routeBldr qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?' valueToMaybe t = if t == "" then Nothing else Just t queryText = map (id *** valueToMaybe) nonEmptyParams in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText -- | Determine if a request is authorized or not. -- -- Return 'Authorized' if the request is authorized, -- 'Unauthorized' a message if unauthorized. -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route site -> Bool -- ^ is this a write request? -> HandlerT site IO AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default, -- this assumes you are following RESTful principles, and determines this -- from request method. In particular, all except the following request -- methods are considered write: GET HEAD OPTIONS TRACE. -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'. isWriteRequest :: Route site -> HandlerT site IO Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] -- | The default route for authentication. -- -- Used in particular by 'isAuthorized', but library users can do whatever -- they want with it. authRoute :: site -> Maybe (Route site) authRoute _ = Nothing -- | A function used to clean up path segments. It returns 'Right' with a -- clean path or 'Left' with a new set of pieces the user should be -- redirected to. The default implementation enforces: -- -- * No double slashes -- -- * There is no trailing slash. -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. cleanPath :: site -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . T.null) s dropDash t | T.all (== '-') t = T.drop 1 t | otherwise = t -- | Builds an absolute URL by concatenating the application root with the -- pieces of a path and a query string, if any. -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. joinPath :: site -> T.Text -- ^ application root -> [T.Text] -- ^ path pieces -> [(T.Text, T.Text)] -- ^ query string -> Builder joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x addDash t | T.all (== '-') t = T.cons '-' t | otherwise = t -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and -- JavaScript content in an external file; the "Yesod.Widget" module uses -- this feature. -- -- The return value is 'Nothing' if no storing was performed; this is the -- default implementation. A 'Just' 'Left' gives the absolute URL of the -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is -- necessary when you are serving the content outside the context of a -- Yesod application, such as via memcached. addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Maximum allowed length of the request body, in bytes. -- -- If @Nothing@, no maximum is applied. -- -- Default: 2 megabytes. maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64 maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes -- | Creates a @Logger@ to use for log messages. -- -- Note that a common technique (endorsed by the scaffolding) is to create -- a @Logger@ value and place it in your foundation datatype, and have this -- method return that already created value. That way, you can use that -- same @Logger@ for printing messages during app initialization. -- -- Default: the 'defaultMakeLogger' function. makeLogger :: site -> IO Logger makeLogger _ = defaultMakeLogger -- | Send a message to the @Logger@ provided by @getLogger@. -- -- Default: the 'defaultMessageLoggerSource' function, using -- 'shouldLogIO' to check whether we should log. messageLoggerSource :: site -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site -- | Where to Load sripts from. We recommend the default value, -- 'BottomOfBody'. jsLoader :: site -> ScriptLoadPosition site jsLoader _ = BottomOfBody -- | Create a session backend. Returning 'Nothing' disables -- sessions. If you'd like to change the way that the session -- cookies are created, take a look at -- 'customizeSessionCookies'. -- -- Default: Uses clientsession with a 2 hour timeout. makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile -- | How to store uploaded files. -- -- Default: When the request body is greater than 50kb, store in a temp -- file. For chunked request bodies, store in a temp file. Otherwise, store -- in memory. fileUpload :: site -> W.RequestBodyLength -> FileUpload fileUpload _ (W.KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd -- | Should we log the given log source/level combination. -- -- Default: the 'defaultShouldLog' function. shouldLog :: site -> LogSource -> LogLevel -> Bool shouldLog _ = defaultShouldLog -- | Should we log the given log source/level combination. -- -- Note that this is almost identical to @shouldLog@, except the result -- lives in @IO@. This allows you to dynamically alter the logging level of -- your application by having this result depend on, e.g., an @IORef@. -- -- The default implementation simply uses @shouldLog@. Future versions of -- Yesod will remove @shouldLog@ and use this method exclusively. -- -- Since 1.2.4 shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool shouldLogIO a b c = return (shouldLog a b c) -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- -- Default: the 'defaultYesodMiddleware' function. -- -- Since: 1.1.6 yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res yesodMiddleware = defaultYesodMiddleware -- | How to allocate an @InternalState@ for each request. -- -- The default implementation is almost always what you want. However, if -- you know that you are never taking advantage of the @MonadResource@ -- instance in your handler functions, setting this to a dummy -- implementation can provide a small optimization. Only do this if you -- really know what you're doing, otherwise you can turn safe code into a -- runtime error! -- -- Since 1.4.2 yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a yesodWithInternalState _ _ = bracket createInternalState closeInternalState {-# INLINE yesodWithInternalState #-} {-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-} -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write. -- -- Since 1.4.10 defaultMakeLogger :: IO Logger defaultMakeLogger = do loggerSet' <- newStdoutLoggerSet defaultBufSize (getter, _) <- clockDateCacher return $! Logger loggerSet' getter -- | Default implementation of 'messageLoggerSource'. Checks if the -- message should be logged using the provided function, and if so, -- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO' -- as the provided function. -- -- Since 1.4.10 defaultMessageLoggerSource :: (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should -- log this -> Logger -> Loc -- ^ position in source code -> LogSource -> LogLevel -> LogStr -- ^ message -> IO () defaultMessageLoggerSource ckLoggable logger loc source level msg = do loggable <- ckLoggable source level when loggable $ formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger -- | Default implementation of 'shouldLog'. Logs everything at or -- above 'LevelInfo'. -- -- Since 1.4.10 defaultShouldLog :: LogSource -> LogLevel -> Bool defaultShouldLog _ level = level >= LevelInfo -- | A default implementation of 'shouldLogIO' that can be used with -- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'. -- -- Since 1.4.10 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool defaultShouldLogIO a b = return $ defaultShouldLog a b -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- -- Since 1.2.0 defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language" authorizationCheck handler -- | Defends against session hijacking by setting the secure bit on session -- cookies so that browsers will not transmit them over http. With this -- setting on, it follows that the server will regard requests made over -- http as sessionless, because the session cookie will not be included in -- the request. Use this as part of a total security measure which also -- includes disabling HTTP traffic to the site or issuing redirects from -- HTTP urls, and composing 'sslOnlyMiddleware' with the site's -- 'yesodMiddleware'. -- -- Since 1.4.7 sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) sslOnlySessions = (fmap . fmap) secureSessionCookies where setSecureBit cookie = cookie { setCookieSecure = True } secureSessionCookies = customizeSessionCookies setSecureBit -- | 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 :: Yesod site => Int -- ^ minutes -> HandlerT site IO res -> HandlerT site IO res sslOnlyMiddleware timeout handler = do addHeader "Strict-Transport-Security" $ T.pack $ concat [ "max-age=" , show $ timeout * 60 , "; includeSubDomains" ] handler -- | Check if a given request is authorized via 'isAuthorized' and -- 'isWriteRequest'. -- -- Since 1.2.0 authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck = 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 => HandlerT site IO res -> HandlerT site IO 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 :: Yesod site => HandlerT site IO res -> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from. -> HandlerT site IO res csrfCheckMiddleware handler shouldCheckFn headerName paramName = do shouldCheck <- shouldCheckFn when shouldCheck (checkCsrfHeaderOrParam headerName paramName) handler -- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'. -- -- The cookie's path is set to @/@, making it valid for your whole website. -- -- Since 1.4.14 defaultCsrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO 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 :: Yesod site => HandlerT site IO res -> SetCookie -> HandlerT site IO 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 add this 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 => HandlerT site IO res -> HandlerT site IO res defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route site), Yesod site) => WidgetT site IO () -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do master <- getYesod hd <- HandlerT return ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd let title = maybe mempty unTitle mTitle scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p css <- forM (Map.toList style) $ \(mmedia, content) -> do let rendered = toLazyText $ content render x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered return (mmedia, case x of Nothing -> Left $ preEscapedToMarkup rendered Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc regularScriptLoad = [hamlet| $newline never $forall s <- scripts ^{mkScriptTag s} $maybe j <- jscript $maybe s <- jsLoc <script src="#{s}"> $nothing <script>^{jelper j} |] headAll = [hamlet| $newline never \^{head'} $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css $maybe t <- right $ snd s $maybe media <- fst s <link rel=stylesheet media=#{media} href=#{t}> $nothing <link rel=stylesheet href=#{t}> $maybe content <- left $ snd s $maybe media <- fst s <style media=#{media}>#{content} $nothing <style>#{content} $case jsLoader master $of BottomOfBody $of BottomOfHeadAsync asyncJsLoader ^{asyncJsLoader asyncScripts mcomplete} $of BottomOfHeadBlocking ^{regularScriptLoad} |] let bodyScript = [hamlet| $newline never ^{body} ^{regularScriptLoad} |] return $ PageContent title headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body where renderLoc' render' (Local url) = render' url [] renderLoc' _ (Remote s) = s addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) mkScriptTag (Script loc attrs) render' = foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () mkLinkTag (Stylesheet loc attrs) render' = foldl' addAttr TBH.link ( ("rel", "stylesheet") : ("href", renderLoc' render' loc) : attrs ) runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r setTitle "Not Found" toWidget [hamlet| <h1>Not Found <p>#{path'} |] provideRep $ return $ object ["message" .= ("Not Found" :: Text)] -- For API requests. -- For a user with a browser, -- if you specify an authRoute the user will be redirected there and -- this page will not be shown. defaultErrorHandler NotAuthenticated = selectRep $ do provideRep $ defaultLayout $ do setTitle "Not logged in" toWidget [hamlet| <h1>Not logged in <p style="display:none;">Set the authRoute and the user will be redirected there. |] provideRep $ do -- 401 *MUST* include a WWW-Authenticate header -- however, there is no standard to indicate a redirection -- -- change this to Basic or Digest if you allow those forms of authentications addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\"" -- The client will just use the authentication_url in the JSON site <- getYesod rend <- getUrlRender let apair u = ["authentication_url" .= rend u] content = maybe [] apair (authRoute site) return $ object $ ("message" .= ("Not logged in"::Text)):content defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Permission Denied" toWidget [hamlet| <h1>Permission denied <p>#{msg} |] provideRep $ return $ object ["message" .= ("Permission Denied. " <> msg)] defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Invalid Arguments" toWidget [hamlet| <h1>Invalid Arguments <ul> $forall msg <- ia <li>#{msg} |] provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia] defaultErrorHandler (InternalError e) = do $logErrorS "yesod-core" e selectRep $ do provideRep $ defaultLayout $ do setTitle "Internal Server Error" toWidget [hamlet| <h1>Internal Server Error <pre>#{e} |] provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e] defaultErrorHandler (BadMethod m) = selectRep $ do provideRep $ defaultLayout $ do setTitle"Bad Method" toWidget [hamlet| <h1>Method Not Supported <p>Method <code>#{S8.unpack m}</code> not supported |] provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= 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" } 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 = Map.unions $ 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 maybe [] return $ decodeClientSession key date host val save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV return [AddCookie def { setCookieName = sessionName , setCookieValue = encodeClientSession key iv date host sess' , setCookiePath = Just "/" , setCookieExpires = Just (csdcExpires date) , setCookieDomain = Nothing , setCookieHttpOnly = True }] where host = "" -- fixme, properly lock sessions to client address -- taken from file-location package -- turn the TH Loc loaction information into a human readable string -- leaving out the loc_end parameter fileLocationToString :: Loc -> String fileLocationToString loc = 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.4.25/Yesod/Core/Internal/��������������������������������������������������������������0000755�0000000�0000000�00000000000�12772120703�015572� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Internal/LiteApp.hs����������������������������������������������������0000644�0000000�0000000�00000004756�12772120703�017500� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-} module Yesod.Core.Internal.LiteApp where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #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 Monoid LiteApp where mempty = LiteApp $ \_ _ -> Nothing mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps type LiteHandler = HandlerT LiteApp IO type LiteWidget = WidgetT LiteApp IO liteApp :: Writer LiteApp () -> LiteApp liteApp = execWriter dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp () dispatchTo handler = tell $ LiteApp $ \_ ps -> if null ps then Just $ fmap toTypedContent handler else Nothing onMethod :: Method -> Writer LiteApp () -> Writer LiteApp () onMethod method f = tell $ LiteApp $ \m ps -> if method == m then unLiteApp (liteApp f) m ps else Nothing onStatic :: Text -> Writer LiteApp () -> Writer LiteApp () onStatic p0 f = tell $ LiteApp $ \m ps0 -> case ps0 of p:ps | p == p0 -> unLiteApp (liteApp f) m ps _ -> Nothing withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp () withDynamic f = tell $ LiteApp $ \m ps0 -> case ps0 of p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps _ -> Nothing withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp () withDynamicMulti f = tell $ LiteApp $ \m ps -> case fromPathMultiPiece ps of Nothing -> Nothing Just v -> unLiteApp (liteApp $ f v) m [] ������������������yesod-core-1.4.25/Yesod/Core/Internal/Request.hs����������������������������������������������������0000644�0000000�0000000�00000015522�12772120703�017563� 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 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 Data.Conduit import Data.Conduit.List (sourceList) import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word8, Word64) import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Exception (throwIO) import Control.Monad ((<=<), liftM) import Yesod.Core.Types import qualified Data.Map as Map import Data.IORef import qualified System.Random.MWC as MWC import Control.Monad.Primitive (PrimMonad, PrimState) 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 else do writeIORef ref remaining' return bs } tooLargeResponse :: W.Response tooLargeResponse = W.responseLBS (Status 413 "Too Large") [("Content-Type", "text/plain")] "Request body too large to be processed." parseWaiRequest :: W.Request -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size -> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest) parseWaiRequest env session useToken mmaxBodySize = -- In most cases, we won't need to generate any random values. Therefore, -- we split our results: if we need a random generator, return a Right -- value, otherwise return a Left and avoid the relatively costly generator -- acquisition. case etoken of Left token -> Left $ mkRequest token Right mkToken -> Right $ mkRequest <=< mkToken where mkRequest token' = do envLimited <- maybe return limitRequestBody mmaxBodySize env return YesodRequest { reqGetParams = gets , reqCookies = cookies , reqWaiRequest = envLimited , reqLangs = langs'' , reqToken = token' , reqSession = if useToken then Map.delete tokenKey session else session , reqAccept = httpAccept env } gets = textQueryString env reqCookie = lookup "Cookie" $ W.requestHeaders env cookies = maybe [] parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k -- The language preferences are prioritized as follows: langs' = catMaybes [ lookup langKey gets -- Query _LANG , lookup langKey cookies -- Cookie _LANG , lookupText langKey session -- Session _LANG ] ++ langs -- Accept-Language(s) -- Github issue #195. We want to add an extra two-letter version of any -- language in the list. langs'' = addTwoLetters (id, Set.empty) langs' -- If sessions are disabled tokens should not be used (any -- tokenKey present in the session is ignored). If sessions -- are enabled and a session has no tokenKey a new one is -- generated. etoken | useToken = case Map.lookup tokenKey session of -- Already have a token, use it. Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs -- Don't have a token, get a random generator and make a new one. Nothing -> Right $ fmap Just . randomString 10 | otherwise = Left Nothing textQueryString :: W.Request -> [(Text, Text)] textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString -- | Get the list of accepted content types from the WAI Request\'s Accept -- header. -- -- Since 1.2.0 httpAccept :: W.Request -> [ContentType] httpAccept = NWP.parseHttpAccept . fromMaybe S8.empty . lookup "Accept" . W.requestHeaders addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] = filter (`Set.notMember` exist) $ toAdd [] addTwoLetters (toAdd, exist) (l:ls) = l : addTwoLetters (toAdd', exist') ls where (toAdd', exist') | T.length l > 2 = (toAdd . (T.take 2 l:), exist) | otherwise = (toAdd, Set.insert l exist) -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given -- random number generator. randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text randomString len gen = liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar where asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen toAscii i | i < 26 = i + Word8._A | i < 52 = i + Word8._a - 26 | otherwise = i + Word8._0 - 52 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 (sourceList $ L.toChunks lbs) (`L.writeFile` lbs) mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst) mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) tokenKey :: IsString a => a tokenKey = "_TOKEN" langKey :: IsString a => a langKey = "_LANG" ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Internal/Response.hs���������������������������������������������������0000644�0000000�0000000�00000011363�12772120703�017730� 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 Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Network.Wai import Control.Monad (mplus) import Control.Monad.Trans.Resource (runInternalState, InternalState) import Network.Wai.Internal #if !MIN_VERSION_base(4, 6, 0) import Prelude hiding (catch) #endif import Web.Cookie (renderSetCookie) import Yesod.Core.Content import Yesod.Core.Types import qualified Network.HTTP.Types as H import qualified Data.Text as T import Control.Exception (SomeException, handle) import Blaze.ByteString.Builder (fromLazyByteString, toLazyByteString, toByteString) 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 Data.Conduit (Flush (..), ($$), transPipe) import qualified Data.Conduit.List as CL 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 -> transPipe (`runInternalState` is) body $$ CL.mapM_ (\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", toByteString $ renderSetCookie sc) headerToPair (DeleteCookie key path) = ( "Set-Cookie" , S.concat [ key , "=; path=" , path , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] ) headerToPair (Header key value) = (CI.mk key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b len = L.length lbs mlen' = mlen `mplus` Just (fromIntegral len) len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen') where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show evaluateContent c = return (Right c) getStatus :: ErrorResponse -> H.Status getStatus NotFound = H.status404 getStatus (InternalError _) = H.status500 getStatus (InvalidArgs _) = H.status400 getStatus NotAuthenticated = H.status401 getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Internal/Run.hs��������������������������������������������������������0000644�0000000�0000000�00000035760�12772120703�016705� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Internal.Run where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid, mempty) import Control.Applicative ((<$>)) #endif import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) import Control.Exception (fromException, evaluate) import qualified Control.Exception as E 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) -- | Catch all synchronous exceptions, ignoring asynchronous -- exceptions. -- -- Ideally we'd use this from a different library catchSync :: IO a -> (E.SomeException -> IO a) -> IO a catchSync thing after = thing `E.catch` \e -> if isAsyncException e then E.throwIO e else after e -- | Determine if an exception is asynchronous -- -- Also worth being upstream isAsyncException :: E.SomeException -> Bool isAsyncException e = case fromException e of Just E.SomeAsyncException{} -> True Nothing -> False -- | Convert an exception into an ErrorResponse toErrorHandler :: E.SomeException -> IO ErrorResponse toErrorHandler e0 = flip catchSync errFromShow $ case fromException e0 of Just (HCError x) -> evaluate $!! x _ | isAsyncException e0 -> E.throwIO e0 | otherwise -> errFromShow e0 -- | Generate an @ErrorResponse@ based on the shown version of the exception errFromShow :: E.SomeException -> IO ErrorResponse errFromShow x = evaluate $!! InternalError $! T.pack $! show x -- | 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 -> HandlerT site IO 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' <- catchSync (do res <- unHandlerT 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 , handlerToParent = const () , handlerResource = resState } -- | Convert an @ErrorResponse@ into a @YesodResponse@ handleError :: RunHandlerEnv 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) `catchSync` errFromShow -- Generate a response, leveraging the updated session and -- response headers flip runInternalState resState $ do yar <- rheOnError rhe e yreq { reqSession = finalSession } case yar of YRPlain status' hs ct c sess -> let hs' = headers ++ hs status | status' == defaultStatus = getStatus e | otherwise = status' in return $ YRPlain status hs' ct c sess YRWai _ -> return yar YRWaiApp _ -> return yar -- | Convert a @HandlerContents@ into a @YesodResponse@ handleContents :: (ErrorResponse -> IO YesodResponse) -> Map.Map Text S8.ByteString -> [Header] -> HandlerContents -> IO YesodResponse handleContents handleError' finalSession headers contents = case contents of HCContent status (TypedContent ct c) -> do -- Check for impure exceptions hiding in the contents ec' <- evaluateContent c case ec' of Left e -> handleError' e Right c' -> return $ YRPlain status headers ct c' finalSession HCError e -> handleError' e HCRedirect status loc -> do let disable_caching x = Header "Cache-Control" "no-cache, must-revalidate" : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" : x hs = (if status /= H.movedPermanently301 then disable_caching else id) $ Header "Location" (encodeUtf8 loc) : headers return $ YRPlain status hs typePlain emptyContent finalSession HCSendFile ct fp p -> return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession HCCreated loc -> return $ YRPlain H.status201 (Header "Location" (encodeUtf8 loc) : headers) typePlain emptyContent finalSession HCWai r -> return $ YRWai r HCWaiApp a -> return $ YRWaiApp a -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value. evalFallback :: (Monoid w, NFData w) => HandlerContents -> w -> IO (w, HandlerContents) evalFallback contents val = catchSync (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) -- | Function used internally by Yesod in the process of converting a -- 'HandlerT' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c => RunHandlerEnv site -> HandlerT site IO c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do -- Get the raw state and original contents (state, contents0) <- basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents (finalSession, contents1) <- evalFallback contents0 (ghsSession state) (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) -- Convert the HandlerContents into the final YesodResponse handleContents (handleError rhe yreq resState finalSession headers) finalSession headers contents2 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse -> YesodApp safeEh log' er req = do liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError $ toLogStr $ "Error handler errored out: " ++ show er return $ YRPlain H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString)) (reqSession req) -- | Run a 'HandlerT' completely outside of Yesod. This -- function comes with many caveats and you shouldn't use it -- unless you fully understand what it's doing and how it works. -- -- As of now, there's only one reason to use this function at -- all: in order to run unit tests of functions inside 'HandlerT' -- but that aren't easily testable with a full HTTP request. -- Even so, it's better to use @wai-test@ or @yesod-test@ instead -- of using this function. -- -- This function will create a fake HTTP request (both @wai@'s -- 'Request' and @yesod@'s 'Request') and feed it to the -- @HandlerT@. The only useful information the @HandlerT@ may -- get from the request is the session map, which you must supply -- as argument to @runFakeHandler@. All other fields contain -- fake information, which means that they can be accessed but -- won't have any useful information. The response of the -- @HandlerT@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the -- @HandlerT@'s return value. runFakeHandler :: (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site -> HandlerT site IO a -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") maxExpires <- getCurrentMaxExpiresRFC1123 let handler' = liftIO . I.writeIORef ret . Right =<< handler let yapp = runHandler RunHandlerEnv { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing , rheSite = site , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires } handler' errHandler err req = do liftIO $ I.writeIORef ret (Left err) return $ YRPlain H.status500 [] typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req) fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = "" , requestHeaderHost = Nothing , requestHeaders = [] , isSecure = False , remoteHost = error "runFakeHandler-remoteHost" , pathInfo = ["runFakeHandler", "pathInfo"] , queryString = [] , requestBody = return mempty , vault = mempty , requestBodyLength = KnownLength 0 , requestHeaderRange = Nothing #if MIN_VERSION_wai(3,2,0) , requestHeaderReferer = Nothing , requestHeaderUserAgent = Nothing #endif } fakeRequest = YesodRequest { reqGetParams = [] , reqCookies = [] , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) , reqAccept = [] , reqSession = fakeSessionMap } _ <- runResourceT $ yapp fakeRequest I.readIORef ret yesodRunner :: (ToTypedContent res, Yesod site) => HandlerT site IO res -> YesodRunnerEnv site -> Maybe (Route site) -> Application yesodRunner handler' YesodRunnerEnv {..} route req sendResponse | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse | otherwise = do let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend maxExpires <- yreGetMaxExpires let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let yreq = case mkYesodReq of Left yreq' -> yreq' Right needGen -> needGen yreGen let ra = resolveApproot yreSite req let log' = messageLoggerSource yreSite yreLogger -- We set up two environments: the first one has a "safe" error handler -- which will never throw an exception. The second one uses the -- user-provided errorHandler function. If that errorHandler function -- errors out, it will use the safeEh below to recover. rheSafe = RunHandlerEnv { rheRender = yesodRender yreSite ra , rheRoute = route , rheSite = yreSite , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler } yesodWithInternalState yreSite route $ \is -> do yreq' <- yreq yar <- runInternalState (runHandler rhe handler yreq') is yarToResponse yar saveSession yreq' req is sendResponse where mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' yesodRender :: Yesod y => y -> ResolvedApproot -> Route y -> [(Text, Text)] -- ^ url query string -> Text yesodRender y ar url params = decodeUtf8With lenientDecode $ toByteString $ 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.4.25/Yesod/Core/Internal/Session.hs����������������������������������������������������0000644�0000000�0000000�00000004543�12772120703�017557� 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.4.25/Yesod/Core/Internal/TH.hs���������������������������������������������������������0000644�0000000�0000000�00000017074�12772120703�016452� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} 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') #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (replicateM, void) import Data.Either (partitionEithers) import Yesod.Routes.TH import Yesod.Routes.Parse import Yesod.Core.Types import Yesod.Core.Content import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return mkYesodWith :: String -> [Either String [String]] -> [ResourceTree String] -> Q [Dec] mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral 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 = mkYesodDataGeneral name False mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] mkYesodSubData name = mkYesodDataGeneral name True mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do let (name':rest) = words name fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] masterTypeSyns vs site = [ TySynD (mkName "Handler") (fmap PlainTV vs) $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO , TySynD (mkName "Widget") (fmap PlainTV vs) $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() ] -- | 'Left' arguments indicate a monomorphic type, a 'Right' argument -- indicates a polymorphic type, and provides the list of classes -- the type must be instance of. mkYesodGeneral :: String -- ^ foundation type -> [Either String [String]] -- ^ arguments for the type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral namestr args isSub f resS = do mname <- lookupTypeName namestr arity <- case mname of Just name -> do info <- reify name return $ case info of TyConI dec -> case dec of #if MIN_VERSION_template_haskell(2,11,0) DataD _ _ vs _ _ _ -> length vs NewtypeD _ _ vs _ _ _ -> length vs #else DataD _ _ vs _ _ -> length vs NewtypeD _ _ vs _ _ -> length vs #endif _ -> 0 _ -> 0 _ -> return 0 let name = mkName namestr (mtys,_) = partitionEithers args -- Generate as many variable names as the arity indicates vns <- replicateM (arity - length mtys) $ newName "t" -- Base type (site type with variables) let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $ foldr (\arg (xs,n:ns,cs) -> case arg of Left t -> ( ConT (mkName t):xs, n:ns, cs ) Right ts -> ( VarT n :xs, ns , fmap (\t -> #if MIN_VERSION_template_haskell(2,10,0) AppT (ConT $ mkName t) (VarT n) #else ClassP (mkName t) [VarT n] #endif ) ts ++ cs ) ) ([],vns,[]) args site = foldl' AppT (ConT name) argtypes res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res dispatchDec <- mkDispatchInstance site cxt f res parse <- mkParseRouteInstance 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 [ [parse] , renderRouteDec , [routeAttrsDec] , resourcesDec , if isSub then [] else masterTypeSyns vns site ] return (dataDec, dispatchDec) mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh , mdsSubDispatcher = [|\parentRunner getSub toParent env -> yesodSubDispatch YesodSubRunnerEnv { ysreParentRunner = parentRunner , ysreGetSub = getSub , ysreToParentRoute = toParent , ysreParentEnv = env } |] , mdsGetPathInfo = [|W.pathInfo|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsMethod = [|W.requestMethod|] , mds404 = [|void notFound|] , mds405 = [|void badMethod|] , mdsGetHandler = defaultGetHandler , mdsUnwrapper = f } -- | If the generation of @'YesodDispatch'@ instance require finer -- control of the types, contexts etc. using this combinator. You will -- hardly need this generality. However, in certain situations, like -- when writing library/plugin for yesod, this combinator becomes -- handy. mkDispatchInstance :: Type -- ^ The master site type -> Cxt -- ^ Context of the instance -> (Exp -> Q Exp) -- ^ Unwrap handler -> [ResourceTree c] -- ^ The resource -> DecsQ mkDispatchInstance master cxt f res = do clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res let thisDispatch = FunD 'yesodDispatch [clause'] return [instanceD cxt yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res inner <- newName "inner" let innerFun = FunD inner [clause'] helper <- newName "helper" let fun = FunD helper [ Clause [] (NormalB $ VarE inner) [innerFun] ] return $ LetE [fun] (VarE helper) instanceD :: Cxt -> Type -> [Dec] -> Dec #if MIN_VERSION_template_haskell(2,11,0) instanceD = InstanceD Nothing #else instanceD = InstanceD #endif ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Core/Internal/Util.hs�������������������������������������������������������0000644�0000000�0000000�00000003606�12772120703�017050� 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) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif 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.4.25/Yesod/Routes/���������������������������������������������������������������������0000755�0000000�0000000�00000000000�12772120703�014407� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Routes/Class.hs�������������������������������������������������������������0000644�0000000�0000000�00000001746�12772120703�016020� 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.4.25/Yesod/Routes/Overlap.hs�����������������������������������������������������������0000644�0000000�0000000�00000005066�12772120703�016362� 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.4.25/Yesod/Routes/Parse.hs�������������������������������������������������������������0000644�0000000�0000000�00000020533�12772120703�016020� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter module Yesod.Routes.Parse ( parseRoutes , parseRoutesFile , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType , parseTypeTree , TypeTree (..) ) where import Language.Haskell.TH.Syntax import Data.Char (isUpper) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames) import Data.List (foldl', isPrefixOf) import Data.Maybe (mapMaybe) import qualified Data.Set as Set -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the -- checking. See documentation site for details on syntax. parseRoutes :: QuasiQuoter parseRoutes = QuasiQuoter { quoteExp = x } where x s = do let res = resourcesFromString s case findOverlapNames res of [] -> lift res z -> error $ unlines $ "Overlapping routes: " : map show z parseRoutesFile :: FilePath -> Q Exp parseRoutesFile = parseRoutesFileWith parseRoutes parseRoutesFileNoCheck :: FilePath -> Q Exp parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp parseRoutesFileWith qq fp = do qAddDependentFile fp s <- qRunIO $ readUtf8File fp quoteExp qq s readUtf8File :: FilePath -> IO String readUtf8File fp = do h <- SIO.openFile fp SIO.ReadMode SIO.hSetEncoding h SIO.utf8_bom SIO.hGetContents h -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter { quoteExp = lift . resourcesFromString } -- | Converts a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input. resourcesFromString :: String -> [ResourceTree String] resourcesFromString = fst . parse 0 . filter (not . all (== ' ')) . lines 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 "--") $ words 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 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 '-' $ 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) = ConT $ mkName s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 pieceFromString ('#':x) = Right $ (True, Dynamic 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) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Routes/TH.hs����������������������������������������������������������������0000644�0000000�0000000�00000000664�12772120703�015264� 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.4.25/Yesod/Routes/TH/������������������������������������������������������������������0000755�0000000�0000000�00000000000�12772120703�014722� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Routes/TH/Dispatch.hs�������������������������������������������������������0000644�0000000�0000000�00000017404�12772120703�017023� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch ( MkDispatchSettings (..) , mkDispatchClause , defaultGetHandler ) where import Prelude hiding (exp) import Language.Haskell.TH.Syntax import Web.PathPieces import Data.Maybe (catMaybes) import Control.Monad (forM) import Data.List (foldl') import Control.Arrow (second) import System.Random (randomRIO) import Yesod.Routes.TH.Types import Data.Char (toLower) data MkDispatchSettings b site c = MkDispatchSettings { mdsRunHandler :: Q Exp , mdsSubDispatcher :: Q Exp , mdsGetPathInfo :: Q Exp , mdsSetPathInfo :: Q Exp , mdsMethod :: Q Exp , mds404 :: Q Exp , mds405 :: Q Exp , mdsGetHandler :: Maybe String -> String -> Q Exp , mdsUnwrapper :: Exp -> Q Exp } data SDC = SDC { clause404 :: Clause , extraParams :: [Exp] , extraCons :: [Exp] , envExp :: Exp , reqExp :: Exp } -- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on -- view patterns. -- -- Since 1.4.0 mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause mkDispatchClause MkDispatchSettings {..} resources = do suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) envName <- newName $ "env" ++ show suffix reqName <- newName $ "req" ++ show suffix helperName <- newName $ "helper" ++ show suffix let envE = VarE envName reqE = VarE reqName helperE = VarE helperName clause404' <- mkClause404 envE reqE getPathInfo <- mdsGetPathInfo let pathInfo = getPathInfo `AppE` reqE let sdc = SDC { clause404 = clause404' , extraParams = [] , extraCons = [] , envExp = envE , reqExp = reqE } clauses <- mapM (go sdc) resources return $ Clause [VarP envName, VarP reqName] (NormalB $ helperE `AppE` pathInfo) [FunD helperName $ clauses ++ [clause404']] where handlePiece :: Piece a -> Q (Pat, Maybe Exp) handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Dynamic _) = do x <- newName "dyn" let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) return (pat, Just $ VarE x) handlePieces :: [Piece a] -> Q ([Pat], [Exp]) handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece mkCon :: String -> [Exp] -> Exp mkCon name = foldl' AppE (ConE $ mkName name) mkPathPat :: Pat -> [Pat] -> Pat mkPathPat final = foldr addPat final where addPat x y = ConP '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause go sdc (ResourceParent name _check pieces children) = do (pats, dyns) <- handlePieces pieces let sdc' = sdc { extraParams = extraParams sdc ++ dyns , extraCons = extraCons sdc ++ [mkCon name dyns] } childClauses <- mapM (go sdc') children restName <- newName "rest" let restE = VarE restName restP = VarP restName helperName <- newName $ "helper" ++ name let helperE = VarE helperName return $ Clause [mkPathPat restP pats] (NormalB $ helperE `AppE` restE) [FunD helperName $ childClauses ++ [clause404 sdc]] go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do (pats, dyns) <- handlePieces pieces (chooseMethod, finalPat) <- handleDispatch dispatch dyns return $ Clause [mkPathPat finalPat pats] (NormalB chooseMethod) [] where handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) handleDispatch dispatch' dyns = case dispatch' of Methods multi methods -> do (finalPat, mfinalE) <- case multi of Nothing -> return (ConP '[] [], Nothing) Just _ -> do multiName <- newName "multi" let pat = ViewP (VarE 'fromPathMultiPiece) (ConP 'Just [VarP multiName]) return (pat, Just $ VarE multiName) let dynsMulti = case mfinalE of Nothing -> dyns Just e -> dyns ++ [e] route' = foldl' AppE (ConE (mkName name)) dynsMulti route = foldr AppE route' extraCons jroute = ConE 'Just `AppE` route allDyns = extraParams ++ dynsMulti mkRunExp mmethod = do runHandlerE <- mdsRunHandler handlerE' <- mdsGetHandler mmethod name handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns return $ runHandlerE `AppE` handlerE `AppE` envExp `AppE` jroute `AppE` reqExp func <- case methods of [] -> mkRunExp Nothing _ -> do getMethod <- mdsMethod let methodE = getMethod `AppE` reqExp matches <- forM methods $ \method -> do exp <- mkRunExp (Just method) return $ Match (LitP $ StringL method) (NormalB exp) [] match405 <- do runHandlerE <- mdsRunHandler handlerE <- mds405 let exp = runHandlerE `AppE` handlerE `AppE` envExp `AppE` jroute `AppE` reqExp return $ Match WildP (NormalB exp) [] return $ CaseE methodE $ matches ++ [match405] return (func, finalPat) Subsite _ getSub -> do restPath <- newName "restPath" setPathInfoE <- mdsSetPathInfo subDispatcherE <- mdsSubDispatcher runHandlerE <- mdsRunHandler sub <- newName "sub" let allDyns = extraParams ++ dyns sroute <- newName "sroute" let sub2 = LamE [VarP sub] (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns) let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp route' = foldl' AppE (ConE (mkName name)) dyns route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons exp = subDispatcherE `AppE` runHandlerE `AppE` sub2 `AppE` route `AppE` envExp `AppE` reqExp' return (exp, VarP restPath) mkClause404 envE reqE = do handler <- mds404 runHandler <- mdsRunHandler let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE return $ Clause [WildP] (NormalB exp) [] defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Routes/TH/ParseRoute.hs�����������������������������������������������������0000644�0000000�0000000�00000003537�12772120703�017357� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# 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 :: Type -> [ResourceTree a] -> Q Dec mkParseRouteInstance 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 [] (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 #if MIN_VERSION_template_haskell(2,11,0) instanceD = InstanceD Nothing #else instanceD = InstanceD #endif �����������������������������������������������������������������������������������������������������������������������������������������������������������������yesod-core-1.4.25/Yesod/Routes/TH/RenderRoute.hs����������������������������������������������������0000644�0000000�0000000�00000013756�12772120703�017530� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell, CPP #-} module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where import Yesod.Routes.TH.Types #if MIN_VERSION_template_haskell(2,11,0) import Language.Haskell.TH (conT) #endif import Language.Haskell.TH.Syntax import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Monoid (mconcat) #endif -- | 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,11,0) dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] #else let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] #endif return ([con], dec : decs) where con = NormalC (mkName name) $ map (\x -> (notStrict, x)) $ singles ++ [ConT $ mkName name] singles = concatMap toSingle pieces toSingle Static{} = [] toSingle (Dynamic typ) = [typ] -- | Clauses for the 'renderRoute' method. mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses = mapM go where isDynamic Dynamic{} = True isDynamic _ = False go (ResourceParent name _check pieces children) = do let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns childRender <- newName "childRender" let rr = VarE childRender childClauses <- mkRenderRouteClauses children a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces' = foldr cons (VarE a) piecesSingle let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) return $ Clause [pat] (NormalB body) [FunD childRender childClauses] go (ResourceLeaf res) = do let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of Subsite{} -> return <$> newName "sub" _ -> return [] let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns piecesMulti <- case resourceMulti res of Nothing -> return $ ListE [] Just{} -> do tmp <- [|toPathMultiPiece|] return $ tmp `AppE` VarE (last dyns) body <- case sub of [x] -> do rr <- [|renderRoute|] a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces = foldr cons (VarE a) piecesSingle return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x) _ -> do colon <- [|(:)|] let cons a b = InfixE (Just a) colon (Just b) return $ TupE [foldr cons piecesMulti piecesSingle, ListE []] return $ Clause [pat] (NormalB body) [] mkPieces _ _ [] _ = [] mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120" -- | Generate the 'RenderRoute' instance. -- -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance = mkRenderRouteInstance' [] -- | A more general version of 'mkRenderRouteInstance' which takes an -- additional context. 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,11,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes #else let did = DataInstD [] ''Route [typ] cons clazzes #endif return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls ] : decs where clazzes = [''Show, ''Eq, ''Read] #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness #else notStrict :: Strict notStrict = NotStrict #endif instanceD :: Cxt -> Type -> [Dec] -> Dec #if MIN_VERSION_template_haskell(2,11,0) instanceD = InstanceD Nothing #else instanceD = InstanceD #endif ������������������yesod-core-1.4.25/Yesod/Routes/TH/RouteAttrs.hs�����������������������������������������������������0000644�0000000�0000000�00000002721�12772120703�017374� 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) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance typ ress = do clauses <- mapM (goTree id) ress return $ instanceD [] (ConT ''RouteAttrs `AppT` typ) [ FunD 'routeAttrs $ concat clauses ] goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] goTree front (ResourceLeaf res) = return <$> goRes front res goTree front (ResourceParent name _check pieces trees) = concat <$> mapM (goTree front') trees where ignored = (replicate toIgnore WildP ++) . return toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False front' = front . ConP (mkName name) . ignored goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes front Resource {..} = return $ Clause [front $ RecP (mkName resourceName) []] (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) [] where toText s = VarE 'pack `AppE` LitE (StringL s) instanceD :: Cxt -> Type -> [Dec] -> Dec #if MIN_VERSION_template_haskell(2,11,0) instanceD = InstanceD Nothing #else instanceD = InstanceD #endif �����������������������������������������������yesod-core-1.4.25/Yesod/Routes/TH/Types.hs����������������������������������������������������������0000644�0000000�0000000�00000006060�12772120703�016364� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} -- | Warning! This module is considered internal and may have breaking changes module Yesod.Routes.TH.Types ( -- * Data types Resource (..) , ResourceTree (..) , Piece (..) , Dispatch (..) , CheckOverlap , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName , flatten ) where import Language.Haskell.TH.Syntax data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] deriving Functor resourceTreePieces :: ResourceTree typ -> [Piece typ] resourceTreePieces (ResourceLeaf r) = resourcePieces r resourceTreePieces (ResourceParent _ _ x _) = x resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r resourceTreeName (ResourceParent x _ _ _) = x instance Lift t => Lift (ResourceTree t) where lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|] data Resource typ = Resource { resourceName :: String , resourcePieces :: [Piece typ] , resourceDispatch :: Dispatch typ , resourceAttrs :: [String] , resourceCheck :: CheckOverlap } deriving (Show, Functor) type CheckOverlap = Bool instance Lift t => Lift (Resource t) where lift (Resource a b c d e) = [|Resource a b c d e|] data Piece typ = Static String | Dynamic typ deriving Show instance Functor Piece where fmap _ (Static s) = Static s fmap f (Dynamic t) = Dynamic (f t) instance Lift t => Lift (Piece t) where lift (Static s) = [|Static $(lift s)|] lift (Dynamic t) = [|Dynamic $(lift t)|] data Dispatch typ = Methods { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end , methodsMethods :: [String] -- ^ supported request methods } | Subsite { subsiteType :: typ , subsiteFunc :: String } deriving Show instance Functor Dispatch where fmap f (Methods a b) = Methods (fmap f a) b fmap f (Subsite a b) = Subsite (f a) b instance Lift t => Lift (Dispatch t) where lift (Methods Nothing b) = [|Methods Nothing $(lift b)|] lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|] lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|] resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing data FlatResource a = FlatResource { frParentPieces :: [(String, [Piece a])] , frName :: String , frPieces :: [Piece a] , frDispatch :: Dispatch a , frCheck :: Bool } 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������