@@ -24,6 +24,7 @@ import Control.Monad.Primitive
2424import Control.Monad.Ref
2525import Control.Monad.State.Strict
2626import Control.Monad.Trans.Control
27+import Control.Monad.Trans.Reader
2728import Data.ByteString (ByteString)
2829import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
2930import qualified Data.ByteString.Lazy as LBS
@@ -36,6 +37,7 @@ import Data.Functor.Misc
3637import qualified Data.Map as Map
3738import Data.Monoid
3839import qualified Data.Set as Set
40+import Data.Text (Text)
3941import Data.Text.Encoding
4042import Data.Tuple
4143import GHC.Generics
@@ -49,8 +51,10 @@ import Reflex.PerformEvent.Class
4951import Reflex.PostBuild.Class
5052import Reflex.Spider
5153
54+data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }
55+
5256newtype 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
5458 }
5559 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
5660
@@ -59,11 +63,11 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
5963 primitive = lift . primitive
6064
6165instance MonadTrans (StaticDomBuilderT t) where
62− lift = StaticDomBuilderT . lift
66+ lift = StaticDomBuilderT . lift . lift
6367
64−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t Builder)
65−runStaticDomBuilderT (StaticDomBuilderT a) = do
66− (result, a') <- runStateT a []
68+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)
69+runStaticDomBuilderT (StaticDomBuilderT a) e = do
70+ (result, a') <- runStateT (runReaderT a e) []
6771 return (result, mconcat $ reverse a')
6872
6973instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
@@ -134,14 +138,16 @@ instance DomSpace StaticDomSpace where
134138
135139instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
136140 runWithReplace a0 a' = do
137− (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')
141+ e <- StaticDomBuilderT ask
142+ (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
138143 o <- hold (snd result0) $ snd <$> result'
139144 StaticDomBuilderT $ modify $ (:) $ join o
140145 return (fst result0, fst <$> result')
141146 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
142− let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0
147+ e <- StaticDomBuilderT ask
148+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0
143149 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
145151 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
146152 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
147153 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
@@ -163,17 +169,20 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
163169 {-# INLINABLE textNode #-}
164170 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do
165171 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
166− let escape = fromHtmlEscapedText
172+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
173+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
167174 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents
168175 return $ TextNode ()
169176 {-# INLINABLE element #-}
170177 element elementTag cfg child = do
171178 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
172179 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"]
173181 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
174182 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
175183 StaticDomBuilderT $ do
176− (result, innerHtml) <- lift $ runStaticDomBuilderT child
184+ let shouldEscape = elementTag `Set.notMember` noEscapeElements
185+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape
177186 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
178187 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
179188 let tagBS = encodeUtf8 elementTag
@@ -235,7 +244,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
235244renderStatic w = do
236245 runSpiderHost $ do
237246 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
238− ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)
247+ let env0 = StaticDomBuilderEnv True
248+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
239249 mPostBuildTrigger <- readRef postBuildTriggerRef
240250 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
241251 bs' <- sample bs