diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +### 2.0.7 + +* Include aeson's JSON encoding and escape `<`, `>` and `&` to avoid XSS attacks + ### 2.0.6 * Provide the `Text.Hamlet.Runtime` module diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs --- a/Text/CssCommon.hs +++ b/Text/CssCommon.hs @@ -11,7 +11,6 @@ import Language.Haskell.TH import Data.Word (Word8) import Data.Bits -import Data.Text.Lazy.Builder (fromLazyText) import qualified Data.Text.Lazy as TL renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text diff --git a/Text/Julius.hs b/Text/Julius.hs --- a/Text/Julius.hs +++ b/Text/Julius.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for Javascript templates, introducing type-safe, -- compile-time variable and url interpolation.-- @@ -50,7 +52,14 @@ import qualified Data.Text.Lazy as TL import Text.Shakespeare import Data.Aeson (Value) -import Data.Aeson.Encode (fromValue) +import Data.Aeson.Types (Value(..)) +import Numeric (showHex) +import qualified Data.HashMap.Strict as H +import qualified Data.Vector as V +import Data.Text.Lazy.Builder (singleton, fromString) +import qualified Data.Text as T +import Data.Scientific (FPFormat(..), Scientific, base10Exponent) +import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) renderJavascript :: Javascript -> TL.Text renderJavascript (Javascript b) = toLazyText b @@ -80,7 +89,69 @@ toJavascript :: a -> Javascript instance ToJavascript Bool where toJavascript = Javascript . fromText . TS.toLower . TS.pack . show -instance ToJavascript Value where toJavascript = Javascript . fromValue +instance ToJavascript Value where toJavascript = Javascript . encodeToTextBuilder + +-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be +-- embedded efficiently in a text-based protocol. +-- +-- If you are going to immediately encode straight to a +-- 'L.ByteString', it is more efficient to use 'encodeToBuilder' +-- instead. +encodeToTextBuilder :: Value -> Builder +encodeToTextBuilder = + go + where + go Null = {-# SCC "go/Null" #-} "null" + go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false" + go (Number s) = {-# SCC "go/Number" #-} fromScientific s + go (String s) = {-# SCC "go/String" #-} string s + go (Array v) + | V.null v = {-# SCC "go/Array" #-} "[]" + | otherwise = {-# SCC "go/Array" #-} + singleton '[' <> + go (V.unsafeHead v) <> + V.foldr f (singleton ']') (V.unsafeTail v) + where f a z = singleton ',' <> go a <> z + go (Object m) = {-# SCC "go/Object" #-} + case H.toList m of + (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs + _ -> "{}" + where f a z = singleton ',' <> one a <> z + one (k,v) = string k <> singleton ':' <> go v + +string :: T.Text -> Builder +string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"' + where + quote q = case T.uncons t of + Nothing -> fromText h + Just (!c,t') -> fromText h <> escape c <> quote t' + where (h,t) = {-# SCC "break" #-} T.break isEscape q + isEscape c = c == '\"' || + c == '\\' || + c == '<' || + c == '>' || + c == '&' || + c < '\x20' + escape '\"' = "\\\"" + escape '\\' = "\\\\" + escape '\n' = "\\n" + escape '\r' = "\\r" + escape '\t' = "\\t" + escape '<' = "\\u003c" + escape '>' = "\\u003e" + escape '&' = "\\u0026" + + escape c + | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h + | otherwise = singleton c + where h = showHex (fromEnum c) "" + +fromScientific :: Scientific -> Builder +fromScientific s = formatScientificBuilder format prec s + where + (format, prec) + | base10Exponent s < 0 = (Generic, Nothing) + | otherwise = (Fixed, Just 0) newtype RawJavascript = RawJavascript Builder instance ToJavascript RawJavascript where diff --git a/Text/MkSizeType.hs b/Text/MkSizeType.hs --- a/Text/MkSizeType.hs +++ b/Text/MkSizeType.hs @@ -2,6 +2,8 @@ module Text.MkSizeType (mkSizeType) where import Language.Haskell.TH.Syntax +import Data.Text.Lazy.Builder (fromLazyText) +import qualified Data.Text.Lazy as TL mkSizeType :: String -> String -> Q [Dec] mkSizeType name' unit = return [ dataDec name @@ -39,11 +41,10 @@ toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec] where toCssDec = FunD (mkName "toCss") [Clause [] showBody []] showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show') - -- FIXME this whole section makes me a little nervous - from = VarE (mkName "fromLazyText") - pack = VarE (mkName "TL.pack") - dot = VarE (mkName ".") - show' = VarE (mkName "show") + from = VarE 'fromLazyText + pack = VarE 'TL.pack + dot = VarE 'Prelude.fmap + show' = VarE 'Prelude.show instanceType :: String -> Name -> Type instanceType className name = AppT (ConT $ mkName className) (ConT name) diff --git a/shakespeare.cabal b/shakespeare.cabal --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.0.6 +version: 2.0.7 license: MIT license-file: LICENSE author: Michael Snoyman @@ -49,6 +49,9 @@ , blaze-html , exceptions , transformers + , vector + , unordered-containers + , scientific exposed-modules: Text.Shakespeare.I18N Text.Shakespeare.Text diff --git a/test/Text/Shakespeare/JsSpec.hs b/test/Text/Shakespeare/JsSpec.hs --- a/test/Text/Shakespeare/JsSpec.hs +++ b/test/Text/Shakespeare/JsSpec.hs @@ -130,6 +130,12 @@ it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|] + it "< escaping" $ jelper "\"\\u003c\"" [julius|#{toJSON "<"}|] + + it "> escaping" $ jelper "\"\\u003e\"" [julius|#{toJSON ">"}|] + + it "& escaping" $ jelper "\"\\u0026\"" [julius|#{toJSON "&"}|] + it "boolean interpolation" $ jelper "true false true false true false" [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|]