From 98613278d4f695f2cd608d69044fceb414db2d11 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 11:02:53 +0200 Subject: [PATCH] Yesod.Core.Types created, but it's a mess --- yesod-core/Yesod/Content.hs | 30 +- yesod-core/Yesod/Core.hs | 4 +- yesod-core/Yesod/Core/Json.hs | 9 +- yesod-core/Yesod/Core/Time.hs | 29 ++ yesod-core/Yesod/Core/Trans/Class.hs | 15 + yesod-core/Yesod/Core/Types.hs | 417 +++++++++++++++++++++++++++ yesod-core/Yesod/Dispatch.hs | 15 +- yesod-core/Yesod/Handler.hs | 123 +------- yesod-core/Yesod/Internal.hs | 88 +----- yesod-core/Yesod/Internal/Cache.hs | 8 +- yesod-core/Yesod/Internal/Core.hs | 30 +- yesod-core/Yesod/Internal/Request.hs | 29 +- yesod-core/Yesod/Internal/Session.hs | 66 +---- yesod-core/Yesod/Message.hs | 6 - yesod-core/Yesod/Widget.hs | 101 +------ yesod-core/yesod-core.cabal | 8 +- 16 files changed, 492 insertions(+), 486 deletions(-) create mode 100644 yesod-core/Yesod/Core/Time.hs create mode 100644 yesod-core/Yesod/Core/Trans/Class.hs create mode 100644 yesod-core/Yesod/Core/Types.hs delete mode 100644 yesod-core/Yesod/Message.hs diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index efb2cae5..41f6d208 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -63,8 +63,6 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -import Data.String (IsString (fromString)) -import Network.Wai (FilePart) import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput) import Data.Conduit.Internal (ResumableSource (ResumableSource)) @@ -72,19 +70,12 @@ import qualified Data.Aeson as J import Data.Aeson.Encode (fromValue) import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) - -data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length. - | ContentSource !(Source (ResourceT IO) (Flush Builder)) - | ContentFile !FilePath !(Maybe FilePart) - | ContentDontEvaluate !Content +import Yesod.Core.Types -- | Zero-length enumerator. emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 -instance IsString Content where - fromString = toContent - -- | 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 @@ -122,12 +113,6 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString --- | A function which gives targetted representations of content based on the --- content-types the user accepts. -type ChooseRep = - [ContentType] -- ^ list of content-types user accepts, ordered by preference - -> IO (ContentType, Content) - -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep @@ -170,27 +155,20 @@ instance HasReps [(ContentType, Content)] where where go = simpleContentType -newtype RepHtml = RepHtml Content instance HasReps RepHtml where chooseRep (RepHtml c) _ = return (typeHtml, c) -newtype RepJson = RepJson Content instance HasReps RepJson where chooseRep (RepJson c) _ = return (typeJson, c) -data RepHtmlJson = RepHtmlJson Content Content instance HasReps RepHtmlJson where chooseRep (RepHtmlJson html json) = chooseRep [ (typeHtml, html) , (typeJson, json) ] -newtype RepPlain = RepPlain Content instance HasReps RepPlain where chooseRep (RepPlain c) _ = return (typePlain, c) -newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = B.ByteString -- FIXME Text? - typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -256,12 +234,6 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" --- | Prevents a response body from being fully evaluated before sending the --- request. --- --- Since 1.1.0 -newtype DontFullyEvaluate a = DontFullyEvaluate a - instance HasReps a => HasReps (DontFullyEvaluate a) where chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 583efeb9..4f3dfa2f 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -53,8 +53,8 @@ module Yesod.Core , module Yesod.Handler , module Yesod.Request , module Yesod.Widget - , module Yesod.Message , module Yesod.Core.Json + , module Text.Shakespeare.I18N ) where import Yesod.Internal.Core @@ -64,8 +64,8 @@ import Yesod.Dispatch import Yesod.Handler import Yesod.Request import Yesod.Widget -import Yesod.Message import Yesod.Core.Json +import Text.Shakespeare.I18N import Control.Monad.Logger diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index ce98fb96..42f26777 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -24,7 +24,7 @@ module Yesod.Core.Json import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) - , RepJson (RepJson), Content (ContentBuilder) + , RepJson (RepJson) ) import Yesod.Internal.Core (defaultLayout, Yesod) import Yesod.Widget (GWidget) @@ -35,16 +35,9 @@ import Control.Monad (join) import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP import Data.Aeson ((.=)) -import qualified Data.Aeson.Encode as JE -import Data.Aeson.Encode (fromValue) import Data.Conduit.Attoparsec (sinkParser) import Data.Text (Text, pack) import qualified Data.Vector as V -import Text.Julius (ToJavascript (..)) -import Data.Text.Lazy.Builder (fromLazyText) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Text.Lazy.Builder (toLazyText) -import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Conduit import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) diff --git a/yesod-core/Yesod/Core/Time.hs b/yesod-core/Yesod/Core/Time.hs new file mode 100644 index 00000000..371159df --- /dev/null +++ b/yesod-core/Yesod/Core/Time.hs @@ -0,0 +1,29 @@ +module Yesod.Core.Time + ( putTime + , getTime + ) where + +import Data.Int (Int64) +import Data.Serialize (Get, Put, Serialize (..)) +import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), + DiffTime, UTCTime (..)) + +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 diff --git a/yesod-core/Yesod/Core/Trans/Class.hs b/yesod-core/Yesod/Core/Trans/Class.hs new file mode 100644 index 00000000..a4d362b5 --- /dev/null +++ b/yesod-core/Yesod/Core/Trans/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +module Yesod.Core.Trans.Class (MonadLift (..)) where + +import Control.Monad.Trans.Class + +-- | The standard @MonadTrans@ class only allows lifting for monad +-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their +-- types do not express that they actually are transformers. This replacement +-- class accounts for this. +class MonadLift base m | m -> base where + lift :: base a -> m a +instance (Monad m, MonadTrans t) => MonadLift m (t m) where + lift = Control.Monad.Trans.Class.lift diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs new file mode 100644 index 00000000..49c57f13 --- /dev/null +++ b/yesod-core/Yesod/Core/Types.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Yesod.Core.Types where + +import qualified Blaze.ByteString.Builder as BBuilder +import qualified Blaze.ByteString.Builder.Char.Utf8 +import Control.Applicative (Applicative (..)) +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Exception (Exception, throwIO) +import Control.Failure (Failure (..)) +import Control.Monad (liftM) +import Control.Monad.Base (MonadBase (liftBase)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LogLevel, LogSource, + MonadLogger (..)) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Resource (MonadResource (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Conduit (Flush, MonadThrow (..), + MonadUnsafeIO (..), + ResourceT, Source) +import Data.IntMap (IntMap) +import Data.IORef (IORef) +import Data.Map (Map, unionWith) +import Data.Monoid (Any, Endo (..), Last (..), + Monoid (..)) +import Data.Serialize (Serialize (..), + putByteString) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TBuilder +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import 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, toLogStr) +import Text.Blaze.Html (Html) +import Text.Hamlet (HtmlUrl) +import Text.Julius (JavascriptUrl) +import Web.Cookie (SetCookie) +import Yesod.Core.Time (getTime, putTime) +import Yesod.Core.Trans.Class (MonadLift (..)) +import Yesod.Routes.Class (RenderRoute (..)) + +-- Sessions +type BackendSession = [(Text, ByteString)] + +type SaveSession = BackendSession -- ^ The session contents after running the handler + -> IO [Header] + +newtype SessionBackend master = SessionBackend + { sbLoadSession :: master + -> W.Request + -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session + } + +data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = do + either putTime putByteString a + put b + put (map (first T.unpack) c) + + get = do + a <- getTime + b <- get + c <- map (first T.pack) <$> get + return $ SessionCookie (Left a) b c + +data ClientSessionDateCache = + ClientSessionDateCache { + csdcNow :: !UTCTime + , csdcExpires :: !UTCTime + , csdcExpiresSerialized :: !ByteString + } deriving (Eq, Show) + +-- | The parsed request information. +data Request = Request + { reqGetParams :: [(Text, Text)] + , reqCookies :: [(Text, Text)] + , reqWaiRequest :: W.Request + -- | Languages which the client supports. + , reqLangs :: [Text] + -- | A random, session-specific token used to prevent CSRF attacks. + , reqToken :: Maybe Text + } + +-- | A tuple containing both the POST parameters and submitted files. +type RequestBodyContents = + ( [(Text, Text)] + , [(Text, FileInfo)] + ) + +data FileInfo = FileInfo + { fileName :: Text + , fileContentType :: Text + , fileSource :: Source (ResourceT IO) ByteString + , fileMove :: FilePath -> IO () + } + +data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) + | FileUploadDisk (NWP.BackEnd FilePath) + | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) + +-- | How to determine the root of the application for constructing URLs. +-- +-- Note that future versions of Yesod may add new constructors without bumping +-- the major version number. As a result, you should /not/ pattern match on +-- @Approot@ values. +data Approot master = ApprootRelative -- ^ No application root. + | ApprootStatic Text + | ApprootMaster (master -> Text) + | ApprootRequest (master -> W.Request -> Text) + +type ResolvedApproot = Text + +data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text + deriving (Eq, Show, Read) + +data ScriptLoadPosition master + = BottomOfBody + | BottomOfHeadBlocking + | BottomOfHeadAsync (BottomOfHeadAsync master) + +type BottomOfHeadAsync master + = [Text] -- ^ urls to load asynchronously + -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion + -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of + +newtype Cache = Cache (IntMap Any) + deriving Monoid + +newtype CacheKey a = CacheKey Int + +type Texts = [Text] + +-- | Wrap up a normal WAI application as a Yesod subsite. +newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } + +data HandlerData sub master = HandlerData + { handlerRequest :: Request + , handlerSub :: sub + , handlerMaster :: master + , handlerRoute :: Maybe (Route sub) + , handlerRender :: Route master -> [(Text, Text)] -> Text + , handlerToMaster :: Route sub -> Route master + , handlerState :: IORef GHState + , handlerUpload :: RequestBodyLength -> FileUpload + , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + } + +-- | A generic handler monad, which can have a different subsite and master +-- site. We define a newtype for better error message. +newtype GHandler sub master a = GHandler + { unGHandler :: HandlerData sub master -> ResourceT IO a + } + +data GHState = GHState + { ghsSession :: SessionMap + , ghsRBC :: Maybe RequestBodyContents + , ghsIdent :: Int + , ghsCache :: Cache + , ghsHeaders :: Endo [Header] + } + +type SessionMap = Map Text ByteString + +-- | 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 'GHandler' monad and template haskell code should hide it away. +newtype YesodApp = YesodApp + { unYesodApp + :: (ErrorResponse -> YesodApp) + -> Request + -> [ContentType] + -> SessionMap + -> ResourceT IO YesodAppResult + } + +data YesodAppResult + = YARWai W.Response + | YARPlain H.Status [Header] ContentType Content SessionMap + +-- | 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 GWidget sub master a = GWidget + { unGWidget :: GHandler sub master (a, GWData (Route master)) + } + +instance (a ~ ()) => Monoid (GWidget sub master a) where + mempty = return () + mappend x y = x >> y + +type RY master = Route master -> [(Text, Text)] -> Text + +-- | Newtype wrapper allowing injection of arbitrary content into CSS. +-- +-- Usage: +-- +-- > toWidget $ CssBuilder "p { color: red }" +-- +-- Since: 1.1.3 +newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } + +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> HtmlUrl url +data PageContent url = PageContent + { pageTitle :: Html + , pageHead :: HtmlUrl url + , pageBody :: HtmlUrl url + } + +data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length. + | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder)) + | ContentFile !FilePath !(Maybe FilePart) + | ContentDontEvaluate !Content + +-- | A function which gives targetted representations of content based on the +-- content-types the user accepts. +type ChooseRep = + [ContentType] -- ^ list of content-types user accepts, ordered by preference + -> IO (ContentType, Content) + +newtype RepHtml = RepHtml Content +newtype RepJson = RepJson Content +data RepHtmlJson = RepHtmlJson Content 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 a + +-- | Responses to indicate some form of an error occurred. These are different +-- from 'SpecialResponse' in that they allow for custom error pages. +data ErrorResponse = + NotFound + | InternalError Text + | InvalidArgs [Text] + | PermissionDenied Text + | BadMethod H.Method + deriving (Show, Eq, Typeable) + +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie SetCookie + | DeleteCookie ByteString ByteString + | Header ByteString ByteString + deriving (Eq, Show) + +data Location url = Local url | Remote Text + deriving (Show, Eq) + +newtype UniqueList x = UniqueList ([x] -> [x]) + +data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } + deriving (Show, Eq) +data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html } + +newtype Head url = Head (HtmlUrl url) + deriving Monoid +newtype Body url = Body (HtmlUrl url) + deriving Monoid + +type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder + +data GWData a = GWData + { gwdBody :: !(Body a) + , gwdTitle :: !(Last Title) + , gwdScripts :: !(UniqueList (Script a)) + , gwdStylesheets :: !(UniqueList (Stylesheet a)) + , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type + , gwdJavascript :: !(Maybe (JavascriptUrl a)) + , gwdHead :: !(Head a) + } +instance Monoid (GWData a) where + mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mappend (GWData a1 a2 a3 a4 a5 a6 a7) + (GWData b1 b2 b3 b4 b5 b6 b7) = GWData + (a1 `mappend` b1) + (a2 `mappend` b2) + (a3 `mappend` b3) + (a4 `mappend` b4) + (unionWith mappend a5 b5) + (a6 `mappend` b6) + (a7 `mappend` b7) + +data HandlerContents = + HCContent H.Status ChooseRep + | HCError ErrorResponse + | HCSendFile ContentType FilePath (Maybe FilePart) + | HCRedirect H.Status Text + | HCCreated Text + | HCWai W.Response + deriving Typeable + +instance Show HandlerContents where + show _ = "Cannot show a HandlerContents" +instance Exception HandlerContents + +-- Instances for GWidget +instance Functor (GWidget sub master) where + fmap f (GWidget x) = GWidget (fmap (first f) x) +instance Applicative (GWidget sub master) where + pure a = GWidget $ pure (a, mempty) + GWidget f <*> GWidget v = + GWidget $ k <$> f <*> v + where + k (a, wa) (b, wb) = (a b, wa `mappend` wb) +instance Monad (GWidget sub master) where + return = pure + GWidget x >>= f = GWidget $ do + (a, wa) <- x + (b, wb) <- unGWidget (f a) + return (b, wa `mappend` wb) +instance MonadIO (GWidget sub master) where + liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO +instance MonadBase IO (GWidget sub master) where + liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase +instance MonadBaseControl IO (GWidget sub master) where + data StM (GWidget sub master) a = + StW (StM (GHandler sub master) (a, GWData (Route master))) + liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> + liftM (\x -> (x, mempty)) + (f $ liftM StW . runInBase . unGWidget) + restoreM (StW base) = GWidget $ restoreM base + +instance MonadUnsafeIO (GWidget sub master) where + unsafeLiftIO = liftIO +instance MonadThrow (GWidget sub master) where + monadThrow = liftIO . throwIO +instance MonadResource (GWidget sub master) where + liftResourceT = lift . liftResourceT + +instance MonadLogger (GWidget sub master) where + monadLoggerLog a b c = lift . monadLoggerLog a b c + +instance MonadLift (GHandler sub master) (GWidget sub master) where + lift = GWidget . fmap (\x -> (x, mempty)) + +instance MonadLift (ResourceT IO) (GHandler sub master) where + lift = GHandler . const + +-- Instances for GHandler +instance Functor (GHandler sub master) where + fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) +instance Applicative (GHandler sub master) where + pure = GHandler . const . pure + GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r +instance Monad (GHandler sub master) where + return = pure + GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r +instance MonadIO (GHandler sub master) where + liftIO = GHandler . const . lift +instance MonadBase IO (GHandler sub master) where + liftBase = GHandler . const . lift +-- | 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 IO (GHandler sub master) where + data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) + liftBaseWith f = GHandler $ \reader -> + liftBaseWith $ \runInBase -> + f $ liftM StH . runInBase . (\(GHandler r) -> r reader) + restoreM (StH base) = GHandler $ const $ restoreM base + +instance MonadUnsafeIO (GHandler sub master) where + unsafeLiftIO = liftIO +instance MonadThrow (GHandler sub master) where + monadThrow = liftIO . throwIO +instance MonadResource (GHandler sub master) where + liftResourceT = lift . liftResourceT + +instance MonadLogger (GHandler sub master) where + monadLoggerLog a b c d = GHandler $ \hd -> + liftIO $ handlerLog hd a b c (toLogStr d) + +instance Exception e => Failure e (GHandler sub master) where + failure = liftIO . throwIO + +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y + +instance IsString Content where + fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString + +instance RenderRoute WaiSubsite where + data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] + deriving (Show, Eq, Read, Ord) + renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 1e193880..dc752019 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -33,7 +33,6 @@ import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core import Yesod.Handler hiding (lift) -import Yesod.Widget (GWidget) import Web.PathPieces import Language.Haskell.TH @@ -56,8 +55,7 @@ import Yesod.Routes.TH import Yesod.Content (chooseRep) import Yesod.Routes.Parse import System.Log.FastLogger (Logger) - -type Texts = [Text] +import Yesod.Core.Types -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. @@ -210,14 +208,3 @@ sendRedirect y segments' env = then dest else (dest `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) - --- | Wrap up a normal WAI application as a Yesod subsite. -newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } - -instance RenderRoute WaiSubsite where - data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] - deriving (Show, Eq, Read, Ord) - renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) - -instance YesodDispatch WaiSubsite master where - yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 81fb01e0..90e7f759 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -129,11 +129,8 @@ import Control.Exception hiding (Handler, catch, finally) import Control.Applicative import Control.Monad (liftM) -import Control.Failure (Failure (failure)) import Control.Monad.IO.Class -import Control.Monad.Trans.Class (MonadTrans) -import qualified Control.Monad.Trans.Class import System.IO import qualified Network.Wai as W @@ -163,7 +160,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) -import Yesod.Message (RenderMessage (..)) +import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup @@ -172,30 +169,18 @@ import System.Log.FastLogger import Control.Monad.Logger import qualified Yesod.Internal.Cache as Cache -import Yesod.Internal.Cache (mkCacheKey, CacheKey) +import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I import Control.Exception.Lifted (catch) -import Control.Monad.Trans.Control import Control.Monad.Trans.Resource -import Control.Monad.Base import Yesod.Routes.Class import Language.Haskell.TH.Syntax (Loc) +import Yesod.Core.Types +import Yesod.Core.Trans.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y -data HandlerData sub master = HandlerData - { handlerRequest :: Request - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: Route master -> [(Text, Text)] -> Text - , handlerToMaster :: Route sub -> Route master - , handlerState :: I.IORef GHState - , handlerUpload :: W.RequestBodyLength -> FileUpload - , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () - } - handlerSubData :: (Route sub -> Route master) -> (master -> sub) -> Route sub @@ -270,38 +255,6 @@ toMasterHandlerMaybe :: (Route sub -> Route master) -> GHandler sub' master a toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) --- | A generic handler monad, which can have a different subsite and master --- site. We define a newtype for better error message. -newtype GHandler sub master a = GHandler - { unGHandler :: HandlerData sub master -> ResourceT IO a - } - -data GHState = GHState - { ghsSession :: SessionMap - , ghsRBC :: Maybe RequestBodyContents - , ghsIdent :: Int - , ghsCache :: Cache.Cache - , ghsHeaders :: Endo [Header] - } - -type SessionMap = Map.Map Text S.ByteString - --- | 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 'GHandler' monad and template haskell code should hide it away. -newtype YesodApp = YesodApp - { unYesodApp - :: (ErrorResponse -> YesodApp) - -> Request - -> [ContentType] - -> SessionMap - -> ResourceT IO YesodAppResult - } - -data YesodAppResult - = YARWai W.Response - | YARPlain H.Status [Header] ContentType Content SessionMap - getRequest :: GHandler s m Request getRequest = handlerRequest `liftM` ask @@ -1003,71 +956,3 @@ local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub master a -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r - --- | The standard @MonadTrans@ class only allows lifting for monad --- transformers. While @GHandler@ and @GWidget@ should allow lifting, their --- types do not express that they actually are transformers. This replacement --- class accounts for this. -class MonadLift base m | m -> base where - lift :: base a -> m a -instance (Monad m, MonadTrans t) => MonadLift m (t m) where - lift = Control.Monad.Trans.Class.lift -instance MonadLift (ResourceT IO) (GHandler sub master) where - lift = GHandler . const - --- Instances for GHandler -instance Functor (GHandler sub master) where - fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) -instance Applicative (GHandler sub master) where - pure = GHandler . const . pure - GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r -instance Monad (GHandler sub master) where - return = pure - GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r -instance MonadIO (GHandler sub master) where - liftIO = GHandler . const . lift -instance MonadBase IO (GHandler sub master) where - liftBase = GHandler . const . lift --- | 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 IO (GHandler sub master) where - data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) - liftBaseWith f = GHandler $ \reader -> - liftBaseWith $ \runInBase -> - f $ liftM StH . runInBase . (\(GHandler r) -> r reader) - restoreM (StH base) = GHandler $ const $ restoreM base - -instance MonadUnsafeIO (GHandler sub master) where - unsafeLiftIO = liftIO -instance MonadThrow (GHandler sub master) where - monadThrow = liftIO . throwIO -instance MonadResource (GHandler sub master) where -#if MIN_VERSION_resourcet(0,4,0) - liftResourceT = lift . liftResourceT -#else - allocate a = lift . allocate a - register = lift . register - release = lift . release - resourceMask = lift . resourceMask -#endif - -instance MonadLogger (GHandler sub master) where -#if MIN_VERSION_monad_logger(0, 3, 0) - monadLoggerLog a b c d = do - hd <- ask - liftIO $ handlerLog hd a b c (toLogStr d) -#else - monadLoggerLog a c d = monadLoggerLogSource a "" c d - monadLoggerLogSource a b c d = do - hd <- ask - liftIO $ handlerLog hd a b c (toLogStr d) -#endif - -instance Exception e => Failure e (GHandler sub master) where - failure = liftIO . throwIO diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index 23ebc15f..1ea65523 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -30,108 +30,24 @@ module Yesod.Internal , tokenKey ) where -import Text.Hamlet (HtmlUrl, Html) +import Text.Hamlet (HtmlUrl) import Text.Blaze.Html (toHtml) -import Text.Julius (JavascriptUrl) -import Data.Monoid (Monoid (..), Last) import Data.List (nub) -import Data.Text (Text) - -import Data.Typeable (Typeable) -import Control.Exception (Exception) - -import qualified Network.HTTP.Types as H import Data.String (IsString) -import qualified Data.Map as Map -import Data.Text.Lazy.Builder (Builder) -import Web.Cookie (SetCookie (..)) -import Data.ByteString (ByteString) -import qualified Network.Wai as W -import Yesod.Content (ChooseRep, ContentType) - --- | Responses to indicate some form of an error occurred. These are different --- from 'SpecialResponse' in that they allow for custom error pages. -data ErrorResponse = - NotFound - | InternalError Text - | InvalidArgs [Text] - | PermissionDenied Text - | BadMethod H.Method - deriving (Show, Eq, Typeable) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie SetCookie - | DeleteCookie ByteString ByteString - | Header ByteString ByteString - deriving (Eq, Show) +import Yesod.Core.Types langKey :: IsString a => a langKey = "_LANG" -data Location url = Local url | Remote Text - deriving (Show, Eq) locationToHtmlUrl :: Location url -> HtmlUrl url locationToHtmlUrl (Local url) render = toHtml $ render url [] locationToHtmlUrl (Remote s) _ = toHtml s -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } - deriving (Show, Eq) -data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } - -newtype Head url = Head (HtmlUrl url) - deriving Monoid -newtype Body url = Body (HtmlUrl url) - deriving Monoid - tokenKey :: IsString a => a tokenKey = "_TOKEN" - -type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder - -data GWData a = GWData - { gwdBody :: !(Body a) - , gwdTitle :: !(Last Title) - , gwdScripts :: !(UniqueList (Script a)) - , gwdStylesheets :: !(UniqueList (Stylesheet a)) - , gwdCss :: !(Map.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) - (Map.unionWith mappend a5 b5) - (a6 `mappend` b6) - (a7 `mappend` b7) - -data HandlerContents = - HCContent H.Status ChooseRep - | HCError ErrorResponse - | HCSendFile ContentType FilePath (Maybe W.FilePart) - | HCRedirect H.Status Text - | HCCreated Text - | HCWai W.Response - deriving Typeable - -instance Show HandlerContents where - show _ = "Cannot show a HandlerContents" -instance Exception HandlerContents diff --git a/yesod-core/Yesod/Internal/Cache.hs b/yesod-core/Yesod/Internal/Cache.hs index 4aec0d29..0fc2d2a1 100644 --- a/yesod-core/Yesod/Internal/Cache.hs +++ b/yesod-core/Yesod/Internal/Cache.hs @@ -14,15 +14,9 @@ import qualified Data.IntMap as Map import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL)) import Language.Haskell.TH (appE) import Data.Unique (hashUnique, newUnique) -import GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) -import Data.Monoid (Monoid) import Control.Applicative ((<$>)) - -newtype Cache = Cache (Map.IntMap Any) - deriving Monoid - -newtype CacheKey a = CacheKey Int +import Yesod.Core.Types -- | Generate a new 'CacheKey'. Be sure to give a full type signature. mkCacheKey :: Q Exp diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 31c25ba8..f0b9764c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances #-} -- | The basic typeclass for a Yesod application. module Yesod.Internal.Core ( -- * Type classes @@ -95,6 +96,7 @@ import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerP import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) import System.Log.FastLogger.Date (ZonedDate) import System.IO (stdout) +import Yesod.Core.Types yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version @@ -126,18 +128,6 @@ class YesodDispatch sub master where -> W.Application yesodRunner = defaultYesodRunner --- | 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 - -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute a => Yesod a where @@ -472,9 +462,6 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req maxLen = maximumContentLength master $ fmap toMasterRoute murl handler = yesodMiddleware handler' -data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text - deriving (Eq, Show, Read) - -- | 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). @@ -664,16 +651,6 @@ $newline never : attrs ) -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 - left :: Either a b -> Maybe a left (Left x) = Just x left _ = Nothing @@ -874,3 +851,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + +instance YesodDispatch WaiSubsite master where + yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index a85bfe52..74539a48 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -43,17 +43,7 @@ import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word64) import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(Text, Text)] - , reqCookies :: [(Text, Text)] - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [Text] - -- | A random, session-specific token used to prevent CSRF attacks. - , reqToken :: Maybe Text - } +import Yesod.Core.Types parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session @@ -149,19 +139,6 @@ randomString len = take len . map toChar . randomRs (0, 61) | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(Text, Text)] - , [(Text, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileSource :: Source (ResourceT IO) ByteString - , fileMove :: FilePath -> IO () - } - mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs) @@ -170,7 +147,3 @@ mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourc mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) - -data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) - | FileUploadDisk (NWP.BackEnd FilePath) - | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index dac74a41..0dc0de9e 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -8,32 +8,16 @@ module Yesod.Internal.Session , SessionBackend(..) ) where -import Yesod.Internal (Header(..)) import qualified Web.ClientSession as CS -import Data.Int (Int64) import Data.Serialize import Data.Time import Data.ByteString (ByteString) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (forever, guard) -import Data.Text (Text, pack, unpack) -import Control.Arrow (first) -import Control.Applicative ((<$>)) - -import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text) +import Yesod.Core.Types +import Yesod.Core.Time import qualified Data.IORef as I -import qualified Network.Wai as W - -type BackendSession = [(Text, S8.ByteString)] - -type SaveSession = BackendSession -- ^ The session contents after running the handler - -> IO [Header] - -newtype SessionBackend master = SessionBackend - { sbLoadSession :: master - -> W.Request - -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session - } encodeClientSession :: CS.Key -> CS.IV @@ -58,19 +42,6 @@ decodeClientSession key date rhost encrypted = do guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = do - either putTime putByteString a - put b - put (map (first unpack) c) - get = do - a <- getTime - b <- get - c <- map (first pack) <$> get - return $ SessionCookie (Left a) b c - ---------------------------------------------------------------------- @@ -81,13 +52,6 @@ instance Serialize SessionCookie where -- The cached date is updated every 10s, we don't need second -- resolution for session expiration times. -data ClientSessionDateCache = - ClientSessionDateCache { - csdcNow :: !UTCTime - , csdcExpires :: !UTCTime - , csdcExpiresSerialized :: !ByteString - } deriving (Eq, Show) - clientSessionDateCacher :: NominalDiffTime -- ^ Inactive session valitity. -> IO (IO ClientSessionDateCache, IO ()) @@ -104,27 +68,3 @@ clientSessionDateCacher validity = do doUpdate ref = do threadDelay 10000000 -- 10s I.writeIORef ref =<< getUpdated - - ----------------------------------------------------------------------- - - -putTime :: Putter UTCTime -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 diff --git a/yesod-core/Yesod/Message.hs b/yesod-core/Yesod/Message.hs deleted file mode 100644 index 1b76820e..00000000 --- a/yesod-core/Yesod/Message.hs +++ /dev/null @@ -1,6 +0,0 @@ --- | This module has moved to "Text.Shakespeare.I18N" -module Yesod.Message - ( module Text.Shakespeare.I18N - ) where - -import Text.Shakespeare.I18N diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 6642bc60..c6fc55eb 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -52,13 +52,11 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Handler - ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod + ( YesodSubRoute(..), toMasterHandlerMaybe, getYesod , getMessageRender, getUrlRenderParams, MonadLift (..) ) -import Yesod.Message (RenderMessage) -import Yesod.Content (RepHtml (..), toContent) -import Control.Applicative (Applicative (..), (<$>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Text.Shakespeare.I18N (RenderMessage) +import Yesod.Content (toContent) import Yesod.Internal import Control.Monad (liftM) import Data.Text (Text) @@ -66,32 +64,16 @@ 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 Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Exception (throwIO) import qualified Text.Hamlet as NP -import Data.Text.Lazy.Builder (fromLazyText, Builder) +import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL -import Control.Monad.Base (MonadBase (liftBase)) -import Control.Arrow (first) -import Control.Monad.Trans.Resource -import Control.Monad.Logger +import Yesod.Core.Types preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup --- | 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 GWidget sub master a = GWidget - { unGWidget :: GHandler sub master (a, GWData (Route master)) - } - -instance (a ~ ()) => Monoid (GWidget sub master a) where - mempty = return () - mappend x y = x >> y - addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a addSubWidget sub (GWidget w) = do master <- lift getYesod @@ -103,17 +85,6 @@ addSubWidget sub (GWidget w) = do class ToWidget sub master a where toWidget :: a -> GWidget sub master () -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 :: Builder } - instance render ~ RY master => ToWidget sub master (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty instance render ~ RY master => ToWidget sub master (render -> Css) where @@ -216,16 +187,6 @@ addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty --- | 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 - } - whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings @@ -264,58 +225,6 @@ ihamletToRepHtml ih = do tell :: GWData (Route master) -> GWidget sub master () tell w = GWidget $ return ((), w) -instance MonadLift (GHandler sub master) (GWidget sub master) where - lift = GWidget . fmap (\x -> (x, mempty)) - -- | Type-restricted version of @lift@ liftW :: GHandler sub master a -> GWidget sub master a liftW = lift - --- Instances for GWidget -instance Functor (GWidget sub master) where - fmap f (GWidget x) = GWidget (fmap (first f) x) -instance Applicative (GWidget sub master) where - pure a = GWidget $ pure (a, mempty) - GWidget f <*> GWidget v = - GWidget $ k <$> f <*> v - where - k (a, wa) (b, wb) = (a b, wa `mappend` wb) -instance Monad (GWidget sub master) where - return = pure - GWidget x >>= f = GWidget $ do - (a, wa) <- x - (b, wb) <- unGWidget (f a) - return (b, wa `mappend` wb) -instance MonadIO (GWidget sub master) where - liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO -instance MonadBase IO (GWidget sub master) where - liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase -instance MonadBaseControl IO (GWidget sub master) where - data StM (GWidget sub master) a = - StW (StM (GHandler sub master) (a, GWData (Route master))) - liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> - liftM (\x -> (x, mempty)) - (f $ liftM StW . runInBase . unGWidget) - restoreM (StW base) = GWidget $ restoreM base - -instance MonadUnsafeIO (GWidget sub master) where - unsafeLiftIO = liftIO -instance MonadThrow (GWidget sub master) where - monadThrow = liftIO . throwIO -instance MonadResource (GWidget sub master) where -#if MIN_VERSION_resourcet(0,4,0) - liftResourceT = lift . liftResourceT -#else - allocate a = lift . allocate a - register = lift . register - release = lift . release - resourceMask = lift . resourceMask -#endif - -instance MonadLogger (GWidget sub master) where -#if MIN_VERSION_monad_logger(0, 3, 0) - monadLoggerLog a b c = lift . monadLoggerLog a b c -#else - monadLoggerLog a b = lift . monadLoggerLog a b - monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c -#endif diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index efdc4d89..424e3fea 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -80,9 +80,9 @@ library , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2 - , monad-logger >= 0.2.1 && < 0.4 + , monad-logger >= 0.3 && < 0.4 , conduit >= 0.5 - , resourcet >= 0.3 && < 0.5 + , resourcet >= 0.4 && < 0.5 , lifted-base >= 0.1 , attoparsec-conduit , blaze-html >= 0.5 @@ -95,13 +95,15 @@ library Yesod.Handler Yesod.Request Yesod.Widget - Yesod.Message Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request + Yesod.Core.Types + Yesod.Core.Time + Yesod.Core.Trans.Class Paths_yesod_core ghc-options: -Wall