b0cbeed · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Do not escape content for style and script elements.

b0cbeedLuigy Leon10 years ago

src/Reflex/Dom/Builder/Static.hs+21−11

compare with develop

unifiedsplit

@@ -24,6 +24,7 @@ import Control.Monad.Primitive

24import Control.Monad.Ref

25import Control.Monad.State.Strict

26import Control.Monad.Trans.Control

27+import Control.Monad.Trans.Reader

27import Data.ByteString (ByteString)

28import Data.ByteString (ByteString)

28import Data.ByteString.Builder (Builder, byteString, toLazyByteString)

29import Data.ByteString.Builder (Builder, byteString, toLazyByteString)

29import qualified Data.ByteString.Lazy as LBS

30import qualified Data.ByteString.Lazy as LBS

@@ -36,6 +37,7 @@ import Data.Functor.Misc

36import qualified Data.Map as Map

37import qualified Data.Map as Map

37import Data.Monoid

38import Data.Monoid

38import qualified Data.Set as Set

39import qualified Data.Set as Set

40+import Data.Text (Text)

39import Data.Text.Encoding

41import Data.Text.Encoding

40import Data.Tuple

42import Data.Tuple

41import GHC.Generics

43import GHC.Generics

@@ -49,8 +51,10 @@ import Reflex.PerformEvent.Class

49import Reflex.PostBuild.Class

51import Reflex.PostBuild.Class

50import Reflex.Spider

52import Reflex.Spider

54+data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }

55+

52newtype StaticDomBuilderT t m a = StaticDomBuilderT

56newtype StaticDomBuilderT t m a = StaticDomBuilderT

53− { unStaticDomBuilderT :: StateT [Behavior t Builder] m a -- Accumulated Html will be in reversed order

57+ { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order

54 }

58 }

55 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

59 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

@@ -59,11 +63,11 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where

59 primitive = lift . primitive

63 primitive = lift . primitive

61instance MonadTrans (StaticDomBuilderT t) where

65instance MonadTrans (StaticDomBuilderT t) where

62− lift = StaticDomBuilderT . lift

66+ lift = StaticDomBuilderT . lift . lift

64−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t Builder)

68+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)

65−runStaticDomBuilderT (StaticDomBuilderT a) = do

69+runStaticDomBuilderT (StaticDomBuilderT a) e = do

66− (result, a') <- runStateT a []

70+ (result, a') <- runStateT (runReaderT a e) []

67 return (result, mconcat $ reverse a')

71 return (result, mconcat $ reverse a')

69instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where

73instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where

@@ -134,14 +138,16 @@ instance DomSpace StaticDomSpace where

134

138

135instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where

139instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where

136 runWithReplace a0 a' = do

140 runWithReplace a0 a' = do

141+ e <- StaticDomBuilderT ask

137− (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')

142+ (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

138 o <- hold (snd result0) $ snd <$> result'

143 o <- hold (snd result0) $ snd <$> result'

139 StaticDomBuilderT $ modify $ (:) $ join o

144 StaticDomBuilderT $ modify $ (:) $ join o

140 return (fst result0, fst <$> result')

145 return (fst result0, fst <$> result')

141 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

146 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

147+ e <- StaticDomBuilderT ask

142− let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0

148+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0

143 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

149 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

144− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . runStaticDomBuilderT) mv)) p

150+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . flip runStaticDomBuilderT e) mv)) p

145 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

151 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

146 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

152 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

147 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

153 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

@@ -163,17 +169,20 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

163 {-# INLINABLE textNode #-}

169 {-# INLINABLE textNode #-}

164 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do

170 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do

165 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

171 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

172+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

166− let escape = fromHtmlEscapedText

173+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

167 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents

174 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents

168 return $ TextNode ()

175 return $ TextNode ()

169 {-# INLINABLE element #-}

176 {-# INLINABLE element #-}

170 element elementTag cfg child = do

177 element elementTag cfg child = do

171 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements

178 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements

172 let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]

179 let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]

180+ let noEscapeElements = Set.fromList ["style", "script"]

173 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""

181 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""

174 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

182 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

175 StaticDomBuilderT $ do

183 StaticDomBuilderT $ do

184+ let shouldEscape = elementTag `Set.notMember` noEscapeElements

176− (result, innerHtml) <- lift $ runStaticDomBuilderT child

185+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape

177 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

186 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

178 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

187 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

179 let tagBS = encodeUtf8 elementTag

188 let tagBS = encodeUtf8 elementTag

@@ -235,7 +244,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)

235renderStatic w = do

244renderStatic w = do

236 runSpiderHost $ do

245 runSpiderHost $ do

237 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

246 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

247+ let env0 = StaticDomBuilderEnv True

238− ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)

248+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

239 mPostBuildTrigger <- readRef postBuildTriggerRef

249 mPostBuildTrigger <- readRef postBuildTriggerRef

240 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

250 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

241 bs' <- sample bs

251 bs' <- sample bs