Merge pull request #1139 from haskell/issue-1138-unescp-cc

Fix #1138: Check for control characters in text literals everywhere

Author: phadej

aeson.cabal

@@ -176,6 +176,7 @@ test-suite aeson-tests
     Regression.Issue571
     Regression.Issue687
     Regression.Issue967
+    Regression.Issue1138
     RFC8785
     SerializationFormatSpec
     Types

src/Data/Aeson/Decoding/ByteString.hs

@@ -153,7 +153,9 @@ scanStringLiteral ok err bs0 = go 0 bs0 where
             Right t -> ok t (BS.drop (n + 1) bs0)
             Left e  -> err (show e)
         Just (92, bs') -> goSlash (n + 1) bs'
-        Just (_,  bs') -> goEsc (n + 1) bs'
+        Just (w8, bs')
+            | w8 < 0x20  -> errCC
+            | otherwise  -> goEsc (n + 1) bs'
 
     goSlash :: Int -> ByteString -> r
     goSlash !n !bs = case BS.uncons bs of

src/Data/Aeson/Decoding/ByteString/Lazy.hs

@@ -159,7 +159,9 @@ scanStringLiteral ok err bs0 = go 0 bs0 where
             Right t -> ok t (lbsDrop (n + 1) bs0)
             Left e  -> err (show e)
         Just (92, bs') -> goSlash (n + 1) bs'
-        Just (_,  bs') -> goEsc (n + 1) bs'
+        Just (w8, bs')
+            | w8 < 0x20  -> errCC
+            | otherwise  -> goEsc (n + 1) bs'
 
     goSlash :: Int -> ByteString -> r
     goSlash !n !bs = case LBS.uncons bs of

src/Data/Aeson/Decoding/Text.hs

@@ -163,7 +163,9 @@ scanStringLiteral ok err bs0 = go 0 bs0 where
             Right t -> ok t (unsafeDropPoints (n + 1) bs0)
             Left e  -> err (show e)
         Just (92, bs') -> goSlash (n + 1) bs'
-        Just (_,  bs') -> goEsc (n + 1) bs'
+        Just (w8, bs')
+            | w8 < 0x20  -> errCC
+            | otherwise  -> goEsc (n + 1) bs'
 
     goSlash :: Int -> Text -> r
     goSlash !n !bs = case unconsPoint bs of

tests/Regression/Issue1138.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Regression.Issue1138 (issue1138) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, assertFailure)
+
+import Data.Aeson
+
+assertDecodeFailure :: Either String Value -> IO ()
+assertDecodeFailure (Right v) = assertFailure $ "Unexpected success: " ++ show v
+assertDecodeFailure (Left _)  = return ()
+
+issue1138 :: TestTree
+issue1138 = testGroup "Issue #1138" $ map (testCase "-")
+  [ assertDecodeFailure $ eitherDecode "\"\t\""
+  , assertDecodeFailure $ eitherDecode "\"\\\\\t\""
+
+  , assertDecodeFailure $ eitherDecodeStrict "\"\t\""
+  , assertDecodeFailure $ eitherDecodeStrict "\"\\\\\t\""
+
+  , assertDecodeFailure $ eitherDecodeStrictText "\"\t\""
+  , assertDecodeFailure $ eitherDecodeStrictText "\"\\\\\t\""
+  ]

tests/UnitTests.hs

@@ -64,6 +64,7 @@ import Regression.Issue351
 import Regression.Issue571
 import Regression.Issue687
 import Regression.Issue967
+import Regression.Issue1138
 import UnitTests.OmitNothingFieldsNote
 import UnitTests.FromJSONKey
 import UnitTests.Hashable
@@ -568,6 +569,7 @@ tests = testGroup "unit" [
   , issue571
   , issue687
   , issue967
+  , issue1138
   , keyMapInsertWithTests
   , omitNothingFieldsNoteTests
   , noThunksTests