diff --git a/Text/HTML/SanitizeXSS.hs b/Text/HTML/SanitizeXSS.hs
index 0314258..7b5493e 100644
--- a/Text/HTML/SanitizeXSS.hs
+++ b/Text/HTML/SanitizeXSS.hs
@@ -1,4 +1,7 @@
-module Text.HTML.SanitizeXSS (sanitizeXSS) where
+module Text.HTML.SanitizeXSS
+ ( sanitizeXSS
+ , sanitizeBalanceXSS
+ ) where
import Text.HTML.TagSoup
@@ -11,39 +14,50 @@ import Codec.Binary.UTF8.String ( encodeString )
import qualified Data.Map as Map
+sanitizeBalanceXSS :: String -> String
+sanitizeBalanceXSS = renderTagsOptions renderOptions {
+ optMinimize = \x -> x `elem` ["br","img"] -- ![]()
converts to
, converts to
+ } . balance Map.empty . safeTags . parseTags
+
+balance :: Map.Map String Int -> [Tag String] -> [Tag String]
+balance m [] =
+ concatMap go $ Map.toList m
+ where
+ go (name, i)
+ | noClosing name = []
+ | otherwise = replicate i $ TagClose name
+ noClosing = flip elem ["br", "img"]
+balance m (t@(TagClose name):tags) =
+ case Map.lookup name m of
+ Nothing -> TagOpen name [] : TagClose name : balance m tags
+ Just i ->
+ let m' = if i == 1
+ then Map.delete name m
+ else Map.insert name (i - 1) m
+ in t : balance m' tags
+balance m (TagOpen name as : tags) =
+ TagOpen name as : balance m' tags
+ where
+ m' = case Map.lookup name m of
+ Nothing -> Map.insert name 1 m
+ Just i -> Map.insert name (i + 1) m
+balance m (t:ts) = t : balance m ts
+
-- | santize the html to prevent XSS attacks. See README.md for more details
sanitizeXSS :: String -> String
sanitizeXSS = renderTagsOptions renderOptions {
optMinimize = \x -> x `elem` ["br","img"] -- ![]()
converts to
, converts to
- } . safeTags Map.empty . parseTags
- where
- safeTags :: Map.Map String Int -> [Tag String] -> [Tag String]
- safeTags m [] =
- concatMap go $ Map.toList m
- where
- go (name, i)
- | noClosing name = []
- | otherwise = replicate i $ TagClose name
- noClosing = flip elem ["br", "img"]
- safeTags m (t@(TagClose name):tags)
- | safeTagName name =
- case Map.lookup name m of
- Nothing -> TagOpen name [] : TagClose name : safeTags m tags
- Just i ->
- let m' = if i == 1
- then Map.delete name m
- else Map.insert name (i - 1) m
- in t : safeTags m' tags
- | otherwise = safeTags m tags
- safeTags m (TagOpen name attributes:tags)
- | safeTagName name =
- let m' =
- case Map.lookup name m of
- Nothing -> Map.insert name 1 m
- Just i -> Map.insert name (i + 1) m
- in TagOpen name (filter safeAttribute attributes) : safeTags m' tags
- | otherwise = safeTags m tags
- safeTags m (t:tags) = t:safeTags m tags
+ } . safeTags . parseTags
+
+safeTags :: [Tag String] -> [Tag String]
+safeTags [] = []
+safeTags (t@(TagClose name):tags)
+ | safeTagName name = t : safeTags tags
+ | otherwise = safeTags tags
+safeTags (TagOpen name attributes:tags)
+ | safeTagName name = TagOpen name (filter safeAttribute attributes) : safeTags tags
+ | otherwise = safeTags tags
+safeTags (t:tags) = t:safeTags tags
safeTagName :: String -> Bool
safeTagName tagname = tagname `member` sanitaryTags
diff --git a/test.hs b/test.hs
index 106a651..c55e261 100644
--- a/test.hs
+++ b/test.hs
@@ -2,7 +2,7 @@ import Text.HTML.SanitizeXSS
main = do
let test = " safeanchor
Unbalanced
"
- let actual = (sanitizeXSS test)
+ let actual = (sanitizeBalanceXSS test)
let expected = " safeanchor
Unbalanced
"
putStrLn $ "testing: " ++ test
putStrLn $ if actual == expected then "pass" else "failure\n" ++ "\nexpected:" ++ (show expected) ++ "\nactual: " ++ (show actual)