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
, runFakeHandler
-- * Re-exports
, module Yesod.Content
, module Yesod.Dispatch
, module Yesod.Handler
, module Yesod.Widget
, module Yesod.Core.Content
, module Yesod.Core.Dispatch
, module Yesod.Core.Handler
, module Yesod.Core.Widget
, module Yesod.Core.Json
, module Yesod.Core.Trans.Class
, module Yesod.Core.Class.MonadLift
, module Text.Shakespeare.I18N
, module Yesod.Core.Internal.Util
) where
import Yesod.Internal.Core
import Yesod.Content
import Yesod.Dispatch
import Yesod.Handler
import Yesod.Widget
import Yesod.Core.Content
import Yesod.Core.Dispatch
import Yesod.Core.Handler
import Yesod.Core.Widget
import Yesod.Core.Json
import Yesod.Core.Types
import Yesod.Core.Trans.Class
import Yesod.Core.Class.MonadLift
import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
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.
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master 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 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 FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Handler.Class where
module Yesod.Core.Class.Handler where
import Yesod.Core.Types
import Yesod.Core.Trans.Class (lift)
import Yesod.Core.Class.MonadLift (lift)
import Control.Monad.Trans.Class (MonadTrans)
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)

View File

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

View File

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

View File

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

View File

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

View File

@ -19,7 +19,7 @@
-- Define Handler stuff.
--
---------------------------------------------------------
module Yesod.Handler
module Yesod.Core.Handler
( -- * Handler monad
GHandler
-- ** Read information from handler
@ -158,7 +158,7 @@ import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..))
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 Text.Blaze.Html (preEscapedToMarkup, toHtml)
@ -167,7 +167,7 @@ import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef as I
import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Handler.Class
import Yesod.Core.Class.Handler
import Yesod.Core.Types
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 RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Run where
module Yesod.Core.Internal.Run where
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (fromLazyByteString, toByteString,
toLazyByteString)
import Control.Applicative ((<$>))
@ -16,12 +17,9 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
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.Map as Map
import Data.Maybe (isJust)
@ -39,47 +37,13 @@ import Prelude hiding (catch)
import System.Log.FastLogger (Logger)
import System.Log.FastLogger (LogStr, toLogStr)
import System.Random (newStdGen)
import Web.Cookie (renderSetCookie)
import Yesod.Content
import Yesod.Core.Class
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
import Yesod.Core.Types
import Yesod.Core.Internal.Request (parseWaiRequest, tokenKey,
tooLargeResponse)
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 =
local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }})

View File

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

View File

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

View File

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

View File

@ -8,7 +8,7 @@
{-# 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.Widget
module Yesod.Core.Widget
( -- * Datatype
GWidget
, PageContent (..)
@ -51,8 +51,8 @@ import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod.Routes.Class
import Yesod.Handler (getMessageRender, getUrlRenderParams)
import Yesod.Core.Trans.Class (lift)
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Yesod.Core.Class.MonadLift (lift)
import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
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.Test
import Yesod.Core.Internal.Request (randomString, parseWaiRequest)
import Yesod.Core.Internal (randomString, parseWaiRequest)
import Test.Hspec
import Data.Monoid (mempty)
import Data.Map (singleton)

View File

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

View File

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