haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

addCassiusMedia

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-08 11:53:54 +03:00
parent b778372e2f
commit e114a057fb
6 changed files with 102 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
Test/Media.hs Normal file
View File

@ -0,0 +1,64 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Test.Media (mediaTest) where
import Yesod.Core hiding (Request)
import Test.Framework (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
import Network.Wai
import Network.Wai.Test
import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Text as TS
import Text.Lucius
data Y = Y
mkYesod "Y" [$parseRoutes|
/ RootR GET
/static StaticR GET
|]
instance Yesod Y where
approot _ = ""
addStaticContent _ _ content = do
tm <- getRouteToMaster
route <- getCurrentRoute
case fmap tm route of
Just StaticR -> return $ Just $ Left $
if content == "foo2{bar:baz}"
then "screen.css"
else "all.css"
_ -> return Nothing
getRootR = defaultLayout $ do
addCassius [$lucius|foo1{bar:baz}|]
addCassiusMedia "screen" [$lucius|foo2{bar:baz}|]
addCassius [$lucius|foo3{bar:baz}|]
getStaticR = getRootR
runner f = toWaiApp Y >>= runSession f
defaultRequest = Request
{ pathInfo = []
, requestHeaders = []
, queryString = []
, requestMethod = "GET"
}
caseMedia = runner $ do
res <- request defaultRequest
assertStatus 200 res
flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><style>foo1{bar:baz}foo3{bar:baz}</style><style media=\"screen\">foo2{bar:baz}</style></head><body></body></html>"
caseMediaLink = runner $ do
res <- request defaultRequest { pathInfo = ["static"] }
assertStatus 200 res
flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
mediaTest = testGroup "Test.Media"
[ testCase "media" caseMedia
, testCase "media link" caseMediaLink
]

5
Yesod/Internal.hs
View File

@ -43,6 +43,7 @@ import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.String (IsString) import Data.String (IsString)
import qualified Data.Map as Map
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -111,7 +112,7 @@ data GWData a = GWData
!(Last Title) !(Last Title)
!(UniqueList (Script a)) !(UniqueList (Script a))
!(UniqueList (Stylesheet a)) !(UniqueList (Stylesheet a))
!(Maybe (Cassius a)) !(Map.Map (Maybe Text) (Cassius a)) -- media type
!(Maybe (Julius a)) !(Maybe (Julius a))
!(Head a) !(Head a)
instance Monoid (GWData a) where instance Monoid (GWData a) where
@ -122,6 +123,6 @@ instance Monoid (GWData a) where
(a2 `mappend` b2) (a2 `mappend` b2)
(a3 `mappend` b3) (a3 `mappend` b3)
(a4 `mappend` b4) (a4 `mappend` b4)
(a5 `mappend` b5) (Map.unionWith mappend a5 b5)
(a6 `mappend` b6) (a6 `mappend` b6)
(a7 `mappend` b7) (a7 `mappend` b7)

35
Yesod/Internal/Core.hs
View File

@ -478,13 +478,14 @@ widgetToPageContent (GWidget w) = do
Nothing -> Nothing Nothing -> Nothing
Just (Left s) -> Just s Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p Just (Right (u, p)) -> Just $ render u p
cssLoc <- css <- flip mapM (Map.toList style) $ \(mmedia, content) -> do
case style of let rendered = renderCassius render content
Nothing -> return Nothing x <- addStaticContent "css" "text/css; charset=utf-8"
Just s -> do $ encodeUtf8 rendered
x <- addStaticContent "css" "text/css; charset=utf-8" return (mmedia,
$ encodeUtf8 $ renderCassius render s case x of
return $ renderLoc x Nothing -> Left $ preEscapedLazyText rendered
Just y -> Right $ either id (uncurry render) y)
jsLoc <- jsLoc <-
case jscript of case jscript of
Nothing -> return Nothing Nothing -> return Nothing
@ -504,6 +505,10 @@ widgetToPageContent (GWidget w) = do
: ("href", renderLoc' render' loc) : ("href", renderLoc' render' loc)
: attrs : attrs
) )
let left (Left x) = Just x
left _ = Nothing
right (Right x) = Just x
right _ = Nothing
let head'' = let head'' =
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -514,11 +519,17 @@ $forall s <- scripts
^{mkScriptTag s} ^{mkScriptTag s}
$forall s <- stylesheets $forall s <- stylesheets
^{mkLinkTag s} ^{mkLinkTag s}
$maybe s <- style $forall s <- css
$maybe s <- cssLoc $maybe t <- right $ snd s
<link rel=stylesheet href=#{s} $maybe media <- fst s
$nothing <link rel=stylesheet media=#{media} href=#{t}
<style>^{celper s} $nothing
<link rel=stylesheet href=#{t}
$maybe content <- left $ snd s
$maybe media <- fst s
<style media=#{media}>#{content}
$nothing
<style>#{content}
$maybe j <- jscript $maybe j <- jscript
$maybe s <- jsLoc $maybe s <- jsLoc
<script src="#{s}"> <script src="#{s}">

10
Yesod/Widget.hs
View File

@ -20,6 +20,7 @@ module Yesod.Widget
, addSubWidget , addSubWidget
-- ** CSS -- ** CSS
, addCassius , addCassius
, addCassiusMedia
, addStylesheet , addStylesheet
, addStylesheetAttrs , addStylesheetAttrs
, addStylesheetRemote , addStylesheetRemote
@ -52,6 +53,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
import Yesod.Internal import Yesod.Internal
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as Map
import Control.Monad.IO.Control (MonadControlIO) import Control.Monad.IO.Control (MonadControlIO)
@ -120,9 +122,13 @@ addHtml = addHamlet . const
addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo () addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
addWidget = id addWidget = id
-- | Add some raw CSS to the style tag. -- | Add some raw CSS to the style tag. Applies to all media types.
addCassius :: Monad m => Cassius (Route master) -> GGWidget master m () addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
-- | Add some raw CSS to the style tag, for a specific media type.
addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
-- | Link to the specified local stylesheet. -- | Link to the specified local stylesheet.
addStylesheet :: Monad m => Route master -> GGWidget master m () addStylesheet :: Monad m => Route master -> GGWidget master m ()

2
runtests.hs
View File

@ -2,10 +2,12 @@ import Test.Framework (defaultMain)
import Test.CleanPath import Test.CleanPath
import Test.Exceptions import Test.Exceptions
import Test.Widget import Test.Widget
import Test.Media
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
[ cleanPathTest [ cleanPathTest
, exceptionsTest , exceptionsTest
, widgetTest , widgetTest
, mediaTest
] ]

2
yesod-core.cabal
View File

@ -62,6 +62,8 @@ library
Yesod.Internal.Dispatch Yesod.Internal.Dispatch
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall
if flag(test)
Buildable: False
executable runtests executable runtests
if flag(ghc7) if flag(ghc7)