haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Postgresql Date Truncation (#180)

Browse Source 
* write test case

* weird

* better error message
This commit is contained in:
Matt Parsons 2020-03-30 12:11:27 -06:00 committed by GitHub
parent 0484dfb8d4
commit b6279ca9f2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 97 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
test/Common/Test.hs
View File

@ -55,9 +55,13 @@ module Common.Test
, Numbers (..) , Numbers (..)
, OneUnique(..) , OneUnique(..)
, Unique(..) , Unique(..)
, DateTruncTest(..)
, DateTruncTestId
, Key(..)
) where ) where
import Data.Either import Data.Either
import Data.Time
import Control.Monad (forM_, replicateM, replicateM_, void) import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.Catch (MonadCatch) import Control.Monad.Catch (MonadCatch)
@ -229,6 +233,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
joinOther JoinOtherId joinOther JoinOtherId
joinOne JoinOneId joinOne JoinOneId
deriving Eq Show deriving Eq Show
DateTruncTest
created UTCTime
deriving Eq Show
|] |]
-- Unique Test schema -- Unique Test schema
@ -862,10 +870,10 @@ testSelectSubQuery run = do
it "works" $ do it "works" $ do
run $ do run $ do
_ <- insert' p1 _ <- insert' p1
let q = do let q = do
p <- Experimental.from $ Table @Person p <- Experimental.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge) return ( p ^. PersonName, p ^. PersonAge)
ret <- select $ Experimental.from $ SelectQuery q ret <- select $ Experimental.from $ SelectQuery q
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
it "lets you order by alias" $ do it "lets you order by alias" $ do
@ -873,8 +881,8 @@ testSelectSubQuery run = do
_ <- insert' p1 _ <- insert' p1
_ <- insert' p3 _ <- insert' p3
let q = do let q = do
(name, age) <- (name, age) <-
Experimental.from $ SubQuery $ do Experimental.from $ SubQuery $ do
p <- Experimental.from $ Table @Person p <- Experimental.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge) return ( p ^. PersonName, p ^. PersonAge)
orderBy [ asc age ] orderBy [ asc age ]
@ -889,14 +897,14 @@ testSelectSubQuery run = do
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) -> `Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
return (lord ^. LordId, deed ^. DeedId) return (lord ^. LordId, deed ^. DeedId)
q' = do q' = do
(lordId, deedId) <- Experimental.from $ SubQuery q (lordId, deedId) <- Experimental.from $ SubQuery q
groupBy (lordId) groupBy (lordId)
return (lordId, count deedId) return (lordId, count deedId)
(ret :: [(Value (Key Lord), Value Int)]) <- select q' (ret :: [(Value (Key Lord), Value Int)]) <- select q'
@ -912,16 +920,16 @@ testSelectSubQuery run = do
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) -> `Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId) groupBy (lord ^. LordId)
return (lord ^. LordId, count (deed ^. DeedId)) return (lord ^. LordId, count (deed ^. DeedId))
(ret :: [(Value Int)]) <- select $ do (ret :: [(Value Int)]) <- select $ do
(lordId, deedCount) <- Experimental.from $ SubQuery q (lordId, deedCount) <- Experimental.from $ SubQuery q
where_ $ deedCount >. val (3 :: Int) where_ $ deedCount >. val (3 :: Int)
return (count lordId) return (count lordId)
liftIO $ ret `shouldMatchList` [ (Value 1) ] liftIO $ ret `shouldMatchList` [ (Value 1) ]
@ -933,10 +941,10 @@ testSelectSubQuery run = do
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed) `InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed)
`Experimental.on` (\(lord :& deed) -> `Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId) groupBy (lord ^. LordId)
return (lord ^. LordId, count (deed ^. DeedId)) return (lord ^. LordId, count (deed ^. DeedId))
@ -965,19 +973,19 @@ testSelectSubQuery run = do
run $ do run $ do
_ <- insert p1 _ <- insert p1
_ <- insert p2 _ <- insert p2
let q = Experimental.from $ let q = Experimental.from $
(SelectQuery $ do (SelectQuery $ do
p <- Experimental.from $ Table @Person p <- Experimental.from $ Table @Person
where_ $ not_ $ isNothing $ p ^. PersonAge where_ $ not_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
`Union` `Union`
(SelectQuery $ do (SelectQuery $ do
p <- Experimental.from $ Table @Person p <- Experimental.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
`Union` `Union`
(SelectQuery $ do (SelectQuery $ do
p <- Experimental.from $ Table @Person p <- Experimental.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
names <- select q names <- select q
@ -2409,7 +2417,7 @@ testExperimentalFrom run = do
p1e <- insert' p1 p1e <- insert' p1
_ <- insert' p2 _ <- insert' p2
p3e <- insert' p3 p3e <- insert' p3
peopleWithAges <- select $ do peopleWithAges <- select $ do
people <- Experimental.from $ Table @Person people <- Experimental.from $ Table @Person
where_ $ not_ $ isNothing $ people ^. PersonAge where_ $ not_ $ isNothing $ people ^. PersonAge
return people return people
@ -2422,7 +2430,7 @@ testExperimentalFrom run = do
d1e <- insert' $ Deed "1" (entityKey l1e) d1e <- insert' $ Deed "1" (entityKey l1e)
d2e <- insert' $ Deed "2" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do lordDeeds <- select $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord Experimental.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId) `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
@ -2438,11 +2446,11 @@ testExperimentalFrom run = do
d1e <- insert' $ Deed "1" (entityKey l1e) d1e <- insert' $ Deed "1" (entityKey l1e)
d2e <- insert' $ Deed "2" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do lordDeeds <- select $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord Experimental.from $ Table @Lord
`LeftOuterJoin` Table @Deed `LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds) pure (lords, deeds)
liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)
, (l1e, Just d2e) , (l1e, Just d2e)
@ -2465,7 +2473,7 @@ testExperimentalFrom run = do
lords1 <- Experimental.from $ Table @Lord lords1 <- Experimental.from $ Table @Lord
lords2 <- Experimental.from $ Table @Lord lords2 <- Experimental.from $ Table @Lord
pure (lords1, lords2) pure (lords1, lords2)
ret2 <- select $ do ret2 <- select $ do
(lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord
pure (lords1,lords2) pure (lords1,lords2)
liftIO $ ret `shouldMatchList` ret2 liftIO $ ret `shouldMatchList` ret2
@ -2474,23 +2482,23 @@ testExperimentalFrom run = do
, (l2e, l1e) , (l2e, l1e)
, (l2e, l2e) , (l2e, l2e)
] ]
it "compiles" $ do it "compiles" $ do
run $ void $ do run $ void $ do
let q = do let q = do
(persons :& profiles :& posts) <- (persons :& profiles :& posts) <-
Experimental.from $ Table @Person Experimental.from $ Table @Person
`InnerJoin` Table @Profile `InnerJoin` Table @Profile
`Experimental.on` (\(people :& profiles) -> `Experimental.on` (\(people :& profiles) ->
people ^. PersonId ==. profiles ^. ProfilePerson) people ^. PersonId ==. profiles ^. ProfilePerson)
`LeftOuterJoin` Table @BlogPost `LeftOuterJoin` Table @BlogPost
`Experimental.on` (\(people :& _ :& posts) -> `Experimental.on` (\(people :& _ :& posts) ->
just (people ^. PersonId) ==. posts ?. BlogPostAuthorId) just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)
pure (persons, posts, profiles) pure (persons, posts, profiles)
--error . show =<< renderQuerySelect q --error . show =<< renderQuerySelect q
pure () pure ()
listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation
listsEqualOn a b f = map f a `shouldBe` map f b listsEqualOn a b f = map f a `shouldBe` map f b
@ -2584,6 +2592,8 @@ cleanDB = do
delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()
cleanUniques cleanUniques
:: (forall m. RunDbMonad m :: (forall m. RunDbMonad m

57
test/PostgreSQL/Test.hs
View File

@ -7,9 +7,15 @@
, ScopedTypeVariables , ScopedTypeVariables
, TypeApplications , TypeApplications
, TypeFamilies , TypeFamilies
, PartialTypeSignatures
#-} #-}
module Main (main) where module Main (main) where
import Data.Coerce
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Map (Map)
import Data.Time
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Monad (void, when) import Control.Monad (void, when)
import Control.Monad.Catch (MonadCatch, catch) import Control.Monad.Catch (MonadCatch, catch)
@ -36,6 +42,7 @@ import Database.Persist.Postgresql (withPostgresqlConn)
import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..)) import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..))
import System.Environment import System.Environment
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck
import Common.Test import Common.Test
import PostgreSQL.MigrateJSON import PostgreSQL.MigrateJSON
@ -52,10 +59,6 @@ testPostgresqlCoalesce = do
return (coalesce [p ^. PersonAge]) return (coalesce [p ^. PersonAge])
return () return ()
nameContains :: (BaseBackend backend ~ SqlBackend, nameContains :: (BaseBackend backend ~ SqlBackend,
BackendCompatible SqlBackend backend, BackendCompatible SqlBackend backend,
MonadIO m, SqlString s, MonadIO m, SqlString s,
@ -486,6 +489,52 @@ testAggregateFunctions = do
testPostgresModule :: Spec testPostgresModule :: Spec
testPostgresModule = do testPostgresModule = do
describe "date_trunc" $ do
prop "works" $ \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)
ret <-
fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $
select $
from $ \dt -> do
pure
( dt ^. DateTruncTestId
, ( dt ^. DateTruncTestCreated
, truncateDate (val "day") (dt ^. DateTruncTestCreated)
)
)
liftIO $ for_ vals $ \(idx, utcTime) -> do
case Map.lookup idx ret of
Nothing ->
expectationFailure "index not found"
Just (original, expected) -> do
utcTime `shouldBe` original
if utctDay utcTime == utctDay expected
then
utctDay utcTime `shouldBe` utctDay expected
else
-- use this if/else to get a beter error message
utcTime `shouldBe` expected
describe "PostgreSQL module" $ do describe "PostgreSQL module" $ do
describe "Aggregate functions" testAggregateFunctions describe "Aggregate functions" testAggregateFunctions
it "chr looks sane" $ it "chr looks sane" $