@@ -23,7 +23,7 @@ import Control.Monad.Identity
23import Control.Monad.Primitive
23import Control.Monad.Primitive
24import Control.Monad.Ref
24import Control.Monad.Ref
25import Control.Monad.State.Strict
25import Control.Monad.State.Strict
26−import Control.Monad.Trans.Control
26+import Control.Monad.Trans.Reader
27import Data.ByteString (ByteString)
27import Data.ByteString (ByteString)
28import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
28import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
29import qualified Data.ByteString.Lazy as LBS
29import qualified Data.ByteString.Lazy as LBS
@@ -50,8 +50,10 @@ import Reflex.PostBuild.Base
50import Reflex.Spider
50import Reflex.Spider
51import Reflex.TriggerEvent.Class
51import Reflex.TriggerEvent.Class
53+data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }
53newtype StaticDomBuilderT t m a = StaticDomBuilderT
55newtype StaticDomBuilderT t m a = StaticDomBuilderT
54− { unStaticDomBuilderT :: StateT [Behavior t Builder] m a -- Accumulated Html will be in reversed order
56+ { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
56 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
58 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
@@ -59,17 +61,12 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
59 type PrimState (StaticDomBuilderT x m) = PrimState m
61 type PrimState (StaticDomBuilderT x m) = PrimState m
60 primitive = lift . primitive
62 primitive = lift . primitive
62−instance MonadTransControl (StaticDomBuilderT t) where
63− type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t Builder]) a
64− liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT
65− restoreT = defaultRestoreT StaticDomBuilderT
67instance MonadTrans (StaticDomBuilderT t) where
64instance MonadTrans (StaticDomBuilderT t) where
68− lift = StaticDomBuilderT . lift
65+ lift = StaticDomBuilderT . lift . lift
70−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t Builder)
67+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)
71−runStaticDomBuilderT (StaticDomBuilderT a) = do
68+runStaticDomBuilderT (StaticDomBuilderT a) e = do
72− (result, a') <- runStateT a []
69+ (result, a') <- runStateT (runReaderT a e) []
73 return (result, mconcat $ reverse a')
70 return (result, mconcat $ reverse a')
75instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
72instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
@@ -140,14 +137,16 @@ instance DomSpace StaticDomSpace where
141instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
138instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
142 runWithReplace a0 a' = do
139 runWithReplace a0 a' = do
140+ e <- StaticDomBuilderT ask
143− (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')
141+ (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
144 o <- hold (snd result0) $ snd <$> result'
142 o <- hold (snd result0) $ snd <$> result'
145 StaticDomBuilderT $ modify $ (:) $ join o
143 StaticDomBuilderT $ modify $ (:) $ join o
146 return (fst result0, fst <$> result')
144 return (fst result0, fst <$> result')
147 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
145 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
146+ e <- StaticDomBuilderT ask
148− let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0
147+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0
149 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
148 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
150− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . runStaticDomBuilderT) mv)) p
149+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . flip runStaticDomBuilderT e) mv)) p
151 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
150 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
152 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
151 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
153 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
152 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
@@ -169,24 +168,27 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
169 {-# INLINABLE textNode #-}
168 {-# INLINABLE textNode #-}
170 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do
169 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do
171 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
170 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
171+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
172− let escape = fromHtmlEscapedText
172+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
173 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents
173 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents
174 return $ TextNode ()
174 return $ TextNode ()
175 {-# INLINABLE element #-}
175 {-# INLINABLE element #-}
176 element elementTag cfg child = do
176 element elementTag cfg child = do
177 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
177 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
178 let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]
178 let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]
179+ let noEscapeElements = Set.fromList ["style", "script"]
179 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
180 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
180 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
181 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
181 StaticDomBuilderT $ do
182 StaticDomBuilderT $ do
183+ let shouldEscape = elementTag `Set.notMember` noEscapeElements
182− (result, innerHtml) <- lift $ runStaticDomBuilderT child
184+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape
183 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
185 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
184 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
186 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
185 let tagBS = encodeUtf8 elementTag
187 let tagBS = encodeUtf8 elementTag
186 if Set.member elementTag voidElements
188 if Set.member elementTag voidElements
187 then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
189 then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
189− let open = mconcat [constant ("<" <> byteString tagBS <> " "), attrs1, constant (byteString ">")]
191+ let open = mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString ">")]
190 let close = constant $ byteString $ "</" <> tagBS <> ">"
192 let close = constant $ byteString $ "</" <> tagBS <> ">"
191 modify $ (:) $ mconcat [open, innerHtml, close]
193 modify $ (:) $ mconcat [open, innerHtml, close]
192 return (Element es (), result)
194 return (Element es (), result)
@@ -241,7 +243,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
241renderStatic w = do
243renderStatic w = do
242 runSpiderHost $ do
244 runSpiderHost $ do
243 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
245 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
246+ let env0 = StaticDomBuilderEnv True
244− ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)
247+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
245 mPostBuildTrigger <- readRef postBuildTriggerRef
248 mPostBuildTrigger <- readRef postBuildTriggerRef
246 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
249 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
247 bs' <- sample bs
250 bs' <- sample bs