diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index afa861742..92fee72d5 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/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 diff --git a/persistent-postgresql/test/ArrayTest.hs b/persistent-postgresql/test/ArrayTest.hs new file mode 100644 index 000000000..878a11528 --- /dev/null +++ b/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"]) + + + + + diff --git a/persistent-postgresql/test/ArrayTest/Instances.hs b/persistent-postgresql/test/ArrayTest/Instances.hs new file mode 100644 index 000000000..f095f79da --- /dev/null +++ b/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[]" \ No newline at end of file diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index 6e233ea34..59cde31e3 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/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 diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 7cc6330fe..1f1d90b39 100644 --- a/persistent-postgresql/test/main.hs +++ b/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