Skip to content

Commit d4facde

Browse files
LaurentRDCLaurentRDC
committed
Fixed an issue where lead1_, lag1_, lead_, and lag_ did not have the appropriate type
1 parent c383724 commit d4facde

File tree

5 files changed

+240
-12
lines changed

5 files changed

+240
-12
lines changed

‎beam-core/ChangeLog.md

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,10 @@
55
* Added a `Generic` instance to `SqlNull`, `SqlBitString`, and `SqlSerial` (#736).
66
* Added a note to `default_` to specify that it has more restrictions than its type may indicate (#744).
77

8+
## Bug fixes
9+
10+
* Fixed an issue where `lead1_`, `lag1_`, `lead_`, and `lag_` did not have the appropriate type, leading to runtime exceptions (#745).
11+
812
## Updated dependencies
913

1014
* Updated the upper bound to include `containers-0.8`.

‎beam-core/Database/Beam/Query/Extensions.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -47,13 +47,13 @@ ntile_ (QExpr a) = QExpr (ntileE <$> a)
4747

4848
lead1_, lag1_
4949
:: (BeamSqlBackend be, BeamSqlT615Backend be)
50-
=> QExpr be s a -> QAgg be s a
50+
=> QExpr be s a -> QAgg be s (Maybe a)
5151
lead1_ (QExpr a) = QExpr (leadE <$> a <*> pure Nothing <*> pure Nothing)
5252
lag1_ (QExpr a) = QExpr (lagE <$> a <*> pure Nothing <*> pure Nothing)
5353

5454
lead_, lag_
5555
:: (BeamSqlBackend be, BeamSqlT615Backend be, Integral n)
56-
=> QExpr be s a -> QExpr be s n -> QAgg be s a
56+
=> QExpr be s a -> QExpr be s n -> QAgg be s (Maybe a)
5757
lead_ (QExpr a) (QExpr n) = QExpr (leadE <$> a <*> (Just <$> n) <*> pure Nothing)
5858
lag_ (QExpr a) (QExpr n) = QExpr (lagE <$> a <*> (Just <$> n) <*> pure Nothing)
5959

‎beam-postgres/beam-postgres.cabal

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -77,11 +77,12 @@ test-suite beam-postgres-tests
7777
type: exitcode-stdio-1.0
7878
hs-source-dirs: test
7979
main-is: Main.hs
80-
other-modules: Database.Beam.Postgres.Test,
81-
Database.Beam.Postgres.Test.Marshal,
82-
Database.Beam.Postgres.Test.Select,
83-
Database.Beam.Postgres.Test.DataTypes,
80+
other-modules: Database.Beam.Postgres.Test
81+
Database.Beam.Postgres.Test.Marshal
82+
Database.Beam.Postgres.Test.Select
83+
Database.Beam.Postgres.Test.DataTypes
8484
Database.Beam.Postgres.Test.Migrate
85+
Database.Beam.Postgres.Test.Windowing
8586
build-depends:
8687
aeson,
8788
base,

‎beam-postgres/test/Database/Beam/Postgres/Test/Windowing.hs

Lines changed: 221 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,221 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
5+
module Database.Beam.Postgres.Test.Windowing (tests) where
6+
7+
import Database.Beam
8+
import Database.Beam.Backend.SQL.BeamExtensions
9+
import Database.Beam.Migrate
10+
import Database.Beam.Migrate.Simple (autoMigrate)
11+
import Database.Beam.Postgres
12+
import Database.Beam.Postgres.Migrate (migrationBackend)
13+
import Database.Beam.Postgres.Test
14+
15+
import Control.Exception (SomeException (..), handle)
16+
17+
import Data.ByteString (ByteString)
18+
import Data.Int
19+
import Data.Text (Text)
20+
21+
import Control.Monad (void)
22+
import Test.Tasty
23+
import Test.Tasty.HUnit
24+
25+
tests :: IO ByteString -> TestTree
26+
tests postgresConn =
27+
testGroup
28+
"Windowing unit tests"
29+
[ testLead1 postgresConn
30+
, testLag1 postgresConn
31+
, testLead postgresConn
32+
, testLag postgresConn
33+
, testLeadWithDefault postgresConn
34+
, testLagWithDefault postgresConn
35+
]
36+
37+
testLead1 :: IO ByteString -> TestTree
38+
testLead1 = testCase "lead1_" . windowingQueryTest query expectation
39+
where
40+
query =
41+
withWindow_
42+
( \Person{name} ->
43+
frame_
44+
noPartition_
45+
(orderPartitionBy_ (asc_ name))
46+
noBounds_
47+
)
48+
( \Person{name} w ->
49+
(name, lead1_ name `over_` w)
50+
)
51+
(all_ $ persons db)
52+
expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)]
53+
54+
testLag1 :: IO ByteString -> TestTree
55+
testLag1 = testCase "lag1_" . windowingQueryTest query expectation
56+
where
57+
query =
58+
withWindow_
59+
( \Person{name} ->
60+
frame_
61+
noPartition_
62+
(orderPartitionBy_ (asc_ name))
63+
noBounds_
64+
)
65+
( \Person{name} w ->
66+
(name, lag1_ name `over_` w)
67+
)
68+
(all_ $ persons db)
69+
expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")]
70+
71+
testLead :: IO ByteString -> TestTree
72+
testLead getConnStr =
73+
testGroup
74+
"lead_"
75+
[ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr
76+
, testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr
77+
]
78+
where
79+
query n =
80+
withWindow_
81+
( \Person{name} ->
82+
frame_
83+
noPartition_
84+
(orderPartitionBy_ (asc_ name))
85+
noBounds_
86+
)
87+
( \Person{name} w ->
88+
(name, lead_ name (val_ (n :: Int32)) `over_` w)
89+
)
90+
(all_ $ persons db)
91+
expectation1 = []
92+
93+
testLag :: IO ByteString -> TestTree
94+
testLag getConnStr =
95+
testGroup
96+
"lag_"
97+
[ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr
98+
, testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr
99+
]
100+
where
101+
query n =
102+
withWindow_
103+
( \Person{name} ->
104+
frame_
105+
noPartition_
106+
(orderPartitionBy_ (asc_ name))
107+
noBounds_
108+
)
109+
( \Person{name} w ->
110+
(name, lag_ name (val_ (n :: Int32)) `over_` w)
111+
)
112+
(all_ $ persons db)
113+
expectation = []
114+
115+
116+
testLeadWithDefault :: IO ByteString -> TestTree
117+
testLeadWithDefault getConnStr =
118+
testGroup
119+
"leadWithDefault_"
120+
[ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr
121+
, testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr
122+
]
123+
where
124+
query n def =
125+
withWindow_
126+
( \Person{name} ->
127+
frame_
128+
noPartition_
129+
(orderPartitionBy_ (asc_ name))
130+
noBounds_
131+
)
132+
( \Person{name} w ->
133+
(name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)
134+
)
135+
(all_ $ persons db)
136+
expectation1 = []
137+
138+
139+
testLagWithDefault :: IO ByteString -> TestTree
140+
testLagWithDefault getConnStr =
141+
testGroup
142+
"lagWithDefault_"
143+
[ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr
144+
, testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr
145+
]
146+
where
147+
query n def =
148+
withWindow_
149+
( \Person{name} ->
150+
frame_
151+
noPartition_
152+
(orderPartitionBy_ (asc_ name))
153+
noBounds_
154+
)
155+
( \Person{name} w ->
156+
(name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)
157+
)
158+
(all_ $ persons db)
159+
expectation = []
160+
161+
162+
163+
data PersonT f = Person
164+
{ name :: C f Text
165+
}
166+
deriving (Generic)
167+
168+
type Person = PersonT Identity
169+
170+
type PersonExpr s = PersonT (QExpr Postgres s)
171+
172+
deriving instance Show Person
173+
deriving instance Eq Person
174+
175+
instance Beamable PersonT
176+
177+
instance Table PersonT where
178+
data PrimaryKey PersonT f = PersonKey (C f Text)
179+
deriving stock (Generic)
180+
deriving anyclass (Beamable)
181+
182+
primaryKey Person{name} = PersonKey name
183+
184+
data Db f = Db
185+
{ persons :: f (TableEntity PersonT)
186+
}
187+
deriving (Generic)
188+
189+
instance Database Postgres Db
190+
191+
db :: DatabaseSettings Postgres Db
192+
db = defaultDbSettings
193+
194+
windowingQueryTest ::
195+
(Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) =>
196+
Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) ->
197+
[(a, b)] ->
198+
IO ByteString ->
199+
Assertion
200+
windowingQueryTest query expectation getConnStr =
201+
withTestPostgres "db_windowing_psql" getConnStr $
202+
\conn -> do
203+
prepareTable conn
204+
results <-
205+
runBeamPostgres conn $
206+
runSelectReturningList $
207+
select query
208+
209+
assertEqual "Unexpected" expectation results
210+
211+
prepareTable :: Connection -> IO ()
212+
prepareTable conn =
213+
runBeamPostgres conn $ do
214+
void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)
215+
runInsert $
216+
insert (persons db) $
217+
insertValues
218+
[ Person "Alice"
219+
, Person "Bob"
220+
, Person "Claire"
221+
]

‎beam-postgres/test/Main.hs

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -11,18 +11,20 @@ import qualified Database.Beam.Postgres.Test.Select as Select
1111
import qualified Database.Beam.Postgres.Test.Marshal as Marshal
1212
import qualified Database.Beam.Postgres.Test.DataTypes as DataType
1313
import qualified Database.Beam.Postgres.Test.Migrate as Migrate
14+
import qualified Database.Beam.Postgres.Test.Windowing as Windowing
1415
import Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo )
1516
import qualified Database.PostgreSQL.Simple as Postgres
1617

1718
main :: IO ()
18-
main = defaultMain
19-
$ TC.withContainers setupTempPostgresDB
20-
$ \getConnStr ->
19+
main = defaultMain
20+
$ TC.withContainers setupTempPostgresDB
21+
$ \getConnStr ->
2122
testGroup "beam-postgres tests"
2223
[ Marshal.tests getConnStr
2324
, Select.tests getConnStr
2425
, DataType.tests getConnStr
2526
, Migrate.tests getConnStr
27+
, Windowing.tests getConnStr
2628
]
2729

2830

@@ -39,10 +41,10 @@ setupTempPostgresDB = do
3941
, ("POSTGRES_DB", db)
4042
]
4143
TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`))
42-
43-
pure $ Postgres.postgreSQLConnectionString
44+
45+
pure $ Postgres.postgreSQLConnectionString
4446
( defaultConnectInfo { connectHost = "localhost"
45-
, connectUser = unpack user
47+
, connectUser = unpack user
4648
, connectPassword = unpack password
4749
, connectDatabase = unpack db
4850
, connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432

0 commit comments

Comments
 (0)