Skip to content

Commit 80be5ea

Browse files
Martoon-00Martoon-00
committed
Add indices support
This includes: * Manual indices definition; * Automatic detection of indices required for performant JOINs; * Manual and automatic index creation/deletion via `ADD/DROP INDEX` (without SQLite support)
1 parent 9fdfed7 commit 80be5ea

File tree

16 files changed

+809
-92
lines changed

16 files changed

+809
-92
lines changed

‎beam-core/Database/Beam/Schema.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,10 +38,11 @@ module Database.Beam.Schema
3838
-- * Types for lens generation
3939
, Lenses, LensFor(..)
4040

41+
-- TODO: does it worth reexporting index stuff here?
4142
, module Database.Beam.Schema.Lenses ) where
4243

43-
import Database.Beam.Schema.Tables
4444
import Database.Beam.Schema.Lenses
45+
import Database.Beam.Schema.Tables
4546

4647
-- $db-construction
4748
-- Types and functions to express database types and auto-generate name mappings

‎beam-core/Database/Beam/Schema/Indices.hs

Lines changed: 357 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,357 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
-- | This module provides support for table indices definition, both
5+
-- manual and automatic (see 'dbIndices' and 'addDefaultDbIndices' functions).
6+
module Database.Beam.Schema.Indices
7+
( TableIndex (..)
8+
, Index (..)
9+
, IndexOptions (..)
10+
, indexOptions
11+
12+
, FieldIndexBuilder
13+
, IndexBuilder (..)
14+
, EntityIndices (..)
15+
, DatabaseIndices
16+
, (:->)
17+
, IndexFromReference (..)
18+
19+
, indexOptionsEnglishDescription
20+
, mkIndexName
21+
, buildDbIndices
22+
, tableIndex
23+
, dbIndices
24+
, mergeDbIndices
25+
, defaultTableIndices
26+
, defaultDbIndices
27+
, addDefaultDbIndices
28+
) where
29+
30+
import Control.Monad.Writer.Strict (runWriter, tell)
31+
32+
import Data.Aeson
33+
import Data.DList (DList)
34+
import qualified Data.DList as DL
35+
import Data.Functor.Identity
36+
import Data.Hashable (Hashable (..))
37+
import Data.List.NonEmpty (NonEmpty (..))
38+
import Data.Proxy
39+
import Data.Text (Text)
40+
import qualified Data.Text as T
41+
42+
import GHC.Exts (Constraint, fromList)
43+
import GHC.Generics hiding (C, R)
44+
import GHC.TypeLits
45+
46+
import Database.Beam.Schema.Tables
47+
48+
-- Some day it should have more options and allow to modify them depending on the backend.
49+
-- | Index options.
50+
data IndexOptions = IndexOptions
51+
{ indexUnique :: Bool
52+
} deriving (Show, Eq, Ord, Generic)
53+
54+
instance Hashable IndexOptions
55+
56+
instance ToJSON IndexOptions where
57+
toJSON (IndexOptions unique) =
58+
object [ "unique" .= unique ]
59+
instance FromJSON IndexOptions where
60+
parseJSON = withObject "IndexOptions" $ \o ->
61+
IndexOptions <$> o .: "unique"
62+
63+
-- | Default options.
64+
-- For now, they just describe a non-@UNIQUE@ index.
65+
indexOptions :: IndexOptions
66+
indexOptions = IndexOptions
67+
{ indexUnique = False
68+
}
69+
70+
indexOptionsEnglishDescription :: IndexOptions -> String
71+
indexOptionsEnglishDescription (IndexOptions uniq) =
72+
(if uniq then "unique " else " ")
73+
74+
-- | Single index settings for some table.
75+
data TableIndex = TableIndex (NonEmpty Text) IndexOptions
76+
deriving (Show, Eq, Ord)
77+
78+
-- | Single index settings.
79+
data Index = Index !Text !TableIndex
80+
deriving (Show, Eq, Ord)
81+
82+
-- | Make a name for an autogenerated index.
83+
mkIndexName :: Text -> [Text] -> Text
84+
mkIndexName tblNm fields =
85+
"idx_" <> tblNm <> "_" <> T.intercalate "_" fields
86+
87+
-- | Indices for an entity (table).
88+
--
89+
-- Usually, you use the 'dbIndices' function to generate an empty set of indices
90+
-- and modify its fields with 'mconcat' of several 'tableIndex'es, later wrapping
91+
-- it with 'addDefaultDbIndices'.
92+
newtype EntityIndices be db entity = EntityIndices
93+
{ _entityIndices :: DList (DatabaseEntity be db entity -> Index)
94+
-- ^ Multiple indices info assuming the database settings is given.
95+
-- We have to accept database settings here rather than take them at index building
96+
-- stage because migrations require that.
97+
} deriving (Semigroup, Monoid)
98+
99+
-- | When parameterized by this entity tag, a database type will hold
100+
-- a schema of indices, i.e. a way to build material indices when corresponding database
101+
-- settings are provided. Under the hood, each entity type is transformed into its
102+
-- 'EntityIndices' type. For tables, this includes, accordingly, indices for this table; all other types of entities are assumed to be empty.
103+
type DatabaseIndices be db = db (EntityIndices be db)
104+
105+
-- | Construct material indices from the given database schema and indices schema.
106+
buildDbIndices
107+
:: forall be db.
108+
Database be db
109+
=> DatabaseSettings be db -> DatabaseIndices be db -> [Index]
110+
buildDbIndices dbSettings dbIdxs =
111+
let (_ :: DatabaseSettings be db, indices) =
112+
runWriter $ zipTables (Proxy @be)
113+
(\dbEntity (EntityIndices mkIndices) -> do
114+
tell [ mkIndex dbEntity | mkIndex <- DL.toList mkIndices ]
115+
return dbEntity)
116+
dbSettings dbIdxs
117+
in indices
118+
119+
-- | Return empty 'DatabaseIndices'. You can use it like
120+
--
121+
-- > dbIndices{ tbl1 = tableIndex field1 indexOptions{ uniqueIndex = True } <>
122+
-- > tableIndex (field2, field3) indexOptions }
123+
dbIndices :: forall be db. Database be db => DatabaseIndices be db
124+
dbIndices = runIdentity $ zipTables (Proxy @be) (\_ _ -> pure mempty) undefined undefined
125+
126+
-- This function can't be used as 'Semigroup.<>', because 'DatabaseIndices' is not
127+
-- a normal type we can infer an instance for.
128+
-- | Combine two indices settings.
129+
mergeDbIndices
130+
:: forall be db.
131+
Database be db
132+
=> DatabaseIndices be db -> DatabaseIndices be db -> DatabaseIndices be db
133+
mergeDbIndices i1 i2 =
134+
runIdentity $ zipTables (Proxy @be) (\ei1 ei2 -> pure (ei1 <> ei2)) i1 i2
135+
136+
137+
-- * Manual indices definition
138+
139+
-- | Helper for 'IsNotEmptyData'.
140+
type family GIsNotEmptyData (item :: Symbol) (rep :: * -> *) :: Constraint where
141+
GIsNotEmptyData item (D1 _d (C1 _c U1)) =
142+
TypeError ('Text item ':<>: 'Text " without fields is not allowed here")
143+
GIsNotEmptyData _ _ = ()
144+
145+
-- | Ensures a datatype has at least one field.
146+
type IsNotEmptyData item x = (Generic x, GIsNotEmptyData item (Rep x))
147+
148+
-- | Gathers index fields from the given field of a table.
149+
class FieldIndexBuilder field where
150+
buildFieldIndex :: field -> NonEmpty Text
151+
152+
instance FieldIndexBuilder (TableField table a) where
153+
buildFieldIndex field = (:| []) $ _fieldName field
154+
155+
instance (Beamable (PrimaryKey table),
156+
IsNotEmptyData "Primary key" (PrimaryKey table Identity)) =>
157+
FieldIndexBuilder (PrimaryKey table (TableField table')) where
158+
buildFieldIndex =
159+
fromList . allBeamValues (\(Columnar' (TableField fieldNm)) -> fieldNm)
160+
161+
instance (Beamable (PrimaryKey table),
162+
IsNotEmptyData "Primary key" (PrimaryKey table Identity)) =>
163+
FieldIndexBuilder (PrimaryKey table (Nullable (TableField table'))) where
164+
buildFieldIndex =
165+
fromList . allBeamValues (\(Columnar' (TableField fieldNm)) -> fieldNm)
166+
167+
-- | Gathers index fields from a user-supplied pack of table fields.
168+
class IndexBuilder table a where
169+
buildIndex :: TableSettings table -> a -> NonEmpty Text
170+
171+
-- | Field accessors are building blocks for indices.
172+
instance (f ~ TableField table, table ~ table', FieldIndexBuilder field) =>
173+
IndexBuilder table' (table f -> field) where
174+
buildIndex settings getter =
175+
buildFieldIndex $ getter settings
176+
177+
instance (IndexBuilder table a, IndexBuilder table b) =>
178+
IndexBuilder table (a, b) where
179+
buildIndex settings (a, b) = buildIndex settings a <> buildIndex settings b
180+
181+
instance (IndexBuilder table a, IndexBuilder table b, IndexBuilder table c) =>
182+
IndexBuilder table (a, b, c) where
183+
buildIndex settings (a, b, c) =
184+
buildIndex settings a <> buildIndex settings b <> buildIndex settings c
185+
186+
-- | Make a table index builder covering the specified fields.
187+
-- Basic usage is to pass a table field accessor or a tuple of them to this function.
188+
-- Currently, no more than 3 elements in a tuple are supported, but feel free to nest
189+
-- tuples.
190+
-- Order of fields is preserved: tuples expand straightforwardly, while primary keys
191+
-- expand to a list of fields in the same order as they are mentioned in the
192+
-- corresponding constructor.
193+
tableIndex
194+
:: IndexBuilder table a
195+
=> a
196+
-> IndexOptions
197+
-> EntityIndices be db (TableEntity table)
198+
tableIndex builder idxOpts =
199+
EntityIndices . DL.singleton $
200+
\(DatabaseEntity (DatabaseTable tblName tblSettings)) ->
201+
Index tblName $ TableIndex (buildIndex tblSettings builder) idxOpts
202+
203+
-- | For the given part of table @tblp@, indices derived from it.
204+
type TableIndicesBuilder tblp = DList (tblp -> TableIndex)
205+
206+
-- | Helper for GAutoTableIndices
207+
contramapTableIndicesBuilder :: (b -> a) -> TableIndicesBuilder a -> TableIndicesBuilder b
208+
contramapTableIndicesBuilder f = fmap (. f)
209+
210+
-- * Automatic indices definition
211+
212+
-- | Indicates a reference from table @tbl@ to table @tbl'@.
213+
data (tbl :: (* -> *) -> *) :-> (tbl' :: (* -> *) -> *)
214+
215+
-- | Provide options for an automatically created index, which is caused by a primary key
216+
-- of one table being embedded into another.
217+
-- This typeclass is only needed to be defined for inter-table references (see ':->').
218+
class IndexFromReference reference where
219+
referenceIndexOptions :: Proxy reference -> IndexOptions
220+
referenceIndexOptions _ = indexOptions
221+
222+
{- @martoon TODO: I see several minor (or not) problems with making user define instances of
223+
this typeclass:
224+
225+
1. Logic locality - instances can occur to be far away from user's database settings
226+
declaration.
227+
2. Garbade - user have to care itself about removing redundant instances which no more
228+
in use.
229+
3. Extensibility - each time we want to add a type-level restriction on a created index
230+
(e.g. between these two tables only "hash" indices are allowed - nonsence, but we might
231+
want something like this one day), then user's code will break on each such addition.
232+
233+
I'm thinking of an alternative approach when user has to supply some 'HList' stuff,
234+
element in 'HList' would be an 'IndexOption' tagged with @tbl :-> tbl'@.
235+
If the user annotates his 'IndexOption' with the @tbl :-> tbl'@ reference then
236+
he pretty well controlls correspondence between options and indices they relate to.
237+
This would look like the following:
238+
239+
> defaultDbIndices (
240+
> (autoOption @(Table1 :-> Table1) indexOptions) :&
241+
> (autoOption @(Table2 :-> Table1) indexOptions .*.
242+
> autoOption @(Table2 :-> Table2) indexOptions { ... })
243+
> )
244+
245+
Although this all is pretty cumbersome and scaring at a first glance, and dependencies on
246+
'hlist' and 'vinyl' which may be required here are quite heavyweight.
247+
-}
248+
249+
-- | Generic helper for 'AutoTableIndices'.
250+
class GAutoTableIndices (x :: * -> *) where
251+
-- | Returns list of deferred indices.
252+
-- Exactly this type is required, later in migrations knowing that list size does
253+
-- not depend on names (only on structure of the database) is important.
254+
autoTableIndices' :: DList (x p -> TableIndex)
255+
256+
instance GAutoTableIndices x => GAutoTableIndices (M1 i f x) where
257+
autoTableIndices' = contramapTableIndicesBuilder unM1 $ autoTableIndices' @x
258+
259+
instance (GAutoTableIndices x, GAutoTableIndices y) =>
260+
GAutoTableIndices (x :*: y) where
261+
autoTableIndices' =
262+
contramapTableIndicesBuilder (\(x :*: _) -> x) (autoTableIndices' @x) <>
263+
contramapTableIndicesBuilder (\(_ :*: y) -> y) (autoTableIndices' @y)
264+
265+
instance GAutoTableIndices (Rec0 x) where
266+
autoTableIndices' = mempty
267+
268+
instance {-# OVERLAPPING #-}
269+
(Beamable (PrimaryKey tbl'), IndexFromReference (tbl :-> tbl')) =>
270+
GAutoTableIndices (Rec0 (PrimaryKey tbl' (TableField tbl))) where
271+
autoTableIndices' =
272+
if tableValuesNeeded (Proxy @(PrimaryKey tbl')) == 0
273+
then DL.empty
274+
else DL.singleton $ \(K1 referringField) ->
275+
let pkFields = allBeamValues
276+
(\(Columnar' (TableField fieldNm)) -> fieldNm)
277+
referringField
278+
opts = referenceIndexOptions (Proxy @(tbl :-> tbl'))
279+
-- unsafe call, but at this point we know the list is not empty
280+
in TableIndex (fromList pkFields) opts
281+
282+
instance {-# OVERLAPPING #-}
283+
(Beamable (PrimaryKey tbl'), IndexFromReference (tbl :-> tbl')) =>
284+
GAutoTableIndices (Rec0 (PrimaryKey tbl' (Nullable (TableField tbl)))) where
285+
autoTableIndices' =
286+
if tableValuesNeeded (Proxy @(PrimaryKey tbl')) == 0
287+
then DL.empty
288+
else DL.singleton $ \(K1 referringField) ->
289+
let pkFields = allBeamValues
290+
(\(Columnar' (TableField fieldNm)) -> fieldNm)
291+
referringField
292+
opts = referenceIndexOptions (Proxy @(tbl :-> tbl'))
293+
-- unsafe call, but at this point we know the list is not empty
294+
in TableIndex (fromList pkFields) opts
295+
296+
-- | Traverses fields of the given table and builds indices for all encountered 'PrimaryKey's.
297+
class AutoEntityIndex be db tbl where
298+
autoEntityIndices :: EntityIndices be db tbl
299+
300+
-- Other types of entities are approaching, and we probably don't want to define
301+
-- instances for all of them.
302+
-- | Traverses the given table and for every field which is some 'PrimaryKey'
303+
-- makes corresponding SQL index, this allows "JOIN"s on this table perform nicely.
304+
instance {-# OVERLAPPABLE #-}
305+
AutoEntityIndex be db entity where
306+
autoEntityIndices = mempty
307+
308+
instance (Generic (TableSettings tbl),
309+
GAutoTableIndices (Rep (TableSettings tbl))) =>
310+
AutoEntityIndex be db (TableEntity tbl) where
311+
autoEntityIndices =
312+
EntityIndices $ flip fmap autoTableIndices' $
313+
\mkIndex (DatabaseEntity (DatabaseTable tblName tblSettings)) ->
314+
Index tblName (mkIndex (from tblSettings))
315+
316+
-- | Automatically creates indices for every 'PrimaryKey' embedded into the given table.
317+
defaultTableIndices
318+
:: (Generic (TableSettings table),
319+
GAutoTableIndices (Rep (TableSettings table)))
320+
=> EntityIndices be db (TableEntity table)
321+
defaultTableIndices = autoEntityIndices
322+
323+
-- | Traverses all tables in database and builds indices for all encountered 'PrimaryKey's.
324+
class GAutoDbIndices (x :: * -> *) where
325+
autoDbIndices' :: x p
326+
327+
instance GAutoDbIndices x => GAutoDbIndices (M1 i f x) where
328+
autoDbIndices' = M1 autoDbIndices'
329+
330+
instance (GAutoDbIndices x, GAutoDbIndices y) =>
331+
GAutoDbIndices (x :*: y) where
332+
autoDbIndices' = autoDbIndices' :*: autoDbIndices'
333+
334+
instance AutoEntityIndex be db tbl =>
335+
GAutoDbIndices (Rec0 (EntityIndices be db tbl)) where
336+
autoDbIndices' = K1 $ autoEntityIndices @be @db
337+
338+
-- | Automatically creates indices for every 'PrimaryKey' embedded into a table, for
339+
-- @JOIN@s sake.
340+
-- Tables' primary keys themselves are not included as soon as for each primary key
341+
-- a corresponding index is provided by a database engine.
342+
defaultDbIndices
343+
:: forall be db.
344+
(Database be db,
345+
Generic (DatabaseIndices be db), GAutoDbIndices (Rep (DatabaseIndices be db)))
346+
=> DatabaseIndices be db
347+
defaultDbIndices = to autoDbIndices'
348+
349+
-- | Attaches default indices to the given ones. Usually more convenient than plain
350+
-- 'defaultDbIndices':
351+
--
352+
-- > ... `withDbIndices` addDefaultDbIndices dbIndices{ table1 = ..., ... }
353+
addDefaultDbIndices
354+
:: (Database be db,
355+
Generic (DatabaseIndices be db), GAutoDbIndices (Rep (DatabaseIndices be db)))
356+
=> DatabaseIndices be db -> DatabaseIndices be db
357+
addDefaultDbIndices = mergeDbIndices defaultDbIndices

‎beam-core/beam-core.cabal

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ library
3232

3333
Database.Beam.Schema
3434
Database.Beam.Schema.Tables
35+
Database.Beam.Schema.Indices
3536

3637
Database.Beam.Backend.Types
3738
Database.Beam.Backend.URI
@@ -65,7 +66,8 @@ library
6566
network-uri >=2.6 && <2.7,
6667
containers >=0.5 && <0.6,
6768
vector-sized >=0.5 && <1.1,
68-
tagged >=0.8 && <0.9
69+
tagged >=0.8 && <0.9,
70+
vector-sized >=0.5 && <1.2
6971
Default-language: Haskell2010
7072
default-extensions: ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies,
7173
GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators,
@@ -85,7 +87,7 @@ test-suite beam-core-tests
8587
hs-source-dirs: test
8688
main-is: Main.hs
8789
other-modules: Database.Beam.Test.Schema Database.Beam.Test.SQL
88-
build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit
90+
build-depends: base, beam-core, text, bytestring, microlens, time, tasty, tasty-hunit
8991
default-language: Haskell2010
9092
default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, GADTs, TypeFamilies,
9193
DeriveGeneric, DefaultSignatures, RankNTypes, StandaloneDeriving, KindSignatures,

0 commit comments

Comments
 (0)