Merge pull request #189 from silkapp/master

Fix wrong parsing of arrays with text "NULL"
lpsmith · Jun 10, 2016 · b40cd4f · b40cd4f
2 parents 86ef90b + 74b2f4a
commit b40cd4f
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 17 deletions.
diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs
@@ -526,7 +526,7 @@ fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
     fElem = f{ typeOid = typoid (typelem typeInfo) }
 
     parseIt item =
-        fieldParser f' $ if item' == "NULL" then Nothing else Just item'
+        fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
       where
         item' = fmt delim item
         f' | Arrays.Array _ <- item = f

diff --git a/test/Main.hs b/test/Main.hs
@@ -39,23 +39,24 @@ tests :: TestEnv -> TestTree
 tests env = testGroup "tests"
     $ map ($ env)
     [ testBytea
-    , testCase "ExecuteMany"   . testExecuteMany
-    , testCase "Fold"          . testFold
-    , testCase "Notify"        . testNotify
-    , testCase "Serializable"  . testSerializable
-    , testCase "Time"          . testTime
-    , testCase "Array"         . testArray
-    , testCase "HStore"        . testHStore
-    , testCase "JSON"          . testJSON
-    , testCase "Savepoint"     . testSavepoint
-    , testCase "Unicode"       . testUnicode
-    , testCase "Values"        . testValues
-    , testCase "Copy"          . testCopy
+    , testCase "ExecuteMany"        . testExecuteMany
+    , testCase "Fold"               . testFold
+    , testCase "Notify"             . testNotify
+    , testCase "Serializable"       . testSerializable
+    , testCase "Time"               . testTime
+    , testCase "Array"              . testArray
+    , testCase "Array of nullables" . testNullableArray
+    , testCase "HStore"             . testHStore
+    , testCase "JSON"               . testJSON
+    , testCase "Savepoint"          . testSavepoint
+    , testCase "Unicode"            . testUnicode
+    , testCase "Values"             . testValues
+    , testCase "Copy"               . testCopy
     , testCopyFailures
-    , testCase "Double"        . testDouble
-    , testCase "1-ary generic" . testGeneric1
-    , testCase "2-ary generic" . testGeneric2
-    , testCase "3-ary generic" . testGeneric3
+    , testCase "Double"             . testDouble
+    , testCase "1-ary generic"      . testGeneric1
+    , testCase "2-ary generic"      . testGeneric2
+    , testCase "3-ary generic"      . testGeneric3
     ]
 
 testBytea :: TestEnv -> TestTree
@@ -177,6 +178,14 @@ testArray TestEnv{..} = do
     queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
     queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
 
+testNullableArray :: TestEnv -> Assertion
+testNullableArray TestEnv{..} = do
+    xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"
+    xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]
+    xs <- query_ conn "SELECT '{sometext, NULL}'::_text"
+    xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]
+    queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)
+
 testHStore :: TestEnv -> Assertion
 testHStore TestEnv{..} = do
     execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"