{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module PostgreSQL.Test where import Control.Arrow ((&&&)) import Control.Concurrent (forkIO) import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT, runReaderT) import qualified Control.Monad.Trans.Resource as R import Data.Aeson hiding (Value) import qualified Data.Aeson as A (Value) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import qualified Data.Char as Char import Data.Coerce import Data.Foldable import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Time import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Database.Esqueleto hiding (random_) import Database.Esqueleto.Experimental hiding (from, on, random_) import qualified Database.Esqueleto.Experimental as Experimental import qualified Database.Esqueleto.Internal.Internal as ES import Database.Esqueleto.PostgreSQL (random_, withMaterialized, withNotMaterialized) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON import qualified Database.Persist.Class as P import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn) import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) import System.Environment import Test.Hspec import Test.Hspec.Core.Spec (sequential) import Test.Hspec.QuickCheck import Common.Test import Common.Test.Import hiding (from, on) import PostgreSQL.MigrateJSON spec :: Spec spec = beforeAll mkConnectionPool $ do tests describe "PostgreSQL specific tests" $ do testAscRandom random_ testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc testPostgresqlTwoAscFields testPostgresqlSum testPostgresqlRandom testPostgresqlUpdate testPostgresqlCoalesce testPostgresqlTextFunctions testInsertUniqueViolation testUpsert testInsertSelectWithConflict testFilterWhere testCommonTableExpressions setDatabaseState insertJsonValues cleanJSON $ describe "PostgreSQL JSON tests" $ do testJSONInsertions testJSONOperators testLateralQuery testValuesExpression testSubselectAliasingBehavior testPostgresqlLocking testPostgresqlNullsOrdering returningType :: forall a m . m a -> m a returningType a = a testPostgresqlCoalesce :: SpecDb testPostgresqlCoalesce = do itDb "works on PostgreSQL and MySQL with <2 arguments" $ do void $ returningType @[Value (Maybe Int)] $ select $ from $ \p -> do return (coalesce [p ^. PersonAge]) asserting noExceptions testPostgresqlTextFunctions :: SpecDb testPostgresqlTextFunctions = do describe "text functions" $ do itDb "like, (%) and (++.) work on a simple example" $ do let nameContains t = select $ from $ \p -> do where_ (like (p ^. PersonName) ((%) ++. val t ++. (%))) orderBy [asc (p ^. PersonName)] return p [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] h <- nameContains "h" i <- nameContains "i" iv <- nameContains "iv" asserting $ do h `shouldBe` [p1e, p2e] i `shouldBe` [p4e, p3e] iv `shouldBe` [p4e] itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] let nameContains t = do select $ from $ \p -> do where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) orderBy [asc (p ^. PersonName)] return p mi <- nameContains "mi" john <- nameContains "JOHN" asserting $ do mi `shouldBe` [p3e, p5e] john `shouldBe` [p1e] testPostgresqlUpdate :: SpecDb testPostgresqlUpdate = do itDb "works on a simple example" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 let anon = "Anonymous" () <- update $ \p -> do set p [ PersonName =. val anon , PersonAge *=. just (val 2) ] where_ (p ^. PersonName !=. val "Mike") n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- PostgreSQL: nulls are bigger than data, and update returns -- matched rows, not actually changed rows. asserting $ do n `shouldBe` 2 ret `shouldBe` [ Entity p1k (Person anon (Just 73) Nothing 1) , Entity p2k (Person anon Nothing (Just 37) 2) , Entity p3k p3 ] testPostgresqlRandom :: SpecDb testPostgresqlRandom = do itDb "works with random_" $ do _ <- select $ return (random_ :: SqlExpr (Value Double)) asserting noExceptions testPostgresqlSum :: SpecDb testPostgresqlSum = do itDb "works with sum_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ sum_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] testPostgresqlTwoAscFields :: SpecDb testPostgresqlTwoAscFields = do itDb "works with two ASC fields (one call)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p -- in PostgreSQL nulls are bigger than everything asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] testPostgresqlOneAscOneDesc :: SpecDb testPostgresqlOneAscOneDesc = do itDb "works with one ASC and one DESC field (two calls)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] testSelectDistinctOn :: SpecDb testSelectDistinctOn = do describe "SELECT DISTINCT ON" $ do itDb "works on a simple example" $ do do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [_, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] ret <- select $ from $ \bp -> distinctOn [don (bp ^. BlogPostAuthorId)] $ do orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] return bp liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] let slightlyLessSimpleTest q = do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [bpA, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] ret <- select $ from $ \bp -> q bp $ return bp let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC] itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $ slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId)] $ distinctOn [don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do slightlyLessSimpleTest $ \bp -> distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] itDb "generates correct sql with nested expression (distinctOnOrderBy)" $ do let query = do let orderVal = coalesce [nothing, just $ val (10 :: Int)] distinctOnOrderBy [ asc orderVal, desc orderVal ] $ pure orderVal select query asserting noExceptions testArrayAggWith :: SpecDb testArrayAggWith = do describe "ALL, no ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(\"Person\".\"age\")\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, no ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36] describe "ALL, ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum ]) liftIO $ query `shouldBe` "SELECT array_agg(\"Person\".\"age\" \ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ query `shouldBe` "SELECT array_agg(DISTINCT \"Person\".\"age\" \ \ORDER BY \"Person\".\"age\" ASC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing] testStringAggWith :: SpecDb testStringAggWith = do describe "ALL, no ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") []) liftIO $ query `shouldBe` "SELECT string_agg(\"Person\".\"name\", ?)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people) itDb "works with zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ ret `shouldBe` Nothing describe "DISTINCT, no ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] liftIO $ query `shouldBe` "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] itDb "works on an example" $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] liftIO $ (L.sort $ words ret) `shouldBe` (L.sort . L.nub $ map personName people) describe "ALL, ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum ]) liftIO $ query `shouldBe` "SELECT string_agg(\"Person\".\"name\", ? \ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort $ map personName people) describe "DISTINCT, ORDER BY" $ do itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ query `shouldBe` "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \ \ORDER BY \"Person\".\"name\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] itDb "works on an example" $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort . L.nub $ map personName people) testAggregateFunctions :: SpecDb testAggregateFunctions = do describe "arrayAgg" $ do itDb "looks sane" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) itDb "works on zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` Nothing describe "arrayAggWith" testArrayAggWith describe "stringAgg" $ do itDb "looks sane" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> do return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people) itDb "works on zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ ret `shouldBe` Nothing describe "stringAggWith" testStringAggWith describe "array_remove (NULL)" $ do itDb "removes NULL from arrays from nullable fields" $ do mapM_ insert [ Person "1" Nothing Nothing 1 , Person "2" (Just 7) Nothing 1 , Person "3" (Nothing) Nothing 1 , Person "4" (Just 8) Nothing 2 , Person "5" (Just 9) Nothing 2 ] ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do groupBy (person ^. PersonFavNum) return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg $ person ^. PersonAge liftIO $ (L.sort $ map (L.sort . unValue) ret) `shouldBe` [[7], [8,9]] describe "maybeArray" $ do itDb "Coalesces NULL into an empty array" $ do [Value ret] <- select $ from $ \p -> return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` [] testPostgresModule :: SpecDb testPostgresModule = do describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do propDb "works" $ \run listOfDateParts -> run $ do let utcTimes = map (\(y, m, d, s) -> fromInteger s `addUTCTime` UTCTime (fromGregorian (2000 + y) m d) 0 ) listOfDateParts truncateDate :: SqlExpr (Value String) -- ^ .e.g (val "day") -> SqlExpr (Value UTCTime) -- ^ input field -> SqlExpr (Value UTCTime) -- ^ truncated date truncateDate datePart expr = ES.unsafeSqlFunction "date_trunc" (datePart, expr) vals = zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes for_ vals $ \(idx, utcTime) -> do insertKey idx (DateTruncTest utcTime) -- Necessary to get the test to pass; see the discussion in -- https://github.com/bitemyapp/esqueleto/pull/180 rawExecute "SET TIME ZONE 'UTC'" [] ret <- fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ select $ from $ \dt -> do pure ( dt ^. DateTruncTestId , ( dt ^. DateTruncTestCreated , truncateDate (val "day") (dt ^. DateTruncTestCreated) ) ) asserting $ for_ vals $ \(idx, utcTime) -> do case Map.lookup idx ret of Nothing -> expectationFailure "index not found" Just (original, truncated) -> do utcTime `shouldBe` original if utctDay utcTime == utctDay truncated then utctDay utcTime `shouldBe` utctDay truncated else -- use this if/else to get a better error message utcTime `shouldBe` truncated describe "PostgreSQL module" $ do describe "Aggregate functions" testAggregateFunctions itDb "chr looks sane" $ do [Value (ret :: String)] <- select $ return (EP.chr (val 65)) liftIO $ ret `shouldBe` "A" itDb "allows unit for functions" $ do let fn :: SqlExpr (Value UTCTime) fn = ES.unsafeSqlFunction "now" () vals <- select $ pure fn liftIO $ vals `shouldSatisfy` ((1 ==) . length) itDb "works with now" $ do nowDb <- select $ return EP.now_ nowUtc <- liftIO getCurrentTime let oneSecond = realToFrac (1 :: Double) -- | Check the result is not null liftIO $ nowDb `shouldSatisfy` (not . null) -- | Unpack the now value let (Value now: _) = nowDb -- | Get the time diff and check it's less than a second liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond) testJSONInsertions :: SpecDb testJSONInsertions = describe "JSON Insertions" $ do itDb "adds scalar values" $ do insertIt Null insertIt $ Bool True insertIt $ Number 1 insertIt $ String "test" itDb "adds arrays" $ do insertIt $ toJSON ([] :: [A.Value]) insertIt $ toJSON [Number 1, Bool True, Null] insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] itDb "adds objects" $ do insertIt $ object ["a" .= (1 :: Int), "b" .= False] insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] where insertIt :: MonadIO m => A.Value -> SqlPersistT m () insertIt = insert_ . Json . JSONB testJSONOperators :: SpecDb testJSONOperators = describe "JSON Operators" $ do testArrowOperators testFilterOperators testConcatDeleteOperators testArrowOperators :: SpecDb testArrowOperators = describe "Arrow Operators" $ do testArrowJSONB testArrowText testHashArrowJSONB testHashArrowText testArrowJSONB :: SpecDb testArrowJSONB = describe "Single Arrow (JSONB)" $ do itDb "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) ->. "a") "SELECT (? -> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , PersistText "a" ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" ->. 1) "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False) y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True) z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message") asserting $ do length x `shouldBe` 1 length y `shouldBe` 1 length z `shouldBe` 1 testArrowText :: SpecDb testArrowText = describe "Single Arrow (Text)" $ do itDb "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= True]) ->>. "a") "SELECT (? ->> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , PersistText "a" ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL (jsonbVal obj ->. "a" ->>. 1) "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false") y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true") z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message") liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testHashArrowJSONB :: SpecDb testHashArrowJSONB = describe "Double Arrow (JSONB)" $ do itDb "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) #>. list) "SELECT (? #> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj #>. ["a","1"] #>. ["b"]) "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message") y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14) z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14) liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testHashArrowText :: SpecDb testHashArrowText = describe "Double Arrow (Text)" $ do itDb "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL (jsonbVal (object ["a" .= True]) #>>. list) "SELECT (? #>> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","1"] #>>. ["b"]) "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message") y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14") z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14") liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testFilterOperators :: SpecDb testFilterOperators = describe "Filter Operators" $ do testInclusion testQMark testQMarkAny testQMarkAll testInclusion :: SpecDb testInclusion = do describe "@>" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj @>. jsonbVal (object ["a" .= False])) "SELECT (? @> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistLiteralEscaped "{\"a\":false}" ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True])) "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistText "a" , PersistLiteralEscaped "{\"b\":true}" ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 describe "<@" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal (object ["a" .= False]) <@. jsonbVal obj ) "SELECT (? <@ ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":false}" , PersistLiteralEscaped encoded ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] obj' = object ["b" .= True, "c" .= Null] encoded = BSL.toStrict $ encode obj' createSaneSQL (jsonbVal obj ->. "a" <@. jsonbVal obj') "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , PersistText "a" , PersistLiteralEscaped encoded ] itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testQMark :: SpecDb testQMark = do describe "Question Mark" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj JSON.?. "a") "SELECT (? ?? ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistText "a" ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj #>. ["a","0"] JSON.?. "b") "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","0"] , PersistText "b" ] itDb "works as expected" $ do x <- selectJSONwhere (JSON.?. "a") y <- selectJSONwhere (JSON.?. "test") z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 testQMarkAny :: SpecDb testQMarkAny = do describe "Question Mark (Any)" $ do itDb "creates sane SQL" $ do let obj = (object ["a" .= False, "b" .= True]) encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj ?|. ["a","c"]) "SELECT (? ??| ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","c"] ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj #>. ["a","0"] ?|. ["b","c"]) "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] itDb "works as expected" $ do x <- selectJSONwhere (?|. ["b","test"]) y <- selectJSONwhere (?|. ["a"]) z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] w <- selectJSONwhere (?|. []) liftIO $ length x `shouldBe` 3 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 0 testQMarkAll :: SpecDb testQMarkAll = do describe "Question Mark (All)" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj ?&. ["a","c"]) "SELECT (? ??& ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","c"] ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL (jsonbVal obj #>. ["a","0"] ?&. ["b","c"]) "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] itDb "works as expected" $ do x <- selectJSONwhere (?&. ["test"]) y <- selectJSONwhere (?&. ["a","b"]) z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] w <- selectJSONwhere (?&. []) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 9 testConcatDeleteOperators :: SpecDb testConcatDeleteOperators = do describe "Concatenation Operator" testConcatenationOperator describe "Deletion Operators" $ do testMinusOperator testMinusOperatorV10 testHashMinusOperator testConcatenationOperator :: SpecDb testConcatenationOperator = do describe "Concatenation" $ do itDb "creates sane SQL" $ do let objAB = object ["a" .= False, "b" .= True] objC = object ["c" .= Null] createSaneSQL @JSONValue (jsonbVal objAB JSON.||. jsonbVal objC) "SELECT (? || ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB , PersistLiteralEscaped $ BSL.toStrict $ encode objC ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null])) "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistText "a" , PersistLiteralEscaped "[null]" ] itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ v JSON.||. jsonbVal (object ["x" .= True]) @>. jsonbVal (object ["x" .= True]) y <- selectJSONwhere $ \v -> v JSON.||. jsonbVal (toJSON [String "a", String "b"]) ->>. 4 ==. just (val "b") z <- selectJSONwhere $ \v -> v JSON.||. jsonbVal (toJSON [Bool False]) ->. 0 JSON.@>. jsonbVal (Number 1) w <- selectJSON $ \v -> do where_ . not_ $ v @>. jsonbVal (object []) where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1") liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 2 liftIO $ length w `shouldBe` 7 testMinusOperator :: SpecDb testMinusOperator = describe "Minus Operator" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue (jsonbVal obj JSON.-. "a") "SELECT (? - ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistText "a" ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue (jsonbVal obj ->. "a" JSON.-. 0) "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , PersistText "a" , PersistInt64 0 ] itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null]) z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"] w <- selectJSON_ $ \v -> do v JSON.-. "test" @>. jsonbVal (toJSON [String "test"]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 0 liftIO $ length w `shouldBe` 0 sqlFailWith "22023" $ selectJSONwhere $ \v -> v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v testMinusOperatorV10 :: SpecDb testMinusOperatorV10 = do describe "Minus Operator (PSQL >= v10)" $ do itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue (jsonbVal obj --. ["a","b"]) "SELECT (? - ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","b"] ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue (jsonbVal obj #>. ["a","0"] --. ["b"]) "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped encoded , persistTextArray ["a","0"] , persistTextArray ["b"] ] itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ v --. ["a","b"] <@. jsonbVal (object []) z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)]) w <- selectJSON_ $ \v -> do v --. ["test"] @>. jsonbVal (toJSON [String "test"]) liftIO $ length x `shouldBe` 0 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 0 sqlFailWith "22023" $ selectJSONwhere $ \v -> v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v testHashMinusOperator :: SpecDb testHashMinusOperator = describe "Hash-Minus Operator" $ do itDb "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"]) "SELECT (? #- ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True]) , persistTextArray ["a"] ] itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" #-. ["0","b"]) "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped (BSL.toStrict $ encode obj) , PersistText "a" , persistTextArray ["0","b"] ] itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []]) z <- selectJSON_ $ \v -> v #-. ["a","b","c"] @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]]) w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b" liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 0 liftIO $ length w `shouldBe` 1 sqlFailWith "22023" $ selectJSONwhere $ \v -> v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ f v testInsertUniqueViolation :: SpecDb testInsertUniqueViolation = describe "Unique Violation on Insert" $ itDb "Unique throws exception" $ do eres <- try $ do _ <- insert u1 _ <- insert u2 insert u3 liftIO $ case eres of Left err | err == exception -> pure () _ -> expectationFailure $ "Expected a SQL exception, got: " <> show eres where exception = SqlError { sqlState = "23505", sqlExecStatus = FatalError, sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", sqlErrorDetail = "Key (value)=(0) already exists.", sqlErrorHint = ""} testUpsert :: SpecDb testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ do u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) liftIO $ entityVal u1e `shouldBe` u1 u2e <- EP.upsert u2 (pure (OneUniqueName =. val "fifth")) liftIO $ entityVal u2e `shouldBe` u2 u3e <- EP.upsert u3 (pure (OneUniqueName =. val "fifth")) liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} describe "With no updates" $ do itDb "Works with no updates" $ do _ <- EP.upsertMaybe u1 [] pure () itDb "Works with no updates, twice" $ do mu1 <- EP.upsertMaybe u1 [] Entity u1Key u1' <- liftIO $ assertJust mu1 mu2 <- EP.upsertMaybe u1 { oneUniqueName = "Something Else" } [] asserting $ do mu2 `shouldBe` Nothing -- liftIO $ do -- u1 `shouldBe` u1' testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = describe "insertSelectWithConflict test" $ do itDb "Should do Nothing when no updates set" $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) uniques1 <- select $ from $ \u -> return u n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) uniques2 <- select $ from $ \u -> return u liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 0 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test itDb "Should update a value if given an update on conflict" $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 -- Note, have to sum 4 so that the update does not conflicts again with another row. n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) uniques1 <- select $ from $ \u -> return u n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) uniques2 <- select $ from $ \u -> return u liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 3 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3] liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test2 testFilterWhere :: SpecDb testFilterWhere = describe "filterWhere" $ do itDb "adds a filter clause to count aggregation" $ do -- Person "John" (Just 36) Nothing 1 _ <- insert p1 -- Person "Rachel" Nothing (Just 37) 2 _ <- insert p2 -- Person "Mike" (Just 17) Nothing 3 _ <- insert p3 -- Person "Livia" (Just 17) (Just 18) 4 _ <- insert p4 -- Person "Mitch" Nothing Nothing 5 _ <- insert p5 usersByAge <- fmap coerce <$> do select $ from $ \users -> do groupBy $ users ^. PersonAge return ( users ^. PersonAge :: SqlExpr (Value (Maybe Int)) -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2 -- Just 36: [John { favNum = 1 } (excluded)] = 0 -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2 , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2) :: SqlExpr (Value Int) -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0 -- Just 36: [John { favNum = 1 }] = 1 -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0 , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2) :: SqlExpr (Value Int) ) liftIO $ usersByAge `shouldMatchList` ( [ (Nothing, 2, 0) , (Just 36, 0, 1) , (Just 17, 2, 0) ] :: [(Maybe Int, Int, Int)] ) itDb "adds a filter clause to sum aggregation" $ do -- Person "John" (Just 36) Nothing 1 _ <- insert p1 -- Person "Rachel" Nothing (Just 37) 2 _ <- insert p2 -- Person "Mike" (Just 17) Nothing 3 _ <- insert p3 -- Person "Livia" (Just 17) (Just 18) 4 _ <- insert p4 -- Person "Mitch" Nothing Nothing 5 _ <- insert p5 usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do select $ from $ \users -> do groupBy $ users ^. PersonAge return ( users ^. PersonAge -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7 -- Just 36: [John { favNum = 1 } (excluded)] = Nothing -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7 , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2) -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing -- Just 36: [John { favNum = 1 }] = Just 1 -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2) ) liftIO $ usersByAge `shouldMatchList` ( [ (Nothing, Just 7, Nothing) , (Just 36, Nothing, Just 1) , (Just 17, Just 7, Nothing) ] :: [(Maybe Int, Maybe Rational, Maybe Rational)] ) testCommonTableExpressions :: SpecDb testCommonTableExpressions = do describe "You can run them" $ do itDb "will run" $ do void $ select $ do limitedLordsCte <- Experimental.with $ do lords <- Experimental.from $ Experimental.table @Lord limit 10 pure lords lords <- Experimental.from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords asserting noExceptions itDb "can do multiple recursive queries" $ do let oneToTen = Experimental.withRecursive (pure $ val (1 :: Int)) Experimental.unionAll_ (\self -> do v <- Experimental.from self where_ $ v <. val 10 pure $ v +. val 1 ) vals <- select $ do cte <- oneToTen cte2 <- oneToTen res1 <- Experimental.from cte res2 <- Experimental.from cte2 pure (res1, res2) asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10])) itDb "passing previous query works" $ do let oneToTen = Experimental.withRecursive (pure $ val (1 :: Int)) Experimental.unionAll_ (\self -> do v <- Experimental.from self where_ $ v <. val 10 pure $ v +. val 1 ) oneMore q = Experimental.with $ do v <- Experimental.from q pure $ v +. val 1 vals <- select $ do cte <- oneToTen cte2 <- oneMore cte res <- Experimental.from cte2 pure res asserting $ vals `shouldBe` fmap Value [2..11] describe "MATERIALIZED CTEs" $ do describe "withNotMaterialized" $ do itDb "successfully executes query" $ do void $ select $ do limitedLordsCte <- withNotMaterialized $ do lords <- Experimental.from $ Experimental.table @Lord limit 10 pure lords lords <- Experimental.from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords asserting noExceptions itDb "generates the expected SQL" $ do (sql, _) <- showQuery ES.SELECT $ do limitedLordsCte <- withNotMaterialized $ do lords <- Experimental.from $ Experimental.table @Lord limit 10 pure lords lords <- Experimental.from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords asserting $ sql `shouldBe` T.unlines [ "WITH \"cte\" AS NOT MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\"" , "FROM \"Lord\"" , " LIMIT 10" , ")" , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\"" , "FROM \"cte\"" , "ORDER BY \"cte\".\"v_county\" ASC" ] asserting noExceptions describe "withMaterialized" $ do itDb "generates the expected SQL" $ do (sql, _) <- showQuery ES.SELECT $ do limitedLordsCte <- withMaterialized $ do lords <- Experimental.from $ Experimental.table @Lord limit 10 pure lords lords <- Experimental.from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords asserting $ sql `shouldBe` T.unlines [ "WITH \"cte\" AS MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\"" , "FROM \"Lord\"" , " LIMIT 10" , ")" , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\"" , "FROM \"cte\"" , "ORDER BY \"cte\".\"v_county\" ASC" ] asserting noExceptions itDb "successfully executes query" $ do void $ select $ do limitedLordsCte <- withMaterialized $ do lords <- Experimental.from $ Experimental.table @Lord limit 10 pure lords lords <- Experimental.from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords asserting noExceptions testPostgresqlLocking :: SpecDb testPostgresqlLocking = do describe "Monoid instance" $ do let toText conn q = let (tlb, _) = ES.toRawSql ES.SELECT (conn, ES.initialIdentState) q in TLB.toLazyText tlb itDb "concatenates postgres locking clauses" $ do let multipleLockingQuery = do p <- Experimental.from $ table @Person EP.forUpdateOf p EP.skipLocked EP.forUpdateOf p EP.skipLocked EP.forNoKeyUpdateOf p EP.skipLocked EP.forShareOf p EP.skipLocked EP.forKeyShareOf p EP.skipLocked conn <- ask let res1 = toText conn multipleLockingQuery resExpected = TL.unlines [ "SELECT 1" ,"FROM \"Person\"" ,"FOR UPDATE OF \"Person\" SKIP LOCKED" ,"FOR UPDATE OF \"Person\" SKIP LOCKED" ,"FOR NO KEY UPDATE OF \"Person\" SKIP LOCKED" ,"FOR SHARE OF \"Person\" SKIP LOCKED" ,"FOR KEY SHARE OF \"Person\" SKIP LOCKED" ] asserting $ res1 `shouldBe` resExpected describe "For update skip locked locking" $ sequential $ do let mkInitialStateForLockingTest connection = flip runSqlPool connection $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 blogPosts <- mapM insert' [ BlogPost "A" p1k , BlogPost "B" p2k , BlogPost "C" p3k ] pure ([p1k, p2k, p3k], entityKey <$> blogPosts) cleanupLockingTest connection (personKeys, blogPostKeys) = flip runSqlPool connection $ do forM_ blogPostKeys P.delete forM_ personKeys P.delete aroundWith (\testAction connection -> do bracket (mkInitialStateForLockingTest connection) (cleanupLockingTest connection) $ \(personKeys, blogPostKeys) -> testAction (connection, personKeys, blogPostKeys) ) $ do it "skips locked rows for a locking select" $ \(connection, _, _) -> do waitMainThread <- newEmptyMVar let sideThread :: IO Expectation sideThread = do flip runSqlPool connection $ do _ <- takeMVar waitMainThread nonLockedRowsNonSpecified <- select $ do p <- Experimental.from $ table @Person EP.forUpdateOf p EP.skipLocked return p nonLockedRowsSpecifiedTable <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p nonLockedRowsSpecifyAllTables <- select $ do from $ \(p `InnerJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf (p :& b) EP.skipLocked return p pure $ do nonLockedRowsNonSpecified `shouldBe` [] nonLockedRowsSpecifiedTable `shouldBe` [] nonLockedRowsSpecifyAllTables `shouldBe` [] withAsync sideThread $ \sideThreadAsync -> do void $ flip runSqlPool connection $ do void $ select $ do person <- Experimental.from $ table @Person locking ForUpdate pure $ person ^. PersonId _ <- putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync nonLockedRowsAfterUpdate <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 it "skips locked rows for a subselect update" $ \(connection, _, _)-> do waitMainThread <- newEmptyMVar let sideThread :: IO Expectation sideThread = flip runSqlPool connection $ do _ <- liftIO $ takeMVar waitMainThread nonLockedRowsSpecifiedTable <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2 withAsync sideThread $ \sideThreadAsync -> do void $ flip runSqlPool connection $ do update $ \p -> do set p [ PersonName =. val "ChangedName1" ] where_ $ p ^. PersonId `in_` subList_select (do person <- Experimental.from $ table @Person where_ (person ^. PersonName ==. val "Rachel") limit 1 locking ForUpdate pure $ person ^. PersonId) _ <- putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync nonLockedRowsAfterUpdate <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 it "skips locked rows for a subselect join update" $ \(connection, _, _) -> do waitMainThread <- newEmptyMVar let sideThread :: IO Expectation sideThread = flip runSqlPool connection $ do liftIO $ takeMVar waitMainThread lockedRows <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) where_ (b ^. BlogPostTitle ==. val "A") EP.forUpdateOf p EP.skipLocked return p nonLockedRows <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p pure $ do lockedRows `shouldBe` [] length nonLockedRows `shouldBe` 2 withAsync sideThread $ \sideThreadAsync -> do void $ flip runSqlPool connection $ do update $ \p -> do set p [ PersonName =. val "ChangedName" ] where_ $ p ^. PersonId `in_` subList_select (do (people :& blogPosts) <- Experimental.from $ table @Person `Experimental.leftJoin` table @BlogPost `Experimental.on` (\(people :& blogPosts) -> just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) where_ (blogPosts ?. BlogPostTitle ==. just (val "A")) pure $ people ^. PersonId ) liftIO $ putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync nonLockedRowsAfterUpdate <- select $ do from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) EP.forUpdateOf p EP.skipLocked return p asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 describe "noWait" $ do itDb "doesn't crash" $ do select $ do t <- Experimental.from $ table @Person EP.forUpdateOf t EP.noWait pure t asserting noExceptions -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module testLateralQuery :: SpecDb testLateralQuery = do describe "Lateral queries" $ do itDb "supports CROSS JOIN LATERAL" $ do _ <- do select $ do l :& c <- Experimental.from $ table @Lord `CrossJoin` \lord -> do deed <- Experimental.from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int pure (l, c) liftIO $ True `shouldBe` True itDb "supports INNER JOIN LATERAL" $ do let subquery lord = do deed <- Experimental.from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int res <- select $ do l :& c <- Experimental.from $ table @Lord `InnerJoin` subquery `Experimental.on` (const $ val True) pure (l, c) let _ = res :: [(Entity Lord, Value Int)] asserting noExceptions itDb "supports LEFT JOIN LATERAL" $ do res <- select $ do l :& c <- Experimental.from $ table @Lord `LeftOuterJoin` (\lord -> do deed <- Experimental.from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int) `Experimental.on` (const $ val True) pure (l, c) let _ = res :: [(Entity Lord, Value (Maybe Int))] asserting noExceptions testValuesExpression :: SpecDb testValuesExpression = do describe "(VALUES (..)) query" $ do itDb "works with joins and other sql expressions" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 let exprs :: NE.NonEmpty (SqlExpr (Value Int), SqlExpr (Value Text)) exprs = (val 10, val "ten") NE.:| [ (val 20, val "twenty") , (val 30, val "thirty") ] query = do (bound, boundName) :& person <- Experimental.from $ EP.values exprs `Experimental.InnerJoin` table @Person `Experimental.on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound) groupBy bound orderBy [ asc bound ] pure (bound, count @Int $ person^.PersonName) result <- select query liftIO $ result `shouldBe` [ (Value 10, Value 2) , (Value 20, Value 1) , (Value 30, Value 1) ] itDb "supports single-column query" $ do let query = do vInt <- Experimental.from $ EP.values $ val 1 NE.:| [ val 2, val 3 ] pure (vInt :: SqlExpr (Value Int)) result <- select query asserting noExceptions liftIO $ result `shouldBe` [ Value 1, Value 2, Value 3 ] itDb "supports multi-column query (+ nested simple expression and null)" $ do let query = do (vInt, vStr, vDouble) <- Experimental.from $ EP.values $ (val 1, val "str1", coalesce [just $ val 1.0, nothing]) NE.:| [ (val 2, val "str2", just $ val 2.5) , (val 3, val "str3", nothing) ] pure ( vInt :: SqlExpr (Value Int) , vStr :: SqlExpr (Value Text) , vDouble :: SqlExpr (Value (Maybe Double)) ) result <- select query asserting noExceptions liftIO $ result `shouldBe` [ (Value 1, Value "str1", Value $ Just 1.0) , (Value 2, Value "str2", Value $ Just 2.5) , (Value 3, Value "str3", Value Nothing) ] testSubselectAliasingBehavior :: SpecDb testSubselectAliasingBehavior = do describe "Aliasing behavior" $ do itDb "correctly realiases entities accross multiple subselects" $ do _ <- select $ do Experimental.from $ Experimental.from $ Experimental.from $ table @Lord asserting noExceptions itDb "doesnt erroneously repeat variable names when using subselect + union" $ do let lordQuery = do l <- Experimental.from $ table @Lord pure (l ^. LordCounty, l ^. LordDogs) personQuery = do p <- Experimental.from $ table @Person pure (p ^. PersonName, just $ p ^. PersonFavNum) _ <- select $ Experimental.from $ do (str, _) <- Experimental.from $ lordQuery `union_` personQuery pure (str, val @Int 1) asserting noExceptions testPostgresqlNullsOrdering :: SpecDb testPostgresqlNullsOrdering = do describe "Postgresql NULLS orderings work" $ do itDb "ASC NULLS FIRST works" $ do p1e <- insert' p1 p2e <- insert' p2 -- p2 has a null age p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [EP.ascNullsFirst (p ^. PersonAge), EP.ascNullsFirst (p ^. PersonFavNum)] return p -- nulls come first asserting $ ret `shouldBe` [ p2e, p3e, p4e, p1e ] itDb "ASC NULLS LAST works" $ do p1e <- insert' p1 p2e <- insert' p2 -- p2 has a null age p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [EP.ascNullsLast (p ^. PersonAge), EP.ascNullsLast (p ^. PersonFavNum)] return p -- nulls come last asserting $ ret `shouldBe` [ p3e, p4e, p1e, p2e ] itDb "DESC NULLS FIRST works" $ do p1e <- insert' p1 p2e <- insert' p2 -- p2 has a null age p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [EP.descNullsFirst (p ^. PersonAge), EP.descNullsFirst (p ^. PersonFavNum)] return p -- nulls come first asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] itDb "DESC NULLS LAST works" $ do p1e <- insert' p1 p2e <- insert' p2 -- p2 has a null age p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [EP.descNullsLast (p ^. PersonAge), EP.descNullsLast (p ^. PersonFavNum)] return p -- nulls come last asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m () createSaneSQL act q vals = do (query, args) <- showQuery ES.SELECT $ fromValue act liftIO $ do query `shouldBe` q args `shouldBe` vals fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a)) fromValue act = from $ \x -> do let _ = x :: SqlExpr (Entity Json) return act persistTextArray :: [T.Text] -> PersistValue persistTextArray = PersistArray . fmap PersistText sqlFailWith :: (HasCallStack, MonadUnliftIO m, Show a) => ByteString -> SqlPersistT m a -> SqlPersistT m () sqlFailWith errState f = do eres <- try f case eres of Left err -> success err Right a -> liftIO $ expectationFailure $ mconcat [ "should fail with error code: " , T.unpack errStateT , ", but got: " , show a ] where success SqlError{sqlState} | sqlState == errState = pure () | otherwise = do liftIO $ expectationFailure $ T.unpack $ T.concat [ "should fail with: ", errStateT , ", but received: ", TE.decodeUtf8 sqlState ] errStateT = TE.decodeUtf8 errState selectJSONwhere :: MonadIO m => (JSONBExpr A.Value -> SqlExpr (Value Bool)) -> SqlPersistT m [Entity Json] selectJSONwhere f = selectJSON $ where_ . f selectJSON :: MonadIO m => (JSONBExpr A.Value -> SqlQuery ()) -> SqlPersistT m [Entity Json] selectJSON f = select $ from $ \v -> do f $ just (v ^. JsonValue) return v insertJsonValues :: SqlPersistT IO () insertJsonValues = do insertIt Null insertIt $ Bool True insertIt $ Number 1 insertIt $ String "test" insertIt $ toJSON ([] :: [A.Value]) insertIt $ toJSON [Number 1, Bool True, Null] insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] insertIt $ object ["a" .= (1 :: Int), "b" .= False] insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] where insertIt :: MonadIO m => A.Value -> SqlPersistT m () insertIt = insert_ . Json . JSONB verbose :: Bool verbose = False migrateIt :: _ => SqlPersistT m () migrateIt = mapReaderT runNoLoggingT $ do void $ runMigrationSilent $ do migrateAll migrateUnique migrateJSON cleanDB cleanUniques mkConnectionPool :: IO ConnectionPool mkConnectionPool = do verbose' <- lookupEnv "VERBOSE" >>= \case Nothing -> return verbose Just x | map Char.toLower x == "true" -> return True | null x -> return True | otherwise -> return False pool <- if verbose' then runStderrLoggingT $ createPostgresqlPool "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" 4 else runNoLoggingT $ createPostgresqlPool "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" 4 flip runSqlPool pool $ do migrateIt pure pool -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend) => ES.Mode -> SqlQuery a -> ReaderT backend m (T.Text, [PersistValue]) showQuery mode query = do backend <- ask let (builder, values) = ES.toRawSql mode (backend, ES.initialIdentState) query return (ES.builderToText builder, values)