Moved code around some more

This commit is contained in:
Michael Snoyman 2013-03-12 05:49:24 +02:00
parent 4d6c114b12
commit 9873b4d8f3
20 changed files with 224 additions and 226 deletions

View File

@ -47,31 +47,53 @@ module Yesod.Core
, yesodRender , yesodRender
, runFakeHandler , runFakeHandler
-- * Re-exports -- * Re-exports
, module Yesod.Content , module Yesod.Core.Content
, module Yesod.Dispatch , module Yesod.Core.Dispatch
, module Yesod.Handler , module Yesod.Core.Handler
, module Yesod.Widget , module Yesod.Core.Widget
, module Yesod.Core.Json , module Yesod.Core.Json
, module Yesod.Core.Trans.Class , module Yesod.Core.Class.MonadLift
, module Text.Shakespeare.I18N , module Text.Shakespeare.I18N
, module Yesod.Core.Internal.Util , module Yesod.Core.Internal.Util
) where ) where
import Yesod.Internal.Core import Yesod.Core.Content
import Yesod.Content import Yesod.Core.Dispatch
import Yesod.Dispatch import Yesod.Core.Handler
import Yesod.Handler import Yesod.Core.Widget
import Yesod.Widget
import Yesod.Core.Json import Yesod.Core.Json
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Trans.Class import Yesod.Core.Class.MonadLift
import Text.Shakespeare.I18N import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
import Control.Monad.Logger import Control.Monad.Logger
import Yesod.Core.Internal.Session
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Class.Breadcrumbs
import Yesod.Core.Internal.Run (yesodRender, runFakeHandler)
import qualified Paths_yesod_core
import Data.Version (showVersion)
import Yesod.Routes.Class (RenderRoute (..))
-- | Return an 'Unauthorized' value, with the given i18n message. -- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
unauthorizedI msg =do unauthorizedI msg =do
mr <- getMessageRender mr <- getMessageRender
return $ Unauthorized $ mr msg 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 a
=> Route a
-> Bool -- ^ is this a write request?
-> GHandler s a (Maybe (Route a))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing

View File

@ -0,0 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Core.Class.Breadcrumbs where
import Yesod.Core.Handler
import Yesod.Routes.Class
import Data.Text (Text)
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
-- resource, you declare the title of the page and the parent resource (if
-- present).
class YesodBreadcrumbs y 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 y -> GHandler sub y (Text , Maybe (Route y))
-- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, 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

View File

@ -0,0 +1,53 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Yesod.Core.Class.Dispatch where
import Yesod.Core.Content
import Yesod.Core.Handler
import Yesod.Routes.Class
import qualified Network.Wai as W
import Yesod.Core.Internal.Session
import Data.Text (Text)
import System.Log.FastLogger (Logger)
import Yesod.Core.Types
import Yesod.Core.Class.Yesod
import Yesod.Core.Internal.Run
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> Logger
-> master
-> sub
-> (Route sub -> Route master)
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
-> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
-> Text -- ^ request method
-> [Text] -- ^ pieces
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner :: Yesod master
=> Logger
-> GHandler sub master TypedContent
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
{ yreLogger = logger
, yreMaster = master
, yreSub = sub
, yreRoute = murl
, yreToMaster = tomaster
, yreSessionBackend = msb
} handler
instance YesodDispatch WaiSubsite master where
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

View File

@ -2,10 +2,10 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Handler.Class where module Yesod.Core.Class.Handler where
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Trans.Class (lift) import Yesod.Core.Class.MonadLift (lift)
import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Class (MonadTrans)
import Data.IORef.Lifted (atomicModifyIORef) import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO) import Control.Exception.Lifted (throwIO)

View File

@ -1,7 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Yesod.Core.Trans.Class (MonadLift (..)) where module Yesod.Core.Class.MonadLift (MonadLift (..)) where
import Control.Monad.Trans.Class import Control.Monad.Trans.Class

View File

@ -2,11 +2,11 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Class where module Yesod.Core.Class.Yesod where
import Control.Monad.Logger (logErrorS) import Control.Monad.Logger (logErrorS)
import Yesod.Content import Yesod.Core.Content
import Yesod.Handler hiding (getExpires) import Yesod.Core.Handler hiding (getExpires)
import Yesod.Routes.Class import Yesod.Routes.Class
@ -53,9 +53,9 @@ import qualified Web.ClientSession as CS
import Web.Cookie (parseCookies) import Web.Cookie (parseCookies)
import Web.Cookie (SetCookie (..)) import Web.Cookie (SetCookie (..))
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Widget import Yesod.Core.Widget
import Yesod.Core.Trans.Class (lift) import Yesod.Core.Class.MonadLift (lift)
-- | Define settings for a Yesod applications. All methods have intelligent -- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required. -- defaults, and therefore no implementation is required.

View File

@ -5,7 +5,7 @@
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Yesod.Content module Yesod.Core.Content
( -- * Content ( -- * Content
Content (..) Content (..)
, emptyContent , emptyContent

View File

@ -1,10 +1,9 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Dispatch module Yesod.Core.Dispatch
( -- * Quasi-quoted routing ( -- * Quasi-quoted routing
parseRoutes parseRoutes
, parseRoutesNoCheck , parseRoutesNoCheck
@ -31,8 +30,7 @@ module Yesod.Dispatch
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Prelude hiding (exp) import Prelude hiding (exp)
import Yesod.Internal.Core import Yesod.Core.Handler
import Yesod.Handler
import Web.PathPieces import Web.PathPieces
import Language.Haskell.TH import Language.Haskell.TH
@ -52,10 +50,13 @@ import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Content (toTypedContent) import Yesod.Core.Content (toTypedContent)
import Yesod.Routes.Parse import Yesod.Routes.Parse
import System.Log.FastLogger (Logger) import System.Log.FastLogger (Logger)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
-- | Generates URL datatype and site function for the given 'Resource's. This -- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.

View File

@ -19,7 +19,7 @@
-- Define Handler stuff. -- Define Handler stuff.
-- --
--------------------------------------------------------- ---------------------------------------------------------
module Yesod.Handler module Yesod.Core.Handler
( -- * Handler monad ( -- * Handler monad
GHandler GHandler
-- ** Read information from handler -- ** Read information from handler
@ -158,7 +158,7 @@ import Data.Text (Text)
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Shakespeare.I18N (RenderMessage (..))
import Web.Cookie (SetCookie (..)) import Web.Cookie (SetCookie (..))
import Yesod.Content (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..)) import Yesod.Core.Content (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..))
import Yesod.Core.Internal.Util (formatRFC1123) import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml) import Text.Blaze.Html (preEscapedToMarkup, toHtml)
@ -167,7 +167,7 @@ import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef as I import qualified Data.IORef as I
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf) import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Handler.Class import Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Routes.Class (Route) import Yesod.Routes.Class (Route)

View File

@ -0,0 +1,7 @@
-- | 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)

View File

@ -0,0 +1,51 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Internal.Response where
import Blaze.ByteString.Builder (toByteString)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai
import Prelude hiding (catch)
import Web.Cookie (renderSetCookie)
import Yesod.Core.Content
import Yesod.Core.Types
yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response
yarToResponse (YRWai a) _ = a
yarToResponse (YRPlain s hs _ c _) extraHeaders =
go c
where
finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
go (ContentBuilder b mlen) =
ResponseBuilder s hs' b
where
hs' = maybe finalHeaders finalHeaders' mlen
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
go (ContentSource body) = ResponseSource s finalHeaders body
go (ContentDontEvaluate c') = go c'
-- | Convert Header to a key/value pair.
headerToPair :: Header
-> (CI ByteString, ByteString)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie $ sc)
headerToPair (DeleteCookie key path) =
( "Set-Cookie"
, S.concat
[ key
, "=; path="
, path
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
]
)
headerToPair (Header key value) = (CI.mk key, value)

View File

@ -3,8 +3,9 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Run where module Yesod.Core.Internal.Run where
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (fromLazyByteString, toByteString, import Blaze.ByteString.Builder (fromLazyByteString, toByteString,
toLazyByteString) toLazyByteString)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -16,12 +17,9 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource, import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc) liftLoc)
import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Trans.Resource (runResourceT)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.IORef as I import qualified Data.IORef as I
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (isJust) import Data.Maybe (isJust)
@ -39,47 +37,13 @@ import Prelude hiding (catch)
import System.Log.FastLogger (Logger) import System.Log.FastLogger (Logger)
import System.Log.FastLogger (LogStr, toLogStr) import System.Log.FastLogger (LogStr, toLogStr)
import System.Random (newStdGen) import System.Random (newStdGen)
import Web.Cookie (renderSetCookie) import Yesod.Core.Content
import Yesod.Content import Yesod.Core.Class.Yesod
import Yesod.Core.Class
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Request (parseWaiRequest, tokenKey, import Yesod.Core.Internal.Request (parseWaiRequest, tokenKey,
tooLargeResponse) tooLargeResponse)
import Yesod.Routes.Class (Route, renderRoute) import Yesod.Routes.Class (Route, renderRoute)
yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response
yarToResponse (YRWai a) _ = a
yarToResponse (YRPlain s hs _ c _) extraHeaders =
go c
where
finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
go (ContentBuilder b mlen) =
ResponseBuilder s hs' b
where
hs' = maybe finalHeaders finalHeaders' mlen
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
go (ContentSource body) = ResponseSource s finalHeaders body
go (ContentDontEvaluate c') = go c'
-- | Convert Header to a key/value pair.
headerToPair :: Header
-> (CI ByteString, ByteString)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie $ sc)
headerToPair (DeleteCookie key path) =
( "Set-Cookie"
, S.concat
[ key
, "=; path="
, path
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
]
)
headerToPair (Header key value) = (CI.mk key, value)
localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent :: GHandler s m a -> GHandler s m a
localNoCurrent = localNoCurrent =
local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }}) local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }})

View File

@ -1,4 +1,4 @@
module Yesod.Internal.Session module Yesod.Core.Internal.Session
( encodeClientSession ( encodeClientSession
, decodeClientSession , decodeClientSession
, clientSessionDateCacher , clientSessionDateCacher

View File

@ -19,11 +19,11 @@ module Yesod.Core.Json
, acceptsJson , acceptsJson
) where ) where
import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep) import Yesod.Core.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Trans.Class (lift) import Yesod.Core.Class.MonadLift (lift)
import Yesod.Content (TypedContent) import Yesod.Core.Content (TypedContent)
import Yesod.Internal.Core (defaultLayout, Yesod) import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Widget (GWidget) import Yesod.Core.Widget (GWidget)
import Yesod.Routes.Class import Yesod.Routes.Class
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (join) import Control.Monad (join)

View File

@ -51,7 +51,7 @@ import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl) import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie) import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime) import Yesod.Core.Internal.Util (getTime, putTime)
import Yesod.Core.Trans.Class (MonadLift (..)) import Yesod.Core.Class.MonadLift (MonadLift (..))
import Yesod.Routes.Class (RenderRoute (..)) import Yesod.Routes.Class (RenderRoute (..))
-- Sessions -- Sessions

View File

@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
-- generator, allowing you to create truly modular HTML components. -- generator, allowing you to create truly modular HTML components.
module Yesod.Widget module Yesod.Core.Widget
( -- * Datatype ( -- * Datatype
GWidget GWidget
, PageContent (..) , PageContent (..)
@ -51,8 +51,8 @@ import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Yesod.Routes.Class import Yesod.Routes.Class
import Yesod.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Yesod.Core.Trans.Class (lift) import Yesod.Core.Class.MonadLift (lift)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)

View File

@ -1,134 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
-- | The basic typeclass for a Yesod application.
module Yesod.Internal.Core
( -- * Type classes
Yesod (..)
, YesodDispatch (..)
, RenderRoute (..)
-- ** Breadcrumbs
, YesodBreadcrumbs (..)
, breadcrumbs
-- * Utitlities
, maybeAuthorized
, widgetToPageContent
-- * Defaults
, defaultErrorHandler
-- * Data types
, AuthResult (..)
-- * Sessions
, SessionBackend (..)
, defaultClientSessionBackend
, clientSessionBackend
, loadClientSession
, clientSessionDateCacher
-- * jsLoader
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Misc
, yesodVersion
, yesodRender
, resolveApproot
, Approot (..)
, FileUpload (..)
, runFakeHandler
) where
import Yesod.Content
import Yesod.Handler hiding (getExpires)
import Yesod.Routes.Class
import qualified Network.Wai as W
import Yesod.Internal.Session
import Yesod.Core.Internal.Request
import Data.Text (Text)
import qualified Paths_yesod_core
import Data.Version (showVersion)
import System.Log.FastLogger (Logger)
import Yesod.Core.Types
import Yesod.Core.Class
import Yesod.Core.Run
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
-- | 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 y 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 y -> GHandler sub y (Text , Maybe (Route y))
-- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, 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
-- | 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 a
=> Route a
-> Bool -- ^ is this a write request?
-> GHandler s a (Maybe (Route a))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> Logger
-> master
-> sub
-> (Route sub -> Route master)
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
-> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
-> Text -- ^ request method
-> [Text] -- ^ pieces
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner :: Yesod master
=> Logger
-> GHandler sub master TypedContent
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
{ yreLogger = logger
, yreMaster = master
, yreSub = sub
, yreRoute = murl
, yreToMaster = tomaster
, yreSessionBackend = msb
} handler
instance YesodDispatch WaiSubsite master where
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

View File

@ -6,7 +6,7 @@ import System.Random (StdGen, mkStdGen)
import Network.Wai as W import Network.Wai as W
import Network.Wai.Test import Network.Wai.Test
import Yesod.Core.Internal.Request (randomString, parseWaiRequest) import Yesod.Core.Internal (randomString, parseWaiRequest)
import Test.Hspec import Test.Hspec
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Map (singleton) import Data.Map (singleton)

View File

@ -2,7 +2,7 @@
module YesodCoreTest.Redirect (specs, Widget) where module YesodCoreTest.Redirect (specs, Widget) where
import YesodCoreTest.YesodTest import YesodCoreTest.YesodTest
import Yesod.Handler (redirectWith) import Yesod.Core.Handler (redirectWith)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
data Y = Y data Y = Y

View File

@ -88,20 +88,23 @@ library
, blaze-html >= 0.5 , blaze-html >= 0.5
, blaze-markup >= 0.5.1 , blaze-markup >= 0.5.1
exposed-modules: Yesod.Content exposed-modules: Yesod.Core
Yesod.Core Yesod.Core.Content
Yesod.Core.Dispatch
Yesod.Core.Handler
Yesod.Core.Json Yesod.Core.Json
Yesod.Core.Handler.Class Yesod.Core.Widget
Yesod.Dispatch Yesod.Core.Internal
Yesod.Handler other-modules: Yesod.Core.Internal.Session
Yesod.Widget
Yesod.Core.Internal.Request Yesod.Core.Internal.Request
other-modules: Yesod.Internal.Core Yesod.Core.Class.Handler
Yesod.Internal.Session
Yesod.Core.Internal.Util Yesod.Core.Internal.Util
Yesod.Core.Trans.Class Yesod.Core.Internal.Response
Yesod.Core.Run Yesod.Core.Class.MonadLift
Yesod.Core.Class Yesod.Core.Internal.Run
Yesod.Core.Class.Yesod
Yesod.Core.Class.Dispatch
Yesod.Core.Class.Breadcrumbs
Yesod.Core.Types Yesod.Core.Types
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall