diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Extra +1.6.6, released 2018-04-16 + Add escapeJSON and unescapeJSON + Add escapeHTML and unescapeHTML 1.6.5, released 2018-03-24 #33, improve error messages on test suite failures 1.6.4, released 2018-02-23 diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: extra -version: 1.6.5 +version: 1.6.6 license: BSD3 license-file: LICENSE category: Development diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -9,6 +9,8 @@ module Data.List, -- * String operations lower, upper, trim, trimStart, trimEnd, word1, line1, + escapeHTML, escapeJSON, + unescapeHTML, unescapeJSON, -- * Splitting dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, @@ -38,6 +40,7 @@ import Data.Char import Data.Tuple.Extra import Data.Monoid +import Numeric import Data.Functor import Prelude @@ -271,6 +274,73 @@ -- > line1 "test\nrest\nmore" == ("test","rest\nmore") line1 :: String -> (String, String) line1 = second drop1 . break (== '\n') + +-- | Escape a string such that it can be inserted into an HTML document or @\"@ attribute +-- without any special interpretation. This requires escaping the @<@, @>@, @&@ and @\"@ characters. +-- Note that it does /not/ escape @\'@, so will not work when placed in a @\'@ delimited attribute. +-- Also note that it will escape @\"@ even though that is not required in an HTML body (but is not harmful). +-- +-- > escapeHTML "this is a test" == "this is a test" +-- > escapeHTML "\"g&t\"" == "<b>"g&t"</n>" +-- > escapeHTML "don't" == "don't" +escapeHTML :: String -> String +escapeHTML = concatMap f + where + f '>' = ">" + f '<' = "<" + f '&' = "&" + f '\"' = """ + f x = [x] + +-- | Invert of 'escapeHTML' (does not do general HTML unescaping) +-- +-- > \xs -> unescapeHTML (escapeHTML xs) == xs +unescapeHTML :: String -> String +unescapeHTML ('&':xs) + | Just xs <- stripPrefix "lt;" xs = '<' : unescapeHTML xs + | Just xs <- stripPrefix "gt;" xs = '>' : unescapeHTML xs + | Just xs <- stripPrefix "amp;" xs = '&' : unescapeHTML xs + | Just xs <- stripPrefix "quot;" xs = '\"' : unescapeHTML xs +unescapeHTML (x:xs) = x : unescapeHTML xs +unescapeHTML [] = [] + + +-- | Escape a string so it can form part of a JSON literal. +-- This requires escaping the special whitespace and control characters. Additionally, +-- Note that it does /not/ add quote characters around the string. +-- +-- > escapeJSON "this is a test" == "this is a test" +-- > escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" +-- > escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" +escapeJSON :: String -> String +escapeJSON x = concatMap f x + where f '\"' = "\\\"" + f '\\' = "\\\\" + -- the spaces are technically optional, but we include them so the JSON is readable + f '\b' = "\\b" + f '\f' = "\\f" + f '\n' = "\\n" + f '\r' = "\\r" + f '\t' = "\\t" + f x | isControl x = "\\u" ++ takeEnd 4 ("0000" ++ showHex (ord x) "") + f x = [x] + +-- | General JSON unescaping, inversion of 'escapeJSON' and all other JSON escapes. +-- +-- > \xs -> unescapeJSON (escapeJSON xs) == xs +unescapeJSON :: String -> String +unescapeJSON ('\\':x:xs) + | x == '\"' = '\"' : unescapeJSON xs + | x == '\\' = '\\' : unescapeJSON xs + | x == '/' = '/' : unescapeJSON xs + | x == 'b' = '\b' : unescapeJSON xs + | x == 'f' = '\f' : unescapeJSON xs + | x == 'n' = '\n' : unescapeJSON xs + | x == 'r' = '\r' : unescapeJSON xs + | x == 't' = '\t' : unescapeJSON xs + | x == 'u', let (a,b) = splitAt 4 xs, length a == 4, [(i, "")] <- readHex a = chr i : unescapeJSON b +unescapeJSON (x:xs) = x : unescapeJSON xs +unescapeJSON [] = [] #if __GLASGOW_HASKELL__ < 709 diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -23,7 +23,7 @@ modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef', -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. - lower, upper, trim, trimStart, trimEnd, word1, line1, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, + lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, -- * Data.Tuple.Extra -- | Extra functions available in @"Data.Tuple.Extra"@. first, second, (***), (&&&), dupe, both, fst3, snd3, thd3, diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -132,6 +132,14 @@ testGen "line1 \"test\\n\" == (\"test\",\"\")" $ line1 "test\n" == ("test","") testGen "line1 \"test\\nrest\" == (\"test\",\"rest\")" $ line1 "test\nrest" == ("test","rest") testGen "line1 \"test\\nrest\\nmore\" == (\"test\",\"rest\\nmore\")" $ line1 "test\nrest\nmore" == ("test","rest\nmore") + testGen "escapeHTML \"this is a test\" == \"this is a test\"" $ escapeHTML "this is a test" == "this is a test" + testGen "escapeHTML \"\\\"g&t\\\"\" == \"<b>"g&t"</n>\"" $ escapeHTML "\"g&t\"" == "<b>"g&t"</n>" + testGen "escapeHTML \"don't\" == \"don't\"" $ escapeHTML "don't" == "don't" + testGen "\\xs -> unescapeHTML (escapeHTML xs) == xs" $ \xs -> unescapeHTML (escapeHTML xs) == xs + testGen "escapeJSON \"this is a test\" == \"this is a test\"" $ escapeJSON "this is a test" == "this is a test" + testGen "escapeJSON \"\\ttab\\nnewline\\\\\" == \"\\\\ttab\\\\nnewline\\\\\\\\\"" $ escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" + testGen "escapeJSON \"\\ESC[0mHello\" == \"\\\\u001b[0mHello\"" $ escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" + testGen "\\xs -> unescapeJSON (escapeJSON xs) == xs" $ \xs -> unescapeJSON (escapeJSON xs) == xs testGen "sortOn fst [(3,\"z\"),(1,\"\"),(3,\"a\")] == [(1,\"\"),(3,\"z\"),(3,\"a\")]" $ sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] testGen "groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,\"t\"),(2,\"es\"),(3,\"t\")]" $ groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,"t"),(2,"es"),(3,"t")] testGen "\\xs -> map fst (groupSort xs) == sort (nub (map fst xs))" $ \xs -> map fst (groupSort xs) == sort (nub (map fst xs)) diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -71,6 +71,9 @@ runTests :: IO () -> IO () runTests t = do + -- ensure that capturing output is robust + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering writeIORef testCount 0 t n <- readIORef testCount