Issues/Questions about Postgres array support

persistent-postgresql/persistent-postgresql.cabal

@@ -52,6 +52,8 @@ test-suite test
                      JSONTest
                      CustomConstraintTest
                      PgIntervalTest
+                     ArrayTest
+                     ArrayTest.Instances
     ghc-options:     -Wall
 
     build-depends:   base                 >= 4.9 && < 5

persistent-postgresql/test/ArrayTest.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- FIXME
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module ArrayTest where
+
+import Control.Monad.IO.Class (MonadIO)
+import Data.Aeson
+import Data.List (sort)
+import qualified Data.Text as T
+import Test.Hspec.Expectations ()
+
+import PersistentTestModels
+import PgInit
+import ArrayTest.Instances
+
+share [mkPersist persistSettings,  mkMigrate "migrate"] [persistLowerCase|
+  TestRoundtrip
+    test RoundtripTextArray
+    deriving Show Eq
+  TestListHack
+    test ListHackTextArray
+    deriving Show Eq
+  TestIntArray
+    test IntArray
+    deriving Show Eq
+  TestJSONArray
+    test (JSONArray Text)
+    deriving Show Eq
+|]
+
+-- cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m ()
+-- cleanDB = deleteWhere ([] :: [Filter TestValue])
+
+-- setup :: IO TestKeys
+-- setup = asIO $ runConn_ $ do
+--   void $ runMigrationSilent migrate
+
+-- teardown = cleanDB
+
+shouldBeIO :: (Show a, Eq a, MonadIO m) => a -> a -> m ()
+shouldBeIO x y = liftIO $ shouldBe x y
+
+roundTrip :: (MonadIO m, PersistStoreWrite backend,
+                    PersistEntity a, Show a, Eq a,
+                    PersistEntityBackend a ~ BaseBackend backend) =>
+                   a -> ReaderT backend m ()
+roundTrip x = do
+  xId <- insert x
+  maybeX <- get xId
+  case maybeX of
+    Nothing -> error "expected to get Just"
+    Just x2 -> x2 `shouldBeIO` x
+
+specs :: Spec
+specs = do
+  describe "Roundtripping from PersistArray" $ do
+    it "can insert a value serialized to PersistArray, then deserialize from it, and it will be equivalent" $ do
+      runConnAssert $ do
+        -- This will fail, because it will get a PersistList when deserializing instead of a PersistArray
+        roundTrip $ TestRoundtrip $ RoundtripTextArray ["x"]
+    describe "list hack workaround" $ do
+      it "can insert a value serialized to PersistArray, then deserialize from it, and it will be equivalent" $ do
+        runConnAssert $ do
+          roundTrip $ TestListHack $ ListHackTextArray ["x"]
+      it "works on data that will need escaping" $ do
+        runConnAssert $ do
+          roundTrip (TestListHack $ ListHackTextArray ["\""])
+    describe "IntArray" $ do
+      it "works for ints" $ do
+        runConnAssert $ do
+          roundTrip (TestIntArray $ IntArray [1,2,3])
+    describe "JSONArray" $ do
+      it "works for json" $ do
+        runConnAssert $ do
+          -- This will fail with this error:
+          -- SqlError {sqlState = "42804", sqlExecStatus = FatalError, sqlErrorMsg = "column \"test\" is of type jsonb[] but expression is of type text[]", sqlErrorDetail = "", sqlErrorHint = "You will need to rewrite or cast the expression."}
+          roundTrip (TestJSONArray $ JSONArray ["x"])
+
+
+
+
+

persistent-postgresql/test/ArrayTest/Instances.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- FIXME
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module ArrayTest.Instances
+  ( RoundtripTextArray(..)
+  , ListHackTextArray(..)
+  , IntArray(..)
+  , JSONArray(..)
+  ) where
+
+import Control.Monad.IO.Class (MonadIO)
+import Data.Aeson
+import Data.List (sort)
+import qualified Data.Text as T
+import Test.Hspec.Expectations ()
+
+import PersistentTestModels
+import PgInit
+import qualified Data.ByteString.Lazy as BSL
+-- import qualified Data.Text.Lazy.Encoding as DTLE
+-- import qualified Data.Text.Lazy as DTL
+
+newtype RoundtripTextArray = RoundtripTextArray [Text]
+  deriving stock (Show)
+  deriving newtype (Eq, Ord)
+
+instance PersistField RoundtripTextArray where
+  toPersistValue (RoundtripTextArray ts) = PersistArray $ toPersistValue <$> ts
+  fromPersistValue (PersistArray as) = RoundtripTextArray <$> traverse fromPersistValue as
+  -- Note: While we serialized to a PersistArray, we get a PersistList when deserializing. Bug?
+  -- With this next line uncommented, deserializing this will fail
+  -- fromPersistValue (PersistList as) = RoundtripTextArray <$> traverse fromPersistValue as
+  fromPersistValue wat = Left . T.pack $ "RoundtripTextArray: When expecting PersistArray, received: " ++ show wat
+
+instance PersistFieldSql RoundtripTextArray where
+  sqlType _ = SqlOther "text[]"
+
+
+newtype ListHackTextArray = ListHackTextArray [Text]
+  deriving stock (Show)
+  deriving newtype (Eq, Ord)
+
+instance PersistField ListHackTextArray where
+  toPersistValue (ListHackTextArray ts) = PersistArray $ toPersistValue <$> ts
+  fromPersistValue (PersistArray as) = ListHackTextArray <$> traverse fromPersistValue as
+  -- Note: While we serialized to a PersistArray, we get a PersistList when deserializing. Bug?
+  fromPersistValue (PersistList as) = ListHackTextArray <$> traverse fromPersistValue as
+  fromPersistValue wat = Left . T.pack $ "ListHackTextArray: When expecting PersistArray, received: " ++ show wat
+
+instance PersistFieldSql ListHackTextArray where
+  sqlType _ = SqlOther "text[]"
+
+
+newtype IntArray = IntArray [Int]
+  deriving stock (Show)
+  deriving newtype (Eq, Ord)
+
+instance PersistField IntArray where
+  toPersistValue (IntArray ts) = PersistArray $ toPersistValue <$> ts
+  fromPersistValue (PersistArray as) = IntArray <$> traverse fromPersistValue as
+  -- Note: While we serialized to a PersistArray, we get a PersistList when deserializing. Bug?
+  fromPersistValue (PersistList as) = IntArray <$> traverse fromPersistValue as
+  fromPersistValue wat = Left . T.pack $ "IntArray: When expecting PersistArray, received: " ++ show wat
+
+instance PersistFieldSql IntArray where
+  sqlType _ = SqlOther "int[]"
+
+
+newtype JSONArray a = JSONArray [a]
+  deriving (Show, Eq)
+
+instance (ToJSON a, FromJSON a) => PersistField (JSONArray a) where
+  -- Note: You can also serialize to PersistByteString or PersistText, and get the same error
+  toPersistValue (JSONArray xs) = PersistArray $ map (PersistDbSpecific . BSL.toStrict . encode) xs
+  fromPersistValue = error "todo"
+
+-- Started writing an implmentation for this but it was really ugly, realized I didn't need it to demonstrate the error.
+
+--   fromPersistValue (PersistList xs) = 
+--     let eithers :: [Either String a]
+--         eithers = map (eitherDecodeStrict . persistValueToByteString) xs
+
+--         result :: Either String [a]
+--         result = foldl checkForDecodeError (Right []) eithers
+
+--         checkForDecodeError :: Either String [a] -> Either String a -> Either String [a]
+--         checkForDecodeError accum nextValue =
+--            case accum of
+--              Left oldErr -> Left oldErr
+--              Right xs -> case nextValue of
+--                Left newErr -> Left newErr
+--                Right x -> Right (x : xs)
+--     in case result of
+--       Left s -> Left $ T.pack $ "JSONArray: When deserializing a value, got the error: " <> s
+--       Right xs -> Right $ JSONArray xs
+
+-- persistValueToByteString :: PersistValue -> ByteString
+-- persistValueToByteString (PersistByteString bs) = bs
+-- persistValueToByteString (PersistDbSpecific bs) = bs
+-- persistValueToByteString other = error $ "expected bytestring or db specific; got other: " <> show other
+
+instance (ToJSON a, FromJSON a) => PersistFieldSql (JSONArray a) where
+  sqlType _ = SqlOther "jsonb[]"

persistent-postgresql/test/PgInit.hs

@@ -73,7 +73,7 @@ import Database.Persist.Sql
 import Database.Persist.TH ()
 
 _debugOn :: Bool
-_debugOn = False
+_debugOn = True
 
 dockerPg :: IO (Maybe BS.ByteString)
 dockerPg = do

persistent-postgresql/test/main.hs

@@ -53,6 +53,7 @@ import qualified UpsertTest
 import qualified CustomConstraintTest
 import qualified LongIdentifierTest
 import qualified PgIntervalTest
+import qualified ArrayTest
 
 type Tuple = (,)
 
@@ -125,6 +126,7 @@ main = do
       , LongIdentifierTest.migration
       , ForeignKey.compositeMigrate
       , PgIntervalTest.pgIntervalMigrate
+      , ArrayTest.migrate
       ]
     PersistentTest.cleanDB
 
@@ -190,3 +192,4 @@ main = do
     CustomConstraintTest.specs
     PgIntervalTest.specs
     ArrayAggTest.specs
+    ArrayTest.specs