selda 0.3.4.0 → 0.4.0.0
raw patch · 33 files changed
+921/−947 lines, 33 filesdep +containersdep +ghc-primdep +randomdep −hashabledep −psqueuesdep −transformersdep ~base
Dependencies added: containers, ghc-prim, random, uuid-types
Dependencies removed: hashable, psqueues, transformers, unordered-containers
Dependency ranges changed: base
Files
- ChangeLog.md +25/−0
- README.md +11/−10
- selda.cabal +17/−40
- src/Database/Selda.hs +34/−25
- src/Database/Selda/Backend.hs +6/−5
- src/Database/Selda/Backend/Internal.hs +84/−105
- src/Database/Selda/Caching.hs +0/−153
- src/Database/Selda/Compile.hs +9/−19
- src/Database/Selda/Debug.hs +10/−0
- src/Database/Selda/Exp.hs +18/−17
- src/Database/Selda/FieldSelectors.hs +104/−0
- src/Database/Selda/Frontend.hs +63/−104
- src/Database/Selda/Generic.hs +0/−4
- src/Database/Selda/Inner.hs +0/−8
- src/Database/Selda/MakeSelectors.hs +94/−0
- src/Database/Selda/Migrations.hs +19/−15
- src/Database/Selda/Nullable.hs +3/−3
- src/Database/Selda/Prepared.hs +27/−34
- src/Database/Selda/Query.hs +1/−1
- src/Database/Selda/SQL/Print.hs +27/−35
- src/Database/Selda/SQL/Print/Config.hs +10/−6
- src/Database/Selda/Selectors.hs +0/−4
- src/Database/Selda/Selectors/FieldSelectors.hs +0/−104
- src/Database/Selda/Selectors/MakeSelectors.hs +0/−92
- src/Database/Selda/SqlRow.hs +0/−4
- src/Database/Selda/SqlType.hs +84/−45
- src/Database/Selda/Table.hs +96/−28
- src/Database/Selda/Table/Compile.hs +36/−17
- src/Database/Selda/Table/Type.hs +29/−1
- src/Database/Selda/Table/Validation.hs +12/−3
- src/Database/Selda/Types.hs +1/−29
- src/Database/Selda/Unsafe.hs +36/−6
- src/Database/Selda/Validation.hs +65/−30
ChangeLog.md view
@@ -1,6 +1,31 @@ # Revision history for Selda +## 0.4.0.0 -- 2019-06-02++* Type-safe support for backend-specific functionality. Top level query definitions now require explicit type signature. (#80)+* Native UUID support. (#47)+* Support JSON columns on all backends through aeson.+* Support JSON lookups (i.e. SELECT json_column.some_property FROM ...) on PostgreSQL.+* Multi-column primary key and uniqueness constraint support. (#25, #99)+* Switch to PostgreSQL binary protocol. (#18)+* Prevent dangerous user-defined SQL result instances.+* Expose backend internals through Database.Selda.Backend.Internal. (#109)+* Expose SQLite connection handle. (#101)+* Make MonadSelda more amenable to connection pooling. (#108)+* Add weakly auto-incrementing primary keys. (#94)+* Move compile* functions to Database.Selda.Debug.+* Remove half the tuple convenience functions.+* Remove in-process cache. (#117)+* Officially support GHC 8.6, 8.8 (SQLite only until postgres dependencies catch up with 8.8).+* Drop support for GHC 7.10. (#118)+* Manual (i.e. non record label) selectors are no longer exported by default; import Database.Selda.MakeSelectors is you need them. (#118)+* Update toolchain to use v2-style cabal commands.+* Fix date/time types for PostgreSQL. (#104)+* Fix bug when migrating tables with indexes. (#107)+* Misc. smaller bug fixes.++ ## 0.3.4.0 -- 2018-09-29 * Added convenience functions for working with nullable columns.
README.md view
@@ -6,7 +6,7 @@ [](https://www.irccloud.com/invite?channel=%23selda&hostname=irc.freenode.net&port=6697&ssl=1)  [](https://travis-ci.org/valderman/selda)-+[](https://packdeps.haskellers.com/feed?needle=selda) What is Selda?@@ -27,8 +27,8 @@ * Inserting, updating and deleting rows from tables. * Conditional insert/update. * Transactions, uniqueness constraints and foreign keys.+* Type-safe, backend-specific functionality, such as JSON lookups. * Seamless prepared statements.-* Configurable, automatic, consistent in-process caching of query results. * Lightweight and modular: few dependencies, and non-essential features are optional or split into add-on packages. @@ -50,7 +50,7 @@ Requirements ============ -Selda requires GHC 7.10+, as well as SQLite 3.7.11+ or PostgreSQL 9.6+.+Selda requires GHC 8.0+, as well as SQLite 3.7.11+ or PostgreSQL 9.4+. To build the SQLite backend, you need a C compiler installed. To build the PostgreSQL backend, you need the `libpq` development libraries installed (`libpq-dev` on Debian-based Linux distributions).@@ -83,7 +83,10 @@ * Do all the tests pass? * Have you added any tests covering your code? +If you want to contribute code but don't really know where to begin,+issues tagged [good first issue](https://github.com/valderman/selda/issues?q=is%3Aissue+is%3Aopen+label%3A%22good+first+issue%22) are a good start. + Setting up the build environment -------------------------------- @@ -91,9 +94,7 @@ * Install `libpq-dev` from your package manager. This is required to build the PostgreSQL backend.-* Run `make sandbox` followed by `make deps`.- This will set up a local sandbox for your Selda hacking, and install all- Haskell necessary dependencies.+* Make sure you're running a cabal version that supports v2-style commands. * Familiarise yourself with the various targets in the makefile. The dependencies between Selda, the backends and the tests are slightly complex, so straight-up cabal is too quirky for day to day hacking.@@ -130,7 +131,7 @@ ``` $ psql -h 127.0.0.1 -U postgres -W [password from login screen]- # CREATE TABLE test;+ # CREATE DATABASE test; # \q ``` * Run `make pgtest` to check that everything works.@@ -141,7 +142,7 @@ Features that would be nice to have but are not yet implemented. -* Monadic if/else.+* Monadic if/else * Streaming-* MySQL/MariaDB backend.-* MSSQL backend.+* MySQL/MariaDB backend+* MSSQL backend
selda.cabal view
@@ -1,5 +1,5 @@ name: selda-version: 0.3.4.0+version: 0.4.0.0 synopsis: Multi-backend, high-level EDSL for interacting with SQL databases. description: This package provides an EDSL for writing portable, type-safe, high-level database code. Its feature set includes querying and modifying databases,@@ -20,24 +20,11 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10-tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1+tested-with: GHC == 8.0.2, GHC == 8.4.1, GHC == 8.6.3, GHC == 8.8.1 extra-source-files: README.md -flag localcache- default: True- description:- Enable process-local cache support. Even when supported, caching is turned- off by default until enabled by the application.- When unsupported, the relevant APIs are still available, but the cache will- act as if every update is a no-op and every lookup a cache miss.--flag haste- default: False- description:- Automatically set when installing for the Haste compiler.- source-repository head type: git location: https://github.com/valderman/selda.git@@ -46,25 +33,26 @@ exposed-modules: Database.Selda Database.Selda.Backend+ Database.Selda.Backend.Internal+ Database.Selda.Debug+ Database.Selda.MakeSelectors Database.Selda.Migrations Database.Selda.Nullable Database.Selda.SqlType Database.Selda.Unsafe Database.Selda.Validation other-modules:- Database.Selda.Backend.Internal- Database.Selda.Caching Database.Selda.Column Database.Selda.Compile Database.Selda.Exp Database.Selda.Frontend+ Database.Selda.FieldSelectors Database.Selda.Generic Database.Selda.Inner Database.Selda.Prepared Database.Selda.Query Database.Selda.Query.Type Database.Selda.Selectors- Database.Selda.Selectors.MakeSelectors Database.Selda.SQL Database.Selda.SQL.Print Database.Selda.SQL.Print.Config@@ -75,9 +63,6 @@ Database.Selda.Table.Validation Database.Selda.Transform Database.Selda.Types- if impl(ghc >= 7.11)- other-modules:- Database.Selda.Selectors.FieldSelectors other-extensions: OverloadedStrings GADTs@@ -91,26 +76,18 @@ GeneralizedNewtypeDeriving FlexibleContexts build-depends:- base >=4.8 && <5- , bytestring >=0.10 && <0.11- , exceptions >=0.8 && <0.11- , hashable >=1.1 && <1.3- , mtl >=2.0 && <2.3- , text >=1.0 && <1.3- , time >=1.5 && <1.10- , unordered-containers >=0.2.6 && <0.3- if impl(ghc < 7.11)- build-depends:- transformers >=0.4 && <0.6- if impl(ghc >= 8.2)- build-depends:- hashable >= 1.2.6.1- if !flag(haste) && flag(localcache)+ base >=4.9 && <5+ , bytestring >=0.10 && <0.11+ , exceptions >=0.8 && <0.11+ , mtl >=2.0 && <2.3+ , text >=1.0 && <1.3+ , time >=1.5 && <1.10+ , containers >=0.4 && <0.7+ , random >=1.1 && <1.2+ , uuid-types >=1.0 && <1.1+ if impl(ghc < 8.1) && impl(ghc >= 8.0) build-depends:- psqueues >=0.2 && <0.3- else- cpp-options:- -DNO_LOCALCACHE+ ghc-prim >= 0.5.0.0 hs-source-dirs: src default-language:
src/Database/Selda.hs view
@@ -27,7 +27,8 @@ , Relational, Only (..), The (..) , Table, Query, Row, Col, Res, Result , query, queryInto- , transaction, setLocalCache, withoutForeignKeyEnforcement+ , transaction, withoutForeignKeyEnforcement+ , newUuid -- * Constructing queries , SqlType (..), SqlRow (..), SqlEnum (..)@@ -42,9 +43,7 @@ -- * Working with selectors , Selector, Coalesce-#if MIN_VERSION_base(4, 9, 0) , HasField, FieldType, IsLabel-#endif , (!), (?), Assignment ((:=)), with , (+=), (-=), (*=), (||=), (&&=), ($=) @@ -80,34 +79,32 @@ -- * Defining schemas , Generic , TableName, ColName, Attr (..), Attribute- , Selectors, GSelectors, ForeignKey (..)- , table, tableFieldMod, tableWithSelectors, selectors- , primary, autoPrimary, untypedAutoPrimary, unique+ , ForeignKey (..)+ , SelectorLike, Group (..), sel+ , table, tableFieldMod+ , primary, autoPrimary, weakAutoPrimary+ , untypedAutoPrimary, weakUntypedAutoPrimary+ , unique , IndexMethod (..), index, indexUsing -- * Creating and dropping tables , createTable, tryCreateTable , dropTable, tryDropTable - -- * Compiling and inspecting queries- , OnError (..)- , compile- , compileCreateTable, compileDropTable- , compileInsert, compileUpdate- -- * Tuple convenience functions , Tup, Head- , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth+ , first, second, third, fourth, fifth -- * Useful re-exports , MonadIO, MonadMask, liftIO- , Text, Day, TimeOfDay, UTCTime+ , Text, Day, TimeOfDay, UTCTime, UUID ) where import Control.Monad.Catch (MonadMask) import Data.Typeable (Typeable) import Database.Selda.Backend import Database.Selda.Column import Database.Selda.Compile+import Database.Selda.FieldSelectors import Database.Selda.Frontend import Database.Selda.Generic import Database.Selda.Inner@@ -115,11 +112,9 @@ import Database.Selda.Query import Database.Selda.Query.Type import Database.Selda.Selectors-import Database.Selda.Selectors.MakeSelectors import Database.Selda.SQL hiding (distinct) import Database.Selda.SqlRow import Database.Selda.Table-import Database.Selda.Table.Compile import Database.Selda.Table.Validation import Database.Selda.Types import Database.Selda.Unsafe@@ -130,11 +125,8 @@ import Data.Typeable (eqT, (:~:)(..)) import GHC.Generics (Rep) import Unsafe.Coerce--#if MIN_VERSION_base(4, 9, 0)-import Database.Selda.Selectors.FieldSelectors+import System.Random (randomIO) import GHC.TypeLits as TL-#endif -- | Any column type that can be used with the 'min_' and 'max_' functions. class SqlType a => SqlOrd a@@ -166,7 +158,6 @@ ) instance SqlType a => SqlRow (Only a) -#if MIN_VERSION_base(4, 9, 0) instance (TypeError ( 'TL.Text "'Only " ':<>: 'ShowType a ':<>: 'TL.Text "' is not a proper SQL type." ':$$: 'TL.Text "Use 'the' to access the value of the column."@@ -175,8 +166,22 @@ sqlType = error "unreachable" fromSql = error "unreachable" defaultValue = error "unreachable"-#endif +-- | Generate a new random UUID using the system's random number generator.+-- UUIDs generated this way are (astronomically likely to be) unique,+-- but not necessarily unpredictable.+--+-- For applications where unpredictability is crucial, take care to use a+-- proper cryptographic PRNG to generate your UUIDs.+newUuid :: MonadIO m => m UUID+newUuid = liftIO randomIO++-- | Annotation to force the type of a polymorphic label (i.e. @#foo@) to+-- be a selector. This is useful, for instance, when defining unique+-- constraints: @sel #foo :- unique@.+sel :: Selector t a -> Selector t a+sel = id+ -- | Add the given column to the column pointed to by the given selector. (+=) :: (SqlType a, Num (Col s a)) => Selector t a -> Col s a -> Assignment s t s += c = s $= (+ c)@@ -268,6 +273,11 @@ return x infixr 7 `suchThat` +-- | Comparisons over columns.+-- Note that when comparing nullable (i.e. @Maybe@) columns, SQL @NULL@+-- semantics are used. This means that comparing to a @NULL@ field will remove+-- the row in question from the current set.+-- To test for @NULL@, use 'isNull' instead of @.== literal Nothing@. (.==), (./=) :: SqlType a => Col s a -> Col s a -> Col s Bool (.>), (.<), (.>=), (.<=) :: SqlOrd a => Col s a -> Col s a -> Col s Bool (.==) = liftC2 $ BinOp Eq@@ -354,12 +364,11 @@ -- > -- > people :: Table Person -- > people = table "people" []--- > sName :*: sAge :*: sPet = selectors people -- > -- > peopleWithCats = do -- > person <- select people--- > restrict (person ! sPet .== just "cat")--- > return (name ! sName)+-- > restrict (person ! #pet .== just "cat")+-- > return (person ! #name) just :: SqlType a => Col s a -> Col s (Maybe a) just = cast
src/Database/Selda/Backend.hs view
@@ -5,12 +5,13 @@ , StmtID, BackendID (..), QueryRunner, SeldaBackend (..), SeldaConnection , SqlValue (..) , IndexMethod (..)- , Param (..), ColAttr (..)+ , Param (..), ColAttr (..), AutoIncType (..) , PPConfig (..), defPPConfig- , TableName, ColName, ColumnInfo (..)- , columnInfo, fromColInfo+ , TableName, ColName, TableInfo (..), ColumnInfo (..)+ , isAutoPrimary, isPrimary, isUnique+ , tableInfo, fromColInfo , mkTableName, mkColName, fromTableName, fromColName, rawTableName- , newConnection, allStmts, seldaBackend+ , newConnection, allStmts, withBackend , runSeldaT, seldaClose , module SqlType ) where@@ -27,7 +28,7 @@ -- Closing a connection while in use is undefined. -- Passing a closed connection to 'runSeldaT' results in a 'SeldaError' -- being thrown. Closing a connection more than once is a no-op.-seldaClose :: MonadIO m => SeldaConnection -> m ()+seldaClose :: MonadIO m => SeldaConnection b -> m () seldaClose c = liftIO $ mask_ $ do closed <- atomicModifyIORef' (connClosed c) $ \closed -> (True, closed) unless closed $ closeConnection (connBackend c) c
src/Database/Selda/Backend/Internal.hs view
@@ -1,38 +1,40 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures, CPP, TypeFamilies #-} -- | Internal backend API.+-- Using anything exported from this module may or may not invalidate any+-- safety guarantees made by Selda; use at your own peril. module Database.Selda.Backend.Internal- ( StmtID, BackendID (..)+ ( StmtID (..), BackendID (..) , QueryRunner, SeldaBackend (..), SeldaConnection (..), SeldaStmt (..) , MonadSelda (..), SeldaT (..), SeldaM , SeldaError (..)- , Param (..), Lit (..), ColAttr (..)+ , Param (..), Lit (..), ColAttr (..), AutoIncType (..) , SqlType (..), SqlValue (..), SqlTypeRep (..) , PPConfig (..), defPPConfig- , ColumnInfo (..), columnInfo, fromColInfo+ , TableInfo (..), ColumnInfo (..), tableInfo, fromColInfo+ , isAutoPrimary, isPrimary, isUnique , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat , freshStmtId- , invalidate , newConnection, allStmts- , runSeldaT, seldaBackend+ , runSeldaT, withBackend ) where-import Database.Selda.Caching (invalidate, setMaxItems) import Database.Selda.SQL (Param (..)) import Database.Selda.SqlType-import Database.Selda.Table (Table (..), ColAttr (..), tableName)+import Database.Selda.Table hiding (colName, colType, colFKs) import qualified Database.Selda.Table as Table (ColInfo (..)) import Database.Selda.SQL.Print.Config import Database.Selda.Types (TableName, ColName) import Control.Concurrent-import Control.Exception (throw) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.State import Data.Dynamic-import Data.Hashable-import qualified Data.HashMap.Strict as M+import qualified Data.IntMap as M import Data.IORef import Data.Text (Text) import System.IO.Unsafe (unsafePerformIO)+#if !MIN_VERSION_base(4, 13, 0)+import Control.Monad.Fail (MonadFail)+#endif -- | Uniquely identifies some particular backend. --@@ -51,7 +53,7 @@ -- | A prepared statement identifier. Guaranteed to be unique per application. newtype StmtID = StmtID Int- deriving (Show, Eq, Ord, Hashable)+ deriving (Show, Eq, Ord) -- | A connection identifier. Guaranteed to be unique per application. newtype ConnID = ConnID Int@@ -82,14 +84,11 @@ -- starting at 0. -- Backends implementing @runPrepared@ should probably ignore this field. , stmtParams :: ![Either Int Param]-- -- | All tables touched by the statement.- , stmtTables :: ![TableName] } -data SeldaConnection = SeldaConnection+data SeldaConnection b = SeldaConnection { -- | The backend used by the current connection.- connBackend :: !SeldaBackend+ connBackend :: !(SeldaBackend b) -- | A string uniquely identifying the database used by this connection. -- This could be, for instance, a PostgreSQL connection@@ -97,7 +96,7 @@ , connDbId :: Text -- | All statements prepared for this connection.- , connStmts :: !(IORef (M.HashMap StmtID SeldaStmt))+ , connStmts :: !(IORef (M.IntMap SeldaStmt)) -- | Is the connection closed? , connClosed :: !(IORef Bool)@@ -109,7 +108,7 @@ -- | Create a new Selda connection for the given backend and database -- identifier string.-newConnection :: MonadIO m => SeldaBackend -> Text -> m SeldaConnection+newConnection :: MonadIO m => SeldaBackend b -> Text -> m (SeldaConnection b) newConnection back dbid = liftIO $ SeldaConnection back dbid <$> newIORef M.empty <*> newIORef False@@ -117,10 +116,21 @@ -- | Get all statements and their corresponding identifiers for the current -- connection.-allStmts :: SeldaConnection -> IO [(StmtID, Dynamic)]-allStmts =- fmap (map (\(k, v) -> (k, stmtHandle v)) . M.toList) . readIORef . connStmts+allStmts :: SeldaConnection b -> IO [(StmtID, Dynamic)]+allStmts = fmap (map (\(k, v) -> (StmtID k, stmtHandle v)) . M.toList)+ . readIORef+ . connStmts +-- | Comprehensive information about a table.+data TableInfo = TableInfo+ { -- | Ordered information about each table column.+ tableColumnInfos :: [ColumnInfo]+ -- | Unordered list of all (non-PK) uniqueness constraints on this table.+ , tableUniqueGroups :: [[ColName]]+ -- | Unordered list of all primary key constraints on this table.+ , tablePrimaryKey :: [ColName]+ } deriving (Show, Eq)+ -- | Comprehensive information about a column. data ColumnInfo = ColumnInfo { -- | Name of the column.@@ -128,16 +138,11 @@ -- | Selda type of the column, or the type name given by the database -- if Selda couldn't make sense of the type. , colType :: Either Text SqlTypeRep- -- | Is the given column the primary key of its table?- , colIsPK :: Bool -- | Is the given column auto-incrementing?- , colIsAutoIncrement :: Bool- -- | Is the column unique, either through a UNIQUE constraint or by virtue- -- of being a primary key?- , colIsUnique :: Bool+ , colIsAutoPrimary :: Bool -- | Can the column be NULL? , colIsNullable :: Bool- -- | Does the column have an index?+ -- | Is the column explicitly indexed (i.e. using 'indexed')? , colHasIndex :: Bool -- | Any foreign key (table, column) pairs referenced by this column. , colFKs :: [(TableName, ColName)]@@ -148,22 +153,33 @@ fromColInfo ci = ColumnInfo { colName = Table.colName ci , colType = Right $ Table.colType ci- , colIsPK = Primary `elem` Table.colAttrs ci- , colIsAutoIncrement = AutoIncrement `elem` Table.colAttrs ci- , colIsUnique = Unique `elem` Table.colAttrs ci+ , colIsAutoPrimary = any isAutoPrimary (Table.colAttrs ci) , colIsNullable = Optional `elem` Table.colAttrs ci , colHasIndex = not $ null [() | Indexed _ <- Table.colAttrs ci] , colFKs = map fk (Table.colFKs ci) } where- fk (Table tbl _ _, col) = (tbl, col)+ fk (Table tbl _ _ _, col) = (tbl, col) -- | Get the column information for each column in the given table.-columnInfo :: Table a -> [ColumnInfo]-columnInfo = map fromColInfo . tableCols+tableInfo :: Table a -> TableInfo+tableInfo t = TableInfo+ { tableColumnInfos = map fromColInfo (tableCols t)+ , tableUniqueGroups = uniqueGroups+ , tablePrimaryKey = pkGroups+ }+ where+ uniqueGroups =+ [ map (Table.colName . ((tableCols t) !!)) ixs+ | (ixs, Unique) <- tableAttrs t+ ]+ pkGroups = concat+ [ map (Table.colName . ((tableCols t) !!)) ixs+ | (ixs, Primary) <- tableAttrs t+ ] -- | A collection of functions making up a Selda backend.-data SeldaBackend = SeldaBackend+data SeldaBackend b = SeldaBackend { -- | Execute an SQL statement. runStmt :: Text -> [Param] -> IO (Int, [[SqlValue]]) @@ -181,13 +197,13 @@ -- | Get a list of all columns in the given table, with the type and any -- modifiers for each column. -- Return an empty list if the given table does not exist.- , getTableInfo :: TableName -> IO [ColumnInfo]+ , getTableInfo :: TableName -> IO TableInfo -- | SQL pretty-printer configuration. , ppConfig :: PPConfig -- | Close the currently open connection.- , closeConnection :: SeldaConnection -> IO ()+ , closeConnection :: SeldaConnection b -> IO () -- | Unique identifier for this backend. , backendId :: BackendID@@ -202,16 +218,6 @@ , disableForeignKeys :: Bool -> IO () } -data SeldaState = SeldaState- { -- | Connection in use by the current computation.- stConnection :: !SeldaConnection-- -- | Tables modified by the current transaction.- -- Invariant: always @Just xs@ during a transaction, and always- -- @Nothing@ when not in a transaction.- , stTouchedTables :: !(Maybe [TableName])- }- -- | Some monad with Selda SQL capabilitites. -- -- Note that the default implementations of 'invalidateTable' and@@ -219,76 +225,49 @@ -- invoked. If you want to use Selda's built-in caching mechanism, you will -- need to implement these operations yourself. class MonadIO m => MonadSelda m where- -- | Get the connection in use by the computation.- seldaConnection :: m SeldaConnection+ {-# MINIMAL withConnection #-} - -- | Invalidate the given table as soon as the current transaction finishes.- -- Invalidate the table immediately if no transaction is ongoing.- invalidateTable :: Table a -> m ()- invalidateTable _ = liftIO $ setMaxItems 0+ -- | Type of database backend used by @m@.+ type Backend m - -- | Safely wrap a transaction. To ensure consistency of the in-process cache,- -- it is important that any cached tables modified during a transaction are- -- invalidated ONLY if that transaction succeeds, AFTER the changes become- -- visible in the database.- --- -- In order to be thread-safe in the presence of asynchronous exceptions,- -- instances should:- --- -- 1. Mask async exceptions.- -- 2. Start bookkeeping of tables invalidated during the transaction.- -- 3. Perform the transaction, with async exceptions restored.- -- 4. Commit transaction, invalidate tables, and disable bookkeeping; OR- -- 5. If an exception was raised, rollback transaction,- -- disable bookkeeping, and re-throw the exception.- wrapTransaction :: m () -- ^ Signal transaction commit to SQL backend.- -> m () -- ^ Signal transaction rollback to SQL backend.- -> m a -- ^ Transaction to perform.- -> m a- default wrapTransaction :: MonadMask m => m () -> m () -> m a -> m a- wrapTransaction commit rollback act = do- bracketOnError (pure ())- (const rollback)- (const (act <* commit <* liftIO (setMaxItems 0)))- {-# MINIMAL seldaConnection #-}+ -- | Pass a Selda connection to the given computation and execute it.+ -- After the computation finishes, @withConnection@ is free to do anything+ -- it likes to the connection, including closing it or giving it to another+ -- Selda computation.+ -- Thus, the computation must take care never to return or otherwise+ -- access the connection after returning.+ withConnection :: (SeldaConnection (Backend m) -> m a) -> m a + -- | Perform the given computation as a transaction.+ -- Implementations must ensure that subsequent calls to 'withConnection'+ -- within the same transaction always passes the same connection+ -- to its argument.+ transact :: m a -> m a+ transact = id+ -- | Get the backend in use by the computation.-seldaBackend :: MonadSelda m => m SeldaBackend-seldaBackend = connBackend <$> seldaConnection+withBackend :: MonadSelda m => (SeldaBackend (Backend m) -> m a) -> m a+withBackend m = withConnection (m . connBackend) -- | Monad transformer adding Selda SQL capabilities.-newtype SeldaT m a = S {unS :: StateT SeldaState m a}+newtype SeldaT b m a = S {unS :: StateT (SeldaConnection b) m a} deriving ( Functor, Applicative, Monad, MonadIO- , MonadThrow, MonadCatch, MonadMask, MonadTrans+ , MonadThrow, MonadCatch, MonadMask , MonadFail ) -instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT m) where- seldaConnection = S $ fmap stConnection get-- invalidateTable tbl = S $ do- st <- get- case stTouchedTables st of- Nothing -> liftIO $ invalidate [tableName tbl]- Just ts -> put $ st {stTouchedTables = Just (tableName tbl : ts)}-- wrapTransaction commit rollback m = mask $ \restore -> do- S $ modify' $ \st ->- case stTouchedTables st of- Nothing -> st {stTouchedTables = Just []}- Just _ -> throw $ SqlError "attempted to nest transactions"- x <- restore m `onException` rollback- commit- st <- S get- maybe (return ()) (liftIO . invalidate) (stTouchedTables st)- S $ put $ st {stTouchedTables = Nothing}- return x+instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT b m) where+ type Backend (SeldaT b m) = b+ withConnection m = S get >>= m -- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'.-type SeldaM = SeldaT IO+type SeldaM b = SeldaT b IO -- | Run a Selda transformer. Backends should use this to implement their -- @withX@ functions.-runSeldaT :: (MonadIO m, MonadMask m) => SeldaT m a -> SeldaConnection -> m a+runSeldaT :: (MonadIO m, MonadMask m)+ => SeldaT b m a+ -> SeldaConnection b+ -> m a runSeldaT m c = bracket (liftIO $ takeMVar (connLock c)) (const $ liftIO $ putMVar (connLock c) ())@@ -298,4 +277,4 @@ closed <- liftIO $ readIORef (connClosed c) when closed $ do liftIO $ throwM $ DbError "runSeldaT called with a closed connection"- fst <$> runStateT (unS m) (SeldaState c Nothing)+ fst <$> runStateT (unS m) c
− src/Database/Selda/Caching.hs
@@ -1,153 +0,0 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Selda.Caching- ( CacheKey- , cache, cached, invalidate, setMaxItems- ) where-import Prelude hiding (lookup)-import Data.Dynamic-#ifndef NO_LOCALCACHE-import Data.Hashable-import Data.HashPSQ-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Data.List (foldl')-import Database.Selda.SqlType-import Data.IORef-import System.IO.Unsafe-#endif-import Data.Text (Text)-import Database.Selda.SQL (Param (..))-import Database.Selda.Types (TableName)--type CacheKey = (Text, Text, [Param])--#ifdef NO_LOCALCACHE--cache :: Typeable a => [TableName] -> CacheKey -> a -> IO ()-cache _ _ _ = return ()--cached :: Typeable a => CacheKey -> IO (Maybe a)-cached _ = return Nothing--invalidate :: [TableName] -> IO ()-invalidate _ = return ()--setMaxItems :: Int -> IO ()-setMaxItems _ = return ()--#else--- | Reduce all parts of a cache key to HNF.-seqCK :: CacheKey -> a -> a-seqCK (db, q, ps) x = db `seq` q `seq` ps `seq` x--instance Hashable Param where- hashWithSalt s (Param x) = hashWithSalt s x-instance Hashable (Lit a) where- hashWithSalt s (LText x) = hashWithSalt s x- hashWithSalt s (LInt x) = hashWithSalt s x- hashWithSalt s (LDouble x) = hashWithSalt s x- hashWithSalt s (LBool x) = hashWithSalt s x- hashWithSalt s (LDateTime x) = hashWithSalt s x- hashWithSalt s (LDate x) = hashWithSalt s x- hashWithSalt s (LTime x) = hashWithSalt s x- hashWithSalt s (LBlob x) = hashWithSalt s x- hashWithSalt s (LJust x) = hashWithSalt s x- hashWithSalt _ (LNull) = 0- hashWithSalt s (LCustom l) = hashWithSalt s l--data ResultCache = ResultCache- { -- | Query to result mapping.- results :: !(HashPSQ CacheKey Int Dynamic)- -- | Table to query mapping, for keeping track of which queries depend on- -- which tables.- , deps :: !(M.HashMap TableName (S.HashSet CacheKey))- -- | Items currently in cache.- , items :: !Int- -- | Max number of items in cache.- , maxItems :: !Int- -- | Next cache prio to use.- , nextPrio :: !Int- } deriving Show--emptyCache :: ResultCache-emptyCache = ResultCache- { results = empty- , deps = M.empty- , items = 0- , maxItems = 0- , nextPrio = 0- }--{-# NOINLINE theCache #-}-theCache :: IORef ResultCache-theCache = unsafePerformIO $ newIORef emptyCache---- | Cache the given value, with the given table dependencies.-cache :: Typeable a => [TableName] -> CacheKey -> a -> IO ()-cache tns k v = k `seqCK` atomicModifyIORef' theCache (\c -> (cache' tns k v c, ()))--cache' :: Typeable a => [TableName] -> CacheKey -> a -> ResultCache -> ResultCache-cache' tns k v rc- | maxItems rc == 0 = rc- | prio + 1 < prio = cache' tns k v (emptyCache {maxItems = maxItems rc})- | otherwise = rc- { results = insert k prio v' results'- , deps = foldl' (\m tn -> M.alter (addTbl k) tn m) (deps rc) tns- , nextPrio = prio + 1- , items = items'- }- where- v' = toDyn v- prio = nextPrio rc- -- evict LRU element before inserting if full- (items', results')- | items rc >= maxItems rc = (items rc, deleteMin $ results rc)- | otherwise = (items rc + 1, results rc)- addTbl key (Just ks) = Just (S.insert key ks)- addTbl key Nothing = Just (S.singleton key)---- | Get the cached value for the given key, if it exists.-cached :: forall a. Typeable a => CacheKey -> IO (Maybe a)-cached k = k `seqCK` atomicModifyIORef' theCache (cached' k)--cached' :: forall a. Typeable a => CacheKey -> ResultCache -> (ResultCache, Maybe a)-cached' k rc = do- case (maxItems rc, alter updatePrio k (results rc)) of- (0, _) -> (rc, Nothing)- (_, (Just x, results')) -> (rc' results', fromDynamic x)- _ -> (rc, Nothing)- where- rc' rs = rc- { results = rs- , nextPrio = nextPrio rc + 1- }- updatePrio (Just (_, v)) = (Just v, Just (nextPrio rc, v))- updatePrio _ = (Nothing, Nothing)---- | Invalidate all items in the per-process cache that depend on--- the given table.-invalidate :: [TableName] -> IO ()-invalidate tns = atomicModifyIORef' theCache $ \c -> (foldl' (flip invalidate') c tns, ())--invalidate' :: TableName -> ResultCache -> ResultCache-invalidate' tbl rc- | maxItems rc == 0 = rc- | otherwise = rc- { results = results'- , deps = deps'- , items = items rc - length ks- }- where- ks = maybe S.empty id $ M.lookup tbl (deps rc)- results' = S.foldl' (flip delete) (results rc) ks- deps' = M.delete tbl (deps rc)---- | Set the maximum number of items allowed in the cache.-setMaxItems :: Int -> IO ()-setMaxItems n = atomicModifyIORef' theCache $ \_ -> (setMaxItems' n, ())--setMaxItems' :: Int -> ResultCache-setMaxItems' 0 = emptyCache-setMaxItems' n = emptyCache {maxItems = n}-#endif
src/Database/Selda/Compile.hs view
@@ -5,7 +5,7 @@ module Database.Selda.Compile ( Result, Res , buildResult, compQuery, compQueryWithFreshScope- , compile, compileWith, compileWithTables+ , compile, compileWith , compileInsert, compileUpdate, compileDelete ) where@@ -35,19 +35,11 @@ -- The types given are tailored for SQLite. To translate SQLite types into -- whichever types are used by your backend, use 'compileWith'. compile :: Result a => Query s a -> (Text, [Param])-compile = snd . compileWithTables defPPConfig+compile = compileWith defPPConfig -- | Compile a query using the given type translation function. compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param])-compileWith cfg = snd . compileWithTables cfg---- | Compile a query into a parameterised SQL statement. Also returns all--- tables depended on by the query.-compileWithTables :: Result a- => PPConfig- -> Query s a- -> ([TableName], (Text, [Param]))-compileWithTables cfg = compSql cfg . snd . compQuery 0+compileWith cfg = compSql cfg . snd . compQuery 0 -- | Compile an @INSERT@ query, given the keyword representing default values -- in the target SQL dialect, a table and a list of items corresponding@@ -118,37 +110,35 @@ buildResult :: Result r => Proxy r -> [SqlValue] -> Res r buildResult p = runResultReader (toRes p) +type family Res r where+ Res (Col s a :*: b) = a :*: Res b+ Res (Row s a :*: b) = a :*: Res b+ Res (Col s a) = a+ Res (Row s a) = a+ -- | An acceptable query result type; one or more columns stitched together -- with @:*:@. class Typeable (Res r) => Result r where- type Res r -- | Converts the given list of @SqlValue@s into an tuple of well-typed -- results. -- See 'querySQLite' for example usage.- -- The given list must contain exactly as many elements as dictated by- -- the @Res r@. If the result is @a :*: b :*: c@, then the list must- -- contain exactly three values, for instance. toRes :: Proxy r -> ResultReader (Res r) -- | Produce a list of all columns present in the result. finalCols :: r -> [SomeCol SQL] instance (SqlType a, Result b) => Result (Col s a :*: b) where- type Res (Col s a :*: b) = a :*: Res b toRes _ = liftM2 (:*:) (fromSql <$> next) (toRes (Proxy :: Proxy b)) finalCols (a :*: b) = finalCols a ++ finalCols b instance (SqlRow a, Result b) => Result (Row s a :*: b) where- type Res (Row s a :*: b) = a :*: Res b toRes _ = liftM2 (:*:) nextResult (toRes (Proxy :: Proxy b)) finalCols (a :*: b) = finalCols a ++ finalCols b instance SqlType a => Result (Col s a) where- type Res (Col s a) = a toRes _ = fromSql <$> next finalCols (One c) = [Some c] instance SqlRow a => Result (Row s a) where- type Res (Row s a) = a toRes _ = nextResult finalCols (Many cs) = [Some c | Untyped c <- cs]
+ src/Database/Selda/Debug.hs view
@@ -0,0 +1,10 @@+-- | Functionality for inspecting and debugging Selda queries.+module Database.Selda.Debug+ ( OnError (..), defPPConfig+ , compile+ , compileCreateTable, compileDropTable+ , compileInsert, compileUpdate+ ) where+import Database.Selda.Backend+import Database.Selda.Compile+import Database.Selda.Table.Compile
src/Database/Selda/Exp.hs view
@@ -27,7 +27,7 @@ data Exp sql a where Col :: !ColName -> Exp sql a Lit :: !(Lit a) -> Exp sql a- BinOp :: !(BinOp a b) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql b+ BinOp :: !(BinOp a b c) -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c UnOp :: !(UnOp a b) -> !(Exp sql a) -> Exp sql b NulOp :: !(NulOp a) -> Exp sql a Fun2 :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c@@ -38,7 +38,7 @@ InQuery :: !(Exp sql a) -> !sql -> Exp sql Bool data NulOp a where- Fun0 :: Text -> NulOp a+ Fun0 :: !Text -> NulOp a data UnOp a b where Abs :: UnOp a a@@ -46,22 +46,23 @@ Neg :: UnOp a a Sgn :: UnOp a a IsNull :: UnOp (Maybe a) Bool- Fun :: Text -> UnOp a b+ Fun :: !Text -> UnOp a b -data BinOp a b where- Gt :: BinOp a Bool- Lt :: BinOp a Bool- Gte :: BinOp a Bool- Lte :: BinOp a Bool- Eq :: BinOp a Bool- Neq :: BinOp a Bool- And :: BinOp Bool Bool- Or :: BinOp Bool Bool- Add :: BinOp a a- Sub :: BinOp a a- Mul :: BinOp a a- Div :: BinOp a a- Like :: BinOp Text Bool+data BinOp a b c where+ Gt :: BinOp a a Bool+ Lt :: BinOp a a Bool+ Gte :: BinOp a a Bool+ Lte :: BinOp a a Bool+ Eq :: BinOp a a Bool+ Neq :: BinOp a a Bool+ And :: BinOp Bool Bool Bool+ Or :: BinOp Bool Bool Bool+ Add :: BinOp a a a+ Sub :: BinOp a a a+ Mul :: BinOp a a a+ Div :: BinOp a a a+ Like :: BinOp Text Text Bool+ CustomOp :: !Text -> BinOp a b c -- | Any type which may contain column names. class Names a where
+ src/Database/Selda/FieldSelectors.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DataKinds, KindSignatures, TypeOperators, PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-}+{-# LANGUAGE TypeApplications, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Create Selda selectors from plain record field selectors.+-- Requires the @OverloadedLabels@ language extension.+module Database.Selda.FieldSelectors+ (FieldType, HasField, IsLabel+ ) where+import Database.Selda.Generic (Relational)+import Database.Selda.Selectors as S+import Database.Selda.SqlType (SqlType)+import Data.Kind (Constraint)+import GHC.Generics+import GHC.TypeLits+import GHC.OverloadedLabels++-- | Get the next nested type.+type family GetFieldType (f :: * -> *) :: * where+ GetFieldType (M1 c i f) = GetFieldType f+ GetFieldType (K1 i a) = a++-- | Get the type of the field @name@ from the generic representation @a@,+-- returning the default value @b@ if the field does not exist.+type family GFieldType (a :: * -> *) (b :: *) (name :: Symbol) :: * where+ GFieldType (M1 S ('MetaSel ('Just name) su ss ds) f) b name = GetFieldType f+ GFieldType (M1 c i a) b name = GFieldType a b name+ GFieldType (a :*: b) c name = GFieldType a (GFieldType b c name) name+ GFieldType a b name = b++-- | The type of the @name@ field, in the record type @t@.+type FieldType name t = GFieldType (Rep t) (NoSuchSelector t name) name++type family NonError (t :: k) :: Constraint where+ NonError (NoSuchSelector t s) = TypeError+ ( 'Text "Row type '" ':<>: 'ShowType t ':<>:+ 'Text "' has no selector " ':<>: 'ShowType s ':<>: 'Text "."+ )+ NonError t = ()++-- | Internal representation of the "no such selector" error message.+data NoSuchSelector (t :: *) (s :: Symbol)++-- | Any table type @t@, which has a field named @name@.+class ( Relational t+ , SqlType (FieldType name t)+ , GRSel name (Rep t)+ , NonError (FieldType name t)) =>+ HasField (name :: Symbol) t++instance ( Relational t+ , SqlType (FieldType name t)+ , GRSel name (Rep t)+ , NonError (FieldType name t)) =>+ HasField (name :: Symbol) t++instance (Relational t, HasField name t, FieldType name t ~ a) =>+ IsLabel name (S.Selector t a) where+#if MIN_VERSION_base(4, 10, 0)+ fromLabel = field @name @t+#else+ fromLabel _ = field @name @t+#endif++-- | Create a selector from a record selector and a type application.+--+-- For example:+-- > data Foo = Foo+-- > { foo :: Int+-- > , bar :: Text+-- > } deriving Generic+-- > instance SqlRow Foo+-- >+-- > fooTable :: Table Foo+-- > fooTable = table "foo"+-- >+-- > getAllBars :: Query s (Col s Text)+-- > getAllBars = do+-- > t <- select fooTable+-- > return (t ! field @"bar")+field :: forall name t.+ (Relational t, HasField name t)+ => S.Selector t (FieldType name t)+field =+ case gSel @name @(Rep t) 0 of+ Left n -> unsafeSelector n+ _ -> error "unreachable"++class GRSel (s :: Symbol) (f :: * -> *) where+ gSel :: Int -> Either Int Int++instance GRSel name (M1 S ('MetaSel ('Just name) su ss ds) f) where+ gSel = Left++instance {-# OVERLAPPABLE #-} GRSel name f => GRSel name (M1 i s f) where+ gSel = gSel @name @f++instance (GRSel name a, GRSel name b) => GRSel name (a :*: b) where+ gSel n = gSel @name @a n >>= gSel @name @b . succ++instance GRSel name (K1 i a) where+ gSel = Right
src/Database/Selda/Frontend.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-} -- | API for running Selda operations over databases. module Database.Selda.Frontend- ( Result, Res, MonadIO (..), MonadSelda (..), SeldaT+ ( Result, Res, MonadIO (..), MonadSelda (..), SeldaT, OnError (..) , query, queryInto , insert, insert_, insertWithPK, tryInsert, insertWhen, insertUnless , update, update_, upsert , deleteFrom, deleteFrom_- , createTable, tryCreateTable+ , createTable, tryCreateTable, createTableWithoutIndexes, createTableIndexes , dropTable, tryDropTable- , transaction, setLocalCache, withoutForeignKeyEnforcement+ , transaction, withoutForeignKeyEnforcement ) where import Database.Selda.Backend.Internal-import Database.Selda.Caching import Database.Selda.Column import Database.Selda.Compile import Database.Selda.Generic@@ -30,22 +29,19 @@ -- transformer on top of some other monad. -- Selda transformers are entered using backend-specific @withX@ functions, -- such as 'withSQLite' from the SQLite backend.-query :: (MonadSelda m, Result a) => Query s a -> m [Res a]-query q = do- backend <- seldaBackend- queryWith (runStmt backend) q+query :: (MonadSelda m, Result a) => Query (Backend m) a -> m [Res a]+query q = withBackend (flip queryWith q . runStmt) -- | Perform the given query, and insert the result into the given table. -- Returns the number of inserted rows. queryInto :: (MonadSelda m, Relational a) => Table a- -> Query s (Row s a)+ -> Query (Backend m) (Row (Backend m) a) -> m Int-queryInto tbl q = do- backend <- seldaBackend- let (qry, ps) = compileWith (ppConfig backend) q+queryInto tbl q = withBackend $ \b -> do+ let (qry, ps) = compileWith (ppConfig b) q qry' = mconcat ["INSERT INTO ", tblName, " ", qry]- fmap fst . liftIO $ runStmt backend qry' ps+ fmap fst . liftIO $ runStmt b qry' ps where tblName = fromTableName (tableName tbl) @@ -80,11 +76,8 @@ insert :: (MonadSelda m, Relational a) => Table a -> [a] -> m Int insert _ [] = do return 0-insert t cs = do- cfg <- ppConfig <$> seldaBackend- res <- mapM (uncurry exec) $ compileInsert cfg t cs- invalidateTable t- return (sum res)+insert t cs = withBackend $ \b -> do+ sum <$> mapM (uncurry exec) (compileInsert (ppConfig b) t cs) -- | Attempt to insert a list of rows into a table, but don't raise an error -- if the insertion fails. Returns @True@ if the insertion succeeded, otherwise@@ -109,12 +102,10 @@ -- -- Note that this may perform two separate queries: one update, potentially -- followed by one insert.-upsert :: ( MonadSelda m- , Relational a- )+upsert :: (MonadSelda m, MonadMask m, Relational a) => Table a- -> (Row s a -> Col s Bool)- -> (Row s a -> Row s a)+ -> (Row (Backend m) a -> Col (Backend m) Bool)+ -> (Row (Backend m) a -> Row (Backend m) a) -> [a] -> m (Maybe (ID a)) upsert tbl check upd rows = transaction $ do@@ -130,22 +121,18 @@ -- If called on a table which doesn't have an auto-incrementing primary key, -- @Just id@ is always returned on successful insert, where @id@ is a row -- identifier guaranteed to not match any row in any table.-insertUnless :: ( MonadSelda m- , Relational a- )+insertUnless :: (MonadSelda m, MonadMask m, Relational a) => Table a- -> (Row s a -> Col s Bool)+ -> (Row (Backend m) a -> Col (Backend m) Bool) -> [a] -> m (Maybe (ID a)) insertUnless tbl check rows = upsert tbl check id rows -- | Like 'insertUnless', but performs the insert when at least one row matches -- the predicate.-insertWhen :: ( MonadSelda m- , Relational a- )+insertWhen :: (MonadSelda m, MonadMask m, Relational a) => Table a- -> (Row s a -> Col s Bool)+ -> (Row (Backend m) a -> Col (Backend m) Bool) -> [a] -> m (Maybe (ID a)) insertWhen tbl check rows = transaction $ do@@ -164,13 +151,11 @@ -- primary key will always return a row identifier that is guaranteed to not -- match any row in any table. insertWithPK :: (MonadSelda m, Relational a) => Table a -> [a] -> m (ID a)-insertWithPK t cs = do- b <- seldaBackend+insertWithPK t cs = withBackend $ \b -> do if tableHasAutoPK t then do res <- liftIO $ do mapM (uncurry (runStmtWithPK b)) $ compileInsert (ppConfig b) t cs- invalidateTable t return $ toId (last res) else do insert_ t cs@@ -179,21 +164,19 @@ -- | Update the given table using the given update function, for all rows -- matching the given predicate. Returns the number of updated rows. update :: (MonadSelda m, Relational a)- => Table a -- ^ Table to update.- -> (Row s a -> Col s Bool) -- ^ Predicate.- -> (Row s a -> Row s a) -- ^ Update function.+ => Table a -- ^ Table to update.+ -> (Row (Backend m) a -> Col (Backend m) Bool) -- ^ Predicate.+ -> (Row (Backend m) a -> Row (Backend m) a) -- ^ Update function. -> m Int-update tbl check upd = do- cfg <- ppConfig <$> seldaBackend- res <- uncurry exec $ compileUpdate cfg tbl upd check- invalidateTable tbl+update tbl check upd = withBackend $ \b -> do+ res <- uncurry exec $ compileUpdate (ppConfig b) tbl upd check return res -- | Like 'update', but doesn't return the number of updated rows. update_ :: (MonadSelda m, Relational a) => Table a- -> (Row s a -> Col s Bool)- -> (Row s a -> Row s a)+ -> (Row (Backend m) a -> Col (Backend m) Bool)+ -> (Row (Backend m) a -> Row (Backend m) a) -> m () update_ tbl check upd = void $ update tbl check upd @@ -201,49 +184,60 @@ -- Returns the number of deleted rows. deleteFrom :: (MonadSelda m, Relational a) => Table a- -> (Row s a -> Col s Bool)+ -> (Row (Backend m) a -> Col (Backend m) Bool) -> m Int-deleteFrom tbl f = do- cfg <- ppConfig <$> seldaBackend- res <- uncurry exec $ compileDelete cfg tbl f- invalidateTable tbl+deleteFrom tbl f = withBackend $ \b -> do+ res <- uncurry exec $ compileDelete (ppConfig b) tbl f return res -- | Like 'deleteFrom', but does not return the number of deleted rows. deleteFrom_ :: (MonadSelda m, Relational a) => Table a- -> (Row s a -> Col s Bool)+ -> (Row (Backend m) a -> Col (Backend m) Bool) -> m () deleteFrom_ tbl f = void $ deleteFrom tbl f -- | Create a table from the given schema. createTable :: MonadSelda m => Table a -> m () createTable tbl = do- cfg <- ppConfig <$> seldaBackend- mapM_ (flip exec []) $ compileCreateTable cfg Fail tbl+ createTableWithoutIndexes Fail tbl+ createTableIndexes Fail tbl +-- | Create a table from the given schema, but don't create any indexes.+createTableWithoutIndexes :: MonadSelda m => OnError -> Table a -> m ()+createTableWithoutIndexes onerror tbl = withBackend $ \b -> do+ void $ exec (compileCreateTable (ppConfig b) onerror tbl) []++-- | Create all indexes for the given table. Fails if any of the table's indexes+-- already exists.+createTableIndexes :: MonadSelda m => OnError -> Table a -> m ()+createTableIndexes ifex tbl = withBackend $ \b -> do+ mapM_ (flip exec []) $ compileCreateIndexes (ppConfig b) ifex tbl+ -- | Create a table from the given schema, unless it already exists. tryCreateTable :: MonadSelda m => Table a -> m () tryCreateTable tbl = do- cfg <- ppConfig <$> seldaBackend- mapM_ (flip exec []) $ compileCreateTable cfg Ignore tbl+ createTableWithoutIndexes Ignore tbl+ createTableIndexes Ignore tbl -- | Drop the given table. dropTable :: MonadSelda m => Table a -> m ()-dropTable = withInval $ void . flip exec [] . compileDropTable Fail+dropTable = void . flip exec [] . compileDropTable Fail -- | Drop the given table, if it exists. tryDropTable :: MonadSelda m => Table a -> m ()-tryDropTable = withInval $ void . flip exec [] . compileDropTable Ignore+tryDropTable = void . flip exec [] . compileDropTable Ignore -- | Perform the given computation atomically. -- If an exception is raised during its execution, the entire transaction -- will be rolled back and the exception re-thrown, even if the exception -- is caught and handled within the transaction.-transaction :: MonadSelda m => m a -> m a-transaction m = do- wrapTransaction (void $ exec "COMMIT" []) (void $ exec "ROLLBACK" []) $ do- exec "BEGIN TRANSACTION" [] *> m+transaction :: (MonadSelda m, MonadMask m) => m a -> m a+transaction m = mask $ \restore -> transact $ do+ void $ exec "BEGIN TRANSACTION" []+ x <- restore m `onException` void (exec "ROLLBACK" [])+ void $ exec "COMMIT" []+ return x -- | Run the given computation as a transaction without enforcing foreign key -- constraints.@@ -254,63 +248,28 @@ -- -- On the PostgreSQL backend, at least PostgreSQL 9.6 is required. withoutForeignKeyEnforcement :: (MonadSelda m, MonadMask m) => m a -> m a-withoutForeignKeyEnforcement m = do- b <- seldaBackend+withoutForeignKeyEnforcement m = withBackend $ \b -> do bracket_ (liftIO $ disableForeignKeys b True) (liftIO $ disableForeignKeys b False) m --- | Set the maximum local cache size to @n@. A cache size of zero disables--- local cache altogether. Changing the cache size will also flush all--- entries. Note that the cache is shared among all Selda computations running--- within the same process.------ By default, local caching is turned off.------ WARNING: local caching is guaranteed to be consistent with the underlying--- database, ONLY under the assumption that no other process will modify it.--- Also note that the cache is shared between ALL Selda computations running--- within the same process.-setLocalCache :: MonadIO m => Int -> m ()-setLocalCache = liftIO . setMaxItems- -- | Build the final result from a list of result columns.-queryWith :: forall s m a. (MonadSelda m, Result a)- => QueryRunner (Int, [[SqlValue]]) -> Query s a -> m [Res a]-queryWith qr q = do- conn <- seldaConnection- let backend = connBackend conn- db = connDbId conn- cacheKey = (db, qs, ps)- (tables, qry@(qs, ps)) = compileWithTables (ppConfig backend) q- mres <- liftIO $ cached cacheKey- case mres of- Just res -> do- return res- _ -> do- res <- fmap snd . liftIO $ uncurry qr qry- let res' = mkResults (Proxy :: Proxy a) res- liftIO $ cache tables cacheKey res'- return res'+queryWith :: forall m a. (MonadSelda m, Result a)+ => QueryRunner (Int, [[SqlValue]]) -> Query (Backend m) a -> m [Res a]+queryWith run q = withBackend $ \b -> do+ res <- fmap snd . liftIO . uncurry run $ compileWith (ppConfig b) q+ return $ mkResults (Proxy :: Proxy a) res -- | Generate the final result of a query from a list of untyped result rows. mkResults :: Result a => Proxy a -> [[SqlValue]] -> [Res a] mkResults p = map (buildResult p) --- | Run the given computation over a table after invalidating all cached--- results depending on that table.-withInval :: MonadSelda m => (Table a -> m b) -> Table a -> m b-withInval f t = do- res <- f t- invalidateTable t- return res-+{-# INLINE exec #-} -- | Execute a statement without a result. exec :: MonadSelda m => Text -> [Param] -> m Int-exec q ps = do- backend <- seldaBackend- liftIO $ execIO backend q ps+exec q ps = withBackend $ \b -> liftIO $ execIO b q ps +{-# INLINE execIO #-} -- | Like 'exec', but in 'IO'.-execIO :: SeldaBackend -> Text -> [Param] -> IO Int+execIO :: SeldaBackend b -> Text -> [Param] -> IO Int execIO backend q ps = fmap fst $ runStmt backend q ps
src/Database/Selda/Generic.hs view
@@ -16,11 +16,9 @@ #endif import GHC.Generics hiding (R, (:*:), Selector) import qualified GHC.Generics as G ((:*:)(..), Selector)-#if MIN_VERSION_base(4, 9, 0) import qualified GHC.TypeLits as TL import qualified GHC.Generics as G ((:+:)(..)) import qualified Database.Selda.Column as C (Col)-#endif import Control.Exception (Exception (..), try, throw) import System.IO.Unsafe import Database.Selda.Types@@ -143,7 +141,6 @@ b = Proxy :: Proxy b gNew _ = gNew (Proxy :: Proxy a) ++ gNew (Proxy :: Proxy b) -#if MIN_VERSION_base(4, 9, 0) instance (TL.TypeError ( 'TL.Text "Selda currently does not support creating tables from sum types."@@ -163,4 +160,3 @@ gParams = error "unreachable" gTblCols = error "unreachable" gNew = error "unreachable"-#endif
src/Database/Selda/Inner.hs view
@@ -9,9 +9,7 @@ import Database.Selda.Types import Data.Text (Text) import Data.Typeable-#if MIN_VERSION_base(4, 9, 0) import GHC.TypeLits as TL-#endif -- | A single aggregate column. -- Aggregate columns may not be used to restrict queries.@@ -52,7 +50,6 @@ OuterCols (Col (Inner s) a) = Col s a OuterCols (Row (Inner s) a :*: b) = Row s a :*: OuterCols b OuterCols (Row (Inner s) a) = Row s a-#if MIN_VERSION_base(4, 9, 0) OuterCols (Col s a) = TypeError ( 'TL.Text "An inner query can only return rows and columns from its own scope." )@@ -63,12 +60,10 @@ ( 'TL.Text "Only (inductive tuples of) row and columns can be returned from" ':$$: 'TL.Text "an inner query." )-#endif type family AggrCols a where AggrCols (Aggr (Inner s) a :*: b) = Col s a :*: AggrCols b AggrCols (Aggr (Inner s) a) = Col s a-#if MIN_VERSION_base(4, 9, 0) AggrCols (Aggr s a) = TypeError ( 'TL.Text "An aggregate query can only return columns from its own" ':$$: 'TL.Text "scope."@@ -77,7 +72,6 @@ ( 'TL.Text "Only (inductive tuples of) aggregates can be returned from" ':$$: 'TL.Text "an aggregate query." )-#endif -- | The results of a left join are always nullable, as there is no guarantee -- that all joined columns will be non-null.@@ -97,12 +91,10 @@ LeftCols (Row (Inner s) a :*: b) = Row s (Maybe a) :*: LeftCols b LeftCols (Row (Inner s) (Maybe a)) = Row s (Maybe a) LeftCols (Row (Inner s) a) = Row s (Maybe a)-#if MIN_VERSION_base(4, 9, 0) LeftCols a = TypeError ( 'TL.Text "Only (inductive tuples of) rows and columns can be returned" ':$$: 'TL.Text "from a join." )-#endif -- | One or more aggregate columns. class Aggregates a where
+ src/Database/Selda/MakeSelectors.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE ScopedTypeVariables, TypeOperators, KindSignatures #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+-- | Utilities for creating selectors for non-record types.+-- In general, you should really use record types for your tables and+-- their record labels (i.e. #label) as selectors using+-- the @OverloadedLabels@ extension instead.+module Database.Selda.MakeSelectors+ ( Selectors, GSelectors+ , selectors, tableWithSelectors+ ) where+import Control.Monad.State.Strict+import Data.Proxy+import GHC.Generics hiding (Selector, (:*:))+import qualified GHC.Generics as G+import Database.Selda.Generic (Relational)+import Database.Selda.Selectors+import Database.Selda.SqlRow+import Database.Selda.SqlType+import Database.Selda.Table+import Database.Selda.Types++-- | Generate selector functions for the given table.+-- Selectors can be used to access the fields of a query result tuple, avoiding+-- the need to pattern match on the entire tuple.+--+-- > tbl :: Table (Int, Text)+-- > tbl = table "foo" []+-- > (tblBar :*: tblBaz) = selectors tbl+-- >+-- > q :: Query s Text+-- > q = do+-- > row <- select tbl+-- > return (row ! tblBaz)+selectors :: forall a. (Relational a, GSelectors a (Rep a))+ => Table a+ -> Selectors a+selectors _ = selectorsFor (Proxy :: Proxy a)++-- | A pair of the table with the given name and columns, and all its selectors.+-- For example:+--+-- > tbl :: Table (Int, Text)+-- > (tbl, tblBar :*: tblBaz)+-- > = tableWithSelectors "foo" []+-- >+-- > q :: Query s Text+-- > q = tblBaz `from` select tbl+tableWithSelectors :: forall a. (Relational a, GSelectors a (Rep a))+ => TableName+ -> [Attr a]+ -> (Table a, Selectors a)+tableWithSelectors name cs = (t, s)+ where+ t = table name cs+ s = selectors t++-- | Generate selectors for the given type.+selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r+selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r))++-- | An inductive tuple of selectors for the given relation.+type Selectors r = Sels r (Rep r)++type family Sels t f where+ Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))+ Sels t (a G.:*: b) = Sels t a :*: Sels t b+ Sels t (M1 x y f) = Sels t f+ Sels t (K1 i a) = Selector t a++-- | Any table type that can have selectors generated.+class GSelectors t (f :: * -> *) where+ mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)++instance (SqlRow t, SqlType a) => GSelectors t (K1 i a) where+ mkSel _ _ = unsafeSelector <$> state (\n -> (n, n+1))++instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>+ GSelectors t (M1 x y f) where+ mkSel _ = mkSel (Proxy :: Proxy f)++instance GSelectors t (a G.:*: (b G.:*: c)) =>+ GSelectors t ((a G.:*: b) G.:*: c) where+ mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))++instance {-# OVERLAPPABLE #-}+ ( GSelectors t a+ , GSelectors t b+ , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)+ ) => GSelectors t (a G.:*: b) where+ mkSel _ p = do+ x <- mkSel (Proxy :: Proxy a) p+ xs <- mkSel (Proxy :: Proxy b) p+ return (x :*: xs)
src/Database/Selda/Migrations.hs view
@@ -7,6 +7,10 @@ import Control.Monad (void, when) import Control.Monad.Catch import Database.Selda hiding (from)+import Database.Selda.Frontend+ ( OnError (..)+ , createTableWithoutIndexes, createTableIndexes+ ) import Database.Selda.Backend.Internal import Database.Selda.Table.Type (tableName) import Database.Selda.Table.Validation (ValidationError (..))@@ -21,16 +25,16 @@ -- > , Migration m2_from m2_to m2_upgrade -- > , ... -- > ]-data Migration where+data Migration backend where Migration :: (Relational a, Relational b) => Table a -> Table b- -> (Row s a -> Query s (Row s b))- -> Migration+ -> (Row backend a -> Query backend (Row backend b))+ -> Migration backend -- | A migration step is zero or more migrations that need to be performed in -- a single transaction in order to keep the database consistent.-type MigrationStep = [Migration]+type MigrationStep backend = [Migration backend] -- | Migrate the first table into the second, using the given function to -- migrate all records to the new schema.@@ -42,17 +46,17 @@ migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b) => Table a -- ^ Table to migrate from. -> Table b -- ^ Table to migrate to.- -> (Row () a -> Row () b)+ -> (Row (Backend m) a -> Row (Backend m) b) -- ^ Mapping from old to new table. -> m ()-migrate t1 t2 upg = migrateM t1 t2 ((pure :: a -> Query () a) . upg)+migrate t1 t2 upg = migrateM t1 t2 (pure . upg) -- | Like 'migrate', but allows the column upgrade to access -- the entire database. migrateM :: (MonadSelda m, MonadMask m, Relational a, Relational b) => Table a -> Table b- -> (Row s a -> Query s (Row s b))+ -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)) -> m () migrateM t1 t2 upg = migrateAll True [Migration t1 t2 upg] @@ -64,7 +68,7 @@ -- | Perform all given migrations as a single transaction. migrateAll :: (MonadSelda m, MonadMask m) => Bool -- ^ Enforce foreign keys during migration?- -> MigrationStep -- ^ Migration step to perform.+ -> MigrationStep (Backend m) -- ^ Migration step to perform. -> m () migrateAll fks = wrap fks . mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg)@@ -84,7 +88,7 @@ -- @c2@ is indexed with index method @bar@. autoMigrate :: (MonadSelda m, MonadMask m) => Bool -- ^ Enforce foreign keys during migration?- -> [MigrationStep] -- ^ Migration steps to perform.+ -> [MigrationStep (Backend m)] -- ^ Migration steps to perform. -> m () autoMigrate _ [] = do return ()@@ -113,16 +117,16 @@ migrateInternal :: (MonadSelda m, MonadThrow m, Relational a, Relational b) => Table a -> Table b- -> (Row s a -> Query s (Row s b))+ -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)) -> m ()-migrateInternal t1 t2 upg = do+migrateInternal t1 t2 upg = withBackend $ \b -> do validateTable t1 validateSchema t2- backend <- seldaBackend- createTable t2'+ createTableWithoutIndexes Fail t2' void . queryInto t2' $ select t1 >>= upg- void . liftIO $ runStmt backend (dropQuery (tableName t1)) []- void . liftIO $ runStmt backend renameQuery []+ void . liftIO $ runStmt b (dropQuery (tableName t1)) []+ void . liftIO $ runStmt b renameQuery []+ createTableIndexes Fail t2 where t2' = t2 {tableName = mkTableName newName} `asTypeOf` t2 newName = mconcat ["__selda_migration_", rawTableName (tableName t2)]
src/Database/Selda/Nullable.hs view
@@ -26,7 +26,7 @@ -- | Unconditionally convert a nullable value into a non-nullable one, -- using the standard SQL null-coalescing behavior. fromNullable :: SqlType (NonNull a) => Col s a -> Col s (NonNull a)-fromNullable = cast+fromNullable = unsafeCoerce (?==), (?/=) :: (a :?~ b, SqlType a) => Col s a -> Col s b -> Col s (Maybe Bool) @@ -72,9 +72,9 @@ nonNull :: SqlType a => Col s (Maybe a) -> Query s (Col s a) nonNull x = do restrict (not_ $ isNull x)- return (cast x)+ return (fromNullable x) -- | Restrict a query using a nullable expression. -- Equivalent to @restrict . ifNull false@. restrict' :: Col s (Maybe Bool) -> Query s ()-restrict' = restrict . cast+restrict' = restrict . fromNullable
src/Database/Selda/Prepared.hs view
@@ -4,15 +4,13 @@ -- | Building and executing prepared statements. module Database.Selda.Prepared (Preparable, Prepare, prepared) where import Database.Selda.Backend.Internal-import Database.Selda.Caching import Database.Selda.Column import Database.Selda.Compile import Database.Selda.Query.Type import Database.Selda.SQL (param, paramType)-import Database.Selda.Types (TableName) import Control.Exception import Control.Monad.IO.Class-import qualified Data.HashMap.Strict as M+import qualified Data.IntMap as M import Data.IORef import Data.Proxy import Data.Text (Text)@@ -34,9 +32,9 @@ type family Equiv q f where Equiv (Col s a -> q) (a -> f) = Equiv q f- Equiv (Query s a) (m [b]) = Res a ~ b+ Equiv (Query s a) (m [b]) = (Res a ~ b, Backend m ~ s) -type CompResult = (Text, [Either Int Param], [SqlTypeRep], [TableName])+type CompResult = (Text, [Either Int Param], [SqlTypeRep]) class Preparable q where -- | Prepare the query and parameter list.@@ -66,8 +64,7 @@ -- For once, this is actually safe: the IORef points to a single compiled -- statement, so the only consequence of a race between the read and the write -- is that the statement gets compiled (note: NOT prepared) twice.- mkFun ref sid qry arguments = do- conn <- seldaConnection+ mkFun ref (StmtID sid) qry arguments = withConnection $ \conn -> do let backend = connBackend conn args = reverse arguments stmts <- liftIO $ readIORef (connStmts conn)@@ -79,7 +76,7 @@ -- Statement wasn't prepared for this connection; check if it was at -- least previously compiled for this backend. compiled <- liftIO $ readIORef ref- (q, params, reps, ts) <- case compiled of+ (q, params, reps) <- case compiled of Just (bid, comp) | bid == backendId backend -> do return comp _ -> do@@ -89,41 +86,33 @@ -- Prepare and execute liftIO $ mask $ \restore -> do- hdl <- prepareStmt backend sid reps q+ hdl <- prepareStmt backend (StmtID sid) reps q let stm = SeldaStmt { stmtHandle = hdl , stmtParams = params- , stmtTables = ts , stmtText = q } atomicModifyIORef' (connStmts conn) $ \m -> (M.insert sid stm m, ()) restore $ runQuery conn stm args where runQuery conn stm args = do- let backend = connBackend conn- ps = replaceParams (stmtParams stm) args- key = (connDbId conn, stmtText stm, ps)+ let ps = replaceParams (stmtParams stm) args hdl = stmtHandle stm- mres <- cached key- case mres of- Just res -> do- return res- _ -> do- res <- runPrepared backend hdl ps- cache (stmtTables stm) key res- return $ map (buildResult (Proxy :: Proxy (ResultT q))) (snd res)+ res <- runPrepared (connBackend conn) hdl ps+ return $ map (buildResult (Proxy :: Proxy (ResultT q))) (snd res) instance (SqlType a, Preparable b) => Preparable (Col s a -> b) where- mkQuery n f ts = mkQuery (n+1) (f x) (sqlType (Proxy :: Proxy a) : ts)- where x = One $ Lit $ LCustom (throw (Placeholder n) :: Lit a)+ mkQuery n f ts = mkQuery (n+1) (f x) (t : ts)+ where+ t = sqlType (Proxy :: Proxy a)+ x = One $ Lit $ LCustom t (throw (Placeholder n) :: Lit a) instance Result a => Preparable (Query s a) where- mkQuery _ q types = do- b <- seldaBackend- case compileWithTables (ppConfig b) q of- (tables, (q', ps)) -> do+ mkQuery _ q types = withBackend $ \b -> do+ case compileWith (ppConfig b) q of+ (q', ps) -> do (ps', types') <- liftIO $ inspectParams (reverse types) ps- return (q', ps', types', tables)+ return (q', ps', types') -- | Create a prepared Selda function. A prepared function has zero or more -- arguments, and will get compiled into a prepared statement by the first@@ -145,16 +134,20 @@ -- queries aren't re-prepared more than absolutely necessary, -- consider adding a @NOINLINE@ annotation to each prepared function. --+-- Note that when using a constrained backend type variable (i.e.+-- @foo :: Bar b => SeldaM b [Int]@), optimizations must be enabled for+-- prepared statements to be effective.+-- -- A usage example: ----- > ages :: Table (Text :*: Int)--- > ages = table "ages" $ primary "name" :*: required "age"+-- > persons :: Table (Text, Int)+-- > (persons, name :*: age) = tableWithSelectors "ages" [name :- primary] -- > -- > {-# NOINLINE ageOf #-} -- > ageOf :: Text -> SeldaM [Int] -- > ageOf = prepared $ \n -> do--- > (name :*: age) <- select ages--- > restrict $ name .== n+-- > person <- select ages+-- > restrict $ (person!name .== n) -- > return age {-# NOINLINE prepared #-} prepared :: (Preparable q, Prepare q f, Equiv q f) => q -> f@@ -192,5 +185,5 @@ -- | Force a parameter deep enough to determine whether it is a placeholder. forceParam :: Param -> Param-forceParam p@(Param (LCustom x)) | x `seq` True = p-forceParam p = p+forceParam p@(Param (LCustom _ x)) | x `seq` True = p+forceParam p = p
src/Database/Selda/Query.hs view
@@ -21,7 +21,7 @@ -- | Query the given table. select :: Relational a => Table a -> Query s (Row s a)-select (Table name cs _) = Query $ do+select (Table name cs _ _) = Query $ do rns <- renameAll $ map colExpr cs st <- get put $ st {sources = sqlFrom rns (TableName name) : sources st}
src/Database/Selda/SQL/Print.hs view
@@ -25,7 +25,6 @@ data PPState = PPState { ppParams :: ![Param]- , ppTables :: ![TableName] , ppParamNS :: !Int , ppQueryNS :: !Int , ppConfig :: !PPConfig@@ -34,20 +33,18 @@ -- | Run a pretty-printer. runPP :: PPConfig -> PP Text- -> ([TableName], (Text, [Param]))+ -> (Text, [Param]) runPP cfg pp =- case runState pp (PPState [] [] 1 0 cfg) of- (q, st) -> (snub $ ppTables st, (q, reverse (ppParams st)))+ case runState pp (PPState [] 1 0 cfg) of+ (q, st) -> (q, reverse (ppParams st)) -- | Compile an SQL AST into a parameterized SQL query.-compSql :: PPConfig- -> SQL- -> ([TableName], (Text, [Param]))+compSql :: PPConfig -> SQL -> (Text, [Param]) compSql cfg = runPP cfg . ppSql -- | Compile a single column expression. compExp :: PPConfig -> Exp SQL a -> (Text, [Param])-compExp cfg = snd . runPP cfg . ppCol+compExp cfg = runPP cfg . ppCol -- | Compile an @UPATE@ statement. compUpdate :: PPConfig@@ -55,7 +52,7 @@ -> Exp SQL Bool -> [(ColName, SomeCol SQL)] -> (Text, [Param])-compUpdate cfg tbl p cs = snd $ runPP cfg ppUpd+compUpdate cfg tbl p cs = runPP cfg ppUpd where ppUpd = do updates <- mapM ppUpdate cs@@ -81,7 +78,7 @@ -- | Compile a @DELETE@ statement. compDelete :: PPConfig -> TableName -> Exp SQL Bool -> (Text, [Param])-compDelete cfg tbl p = snd $ runPP cfg ppDelete+compDelete cfg tbl p = runPP cfg ppDelete where ppDelete = do c' <- ppCol p@@ -93,20 +90,15 @@ ppLit LNull = pure "NULL" ppLit (LJust l) = ppLit l ppLit l = do- PPState ps ts ns qns tr <- get- put $ PPState (Param l : ps) ts (succ ns) qns tr+ PPState ps ns qns tr <- get+ put $ PPState (Param l : ps) (succ ns) qns tr return $ Text.pack ('$':show ns) -dependOn :: TableName -> PP ()-dependOn t = do- PPState ps ts ns qns tr <- get- put $ PPState ps (t:ts) ns qns tr- -- | Generate a unique name for a subquery. freshQueryName :: PP Text freshQueryName = do- PPState ps ts ns qns tr <- get- put $ PPState ps ts ns (succ qns) tr+ PPState ps ns qns tr <- get+ put $ PPState ps ns (succ qns) tr return $ Text.pack ('q':show qns) -- | Pretty-print an SQL AST.@@ -134,7 +126,6 @@ qn <- freshQueryName pure $ " FROM (SELECT NULL LIMIT 0) AS " <> qn ppSrc (TableName n) = do- dependOn n pure $ " FROM " <> fromTableName n ppSrc (Product []) = do pure ""@@ -260,7 +251,7 @@ IsNull -> "(" <> c' <> ") IS NULL" Fun f -> f <> "(" <> c' <> ")" -ppBinOp :: BinOp a b -> Exp SQL a -> Exp SQL a -> PP Text+ppBinOp :: BinOp a b c -> Exp SQL a -> Exp SQL b -> PP Text ppBinOp op a b = do a' <- ppCol a b' <- ppCol b@@ -271,17 +262,18 @@ paren (Lit{}) c = c paren _ c = "(" <> c <> ")" - ppOp :: BinOp a b -> Text- ppOp Gt = ">"- ppOp Lt = "<"- ppOp Gte = ">="- ppOp Lte = "<="- ppOp Eq = "="- ppOp Neq = "!="- ppOp And = "AND"- ppOp Or = "OR"- ppOp Add = "+"- ppOp Sub = "-"- ppOp Mul = "*"- ppOp Div = "/"- ppOp Like = "LIKE"+ ppOp :: BinOp a b c -> Text+ ppOp Gt = ">"+ ppOp Lt = "<"+ ppOp Gte = ">="+ ppOp Lte = "<="+ ppOp Eq = "="+ ppOp Neq = "!="+ ppOp And = "AND"+ ppOp Or = "OR"+ ppOp Add = "+"+ ppOp Sub = "-"+ ppOp Mul = "*"+ ppOp Div = "/"+ ppOp Like = "LIKE"+ ppOp (CustomOp s) = s
src/Database/Selda/SQL/Print/Config.hs view
@@ -66,6 +66,7 @@ } -- | Default compilation for SQL types.+-- By default, anything we don't know is just a blob. defType :: SqlTypeRep -> Text defType TText = "TEXT" defType TRowID = "INTEGER"@@ -76,12 +77,15 @@ defType TDate = "DATE" defType TTime = "TIME" defType TBlob = "BLOB"+defType TUUID = "BLOB"+defType TJSON = "BLOB" -- | Default compilation for a column attribute. defColAttr :: ColAttr -> Text-defColAttr Primary = "PRIMARY KEY"-defColAttr AutoIncrement = "AUTOINCREMENT"-defColAttr Required = "NOT NULL"-defColAttr Optional = "NULL"-defColAttr Unique = "UNIQUE"-defColAttr (Indexed _) = ""+defColAttr Primary = ""+defColAttr (AutoPrimary Strong) = "PRIMARY KEY AUTOINCREMENT"+defColAttr (AutoPrimary Weak) = "PRIMARY KEY"+defColAttr Required = "NOT NULL"+defColAttr Optional = "NULL"+defColAttr Unique = "UNIQUE"+defColAttr (Indexed _) = ""
src/Database/Selda/Selectors.hs view
@@ -50,14 +50,10 @@ -- | A selector-value assignment pair. data Assignment s a where-#if MIN_VERSION_base(4, 9, 0) -- | Set the given column to the given value.-#endif (:=) :: Selector t a -> Col s a -> Assignment s t -#if MIN_VERSION_base(4, 9, 0) -- | Modify the given column by the given function.-#endif Modify :: Selector t a -> (Col s a -> Col s a) -> Assignment s t infixl 2 :=
− src/Database/Selda/Selectors/FieldSelectors.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE DataKinds, KindSignatures, TypeOperators, PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-}-{-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-}-{-# LANGUAGE TypeApplications, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Create Selda selectors from plain record field selectors.--- Requires the @OverloadedLabels@ language extension.-module Database.Selda.Selectors.FieldSelectors- (FieldType, HasField, IsLabel- ) where-import Database.Selda.Generic (Relational)-import Database.Selda.Selectors as S-import Database.Selda.SqlType (SqlType)-import Data.Kind (Constraint)-import GHC.Generics-import GHC.TypeLits-import GHC.OverloadedLabels---- | Get the next nested type.-type family GetFieldType (f :: * -> *) :: * where- GetFieldType (M1 c i f) = GetFieldType f- GetFieldType (K1 i a) = a---- | Get the type of the field @name@ from the generic representation @a@,--- returning the default value @b@ if the field does not exist.-type family GFieldType (a :: * -> *) (b :: *) (name :: Symbol) :: * where- GFieldType (M1 S ('MetaSel ('Just name) su ss ds) f) b name = GetFieldType f- GFieldType (M1 c i a) b name = GFieldType a b name- GFieldType (a :*: b) c name = GFieldType a (GFieldType b c name) name- GFieldType a b name = b---- | The type of the @name@ field, in the record type @t@.-type FieldType name t = GFieldType (Rep t) (NoSuchSelector t name) name--type family NonError (t :: k) :: Constraint where- NonError (NoSuchSelector t s) = TypeError- ( 'Text "Row type '" ':<>: 'ShowType t ':<>:- 'Text "' has no selector " ':<>: 'ShowType s ':<>: 'Text "."- )- NonError t = ()---- | Internal representation of the "no such selector" error message.-data NoSuchSelector (t :: *) (s :: Symbol)---- | Any table type @t@, which has a field named @name@.-class ( Relational t- , SqlType (FieldType name t)- , GRSel name (Rep t)- , NonError (FieldType name t)) =>- HasField (name :: Symbol) t--instance ( Relational t- , SqlType (FieldType name t)- , GRSel name (Rep t)- , NonError (FieldType name t)) =>- HasField (name :: Symbol) t--instance (Relational t, HasField name t, FieldType name t ~ a) =>- IsLabel name (S.Selector t a) where-#if MIN_VERSION_base(4, 10, 0)- fromLabel = field @name @t-#else- fromLabel _ = field @name @t-#endif---- | Create a selector from a record selector and a type application.------ For example:--- > data Foo = Foo--- > { foo :: Int--- > , bar :: Text--- > } deriving Generic--- > instance SqlRow Foo--- >--- > fooTable :: Table Foo--- > fooTable = table "foo"--- >--- > getAllBars :: Query s (Col s Text)--- > getAllBars = do--- > t <- select fooTable--- > return (t ! field @"bar")-field :: forall name t.- (Relational t, HasField name t)- => S.Selector t (FieldType name t)-field =- case gSel @name @(Rep t) 0 of- Left n -> unsafeSelector n- _ -> error "unreachable"--class GRSel (s :: Symbol) (f :: * -> *) where- gSel :: Int -> Either Int Int--instance GRSel name (M1 S ('MetaSel ('Just name) su ss ds) f) where- gSel = Left--instance {-# OVERLAPPABLE #-} GRSel name f => GRSel name (M1 i s f) where- gSel = gSel @name @f--instance (GRSel name a, GRSel name b) => GRSel name (a :*: b) where- gSel n = gSel @name @a n >>= gSel @name @b . succ--instance GRSel name (K1 i a) where- gSel = Right
− src/Database/Selda/Selectors/MakeSelectors.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, TypeOperators, KindSignatures #-}-{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}--- | Utilities for creating selectors for non-record types.--- Importing this module may significantly increase compilation times.-module Database.Selda.Selectors.MakeSelectors- ( Selectors, GSelectors- , selectors, tableWithSelectors- ) where-import Control.Monad.State.Strict-import Data.Proxy-import GHC.Generics hiding (Selector, (:*:))-import qualified GHC.Generics as G-import Database.Selda.Generic (Relational)-import Database.Selda.Selectors-import Database.Selda.SqlRow-import Database.Selda.SqlType-import Database.Selda.Table-import Database.Selda.Types---- | Generate selector functions for the given table.--- Selectors can be used to access the fields of a query result tuple, avoiding--- the need to pattern match on the entire tuple.------ > tbl :: Table (Int, Text)--- > tbl = table "foo" []--- > (tblBar :*: tblBaz) = selectors tbl--- >--- > q :: Query s Text--- > q = do--- > row <- select tbl--- > return (row ! tblBaz)-selectors :: forall a. (Relational a, GSelectors a (Rep a))- => Table a- -> Selectors a-selectors _ = selectorsFor (Proxy :: Proxy a)---- | A pair of the table with the given name and columns, and all its selectors.--- For example:------ > tbl :: Table (Int, Text)--- > (tbl, tblBar :*: tblBaz)--- > = tableWithSelectors "foo" []--- >--- > q :: Query s Text--- > q = tblBaz `from` select tbl-tableWithSelectors :: forall a. (Relational a, GSelectors a (Rep a))- => TableName- -> [Attr a]- -> (Table a, Selectors a)-tableWithSelectors name cs = (t, s)- where- t = table name cs- s = selectors t---- | Generate selectors for the given type.-selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r-selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r))---- | An inductive tuple of selectors for the given relation.-type Selectors r = Sels r (Rep r)--type family Sels t f where- Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))- Sels t (a G.:*: b) = Sels t a :*: Sels t b- Sels t (M1 x y f) = Sels t f- Sels t (K1 i a) = Selector t a---- | Any table type that can have selectors generated.-class GSelectors t (f :: * -> *) where- mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)--instance (SqlRow t, SqlType a) => GSelectors t (K1 i a) where- mkSel _ _ = unsafeSelector <$> state (\n -> (n, n+1))--instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>- GSelectors t (M1 x y f) where- mkSel _ = mkSel (Proxy :: Proxy f)--instance GSelectors t (a G.:*: (b G.:*: c)) =>- GSelectors t ((a G.:*: b) G.:*: c) where- mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c)))--instance {-# OVERLAPPABLE #-}- ( GSelectors t a- , GSelectors t b- , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)- ) => GSelectors t (a G.:*: b) where- mkSel _ p = do- x <- mkSel (Proxy :: Proxy a) p- xs <- mkSel (Proxy :: Proxy b) p- return (x :*: xs)
src/Database/Selda/SqlRow.hs view
@@ -12,9 +12,7 @@ import Database.Selda.SqlType import Data.Typeable import GHC.Generics-#if MIN_VERSION_base(4, 9, 0) import qualified GHC.TypeLits as TL-#endif newtype ResultReader a = R (State [SqlValue] a) deriving (Functor, Applicative, Monad)@@ -54,7 +52,6 @@ gNextResult = liftM2 (:*:) gNextResult gNextResult gNestedCols _ = gNestedCols (Proxy :: Proxy a) + gNestedCols (Proxy :: Proxy b) -#if MIN_VERSION_base(4, 9, 0) instance (TL.TypeError ( 'TL.Text "Selda currently does not support creating tables from sum types."@@ -63,7 +60,6 @@ )) => GSqlRow (a :+: b) where gNextResult = error "unreachable" gNestedCols = error "unreachable"-#endif -- * Various instances instance SqlRow a => SqlRow (Maybe a) where
src/Database/Selda/SqlType.hs view
@@ -3,33 +3,39 @@ -- | Types representable as columns in Selda's subset of SQL. module Database.Selda.SqlType ( SqlType (..), SqlEnum (..)- , Lit (..), RowID, ID, SqlValue (..), SqlTypeRep (..)+ , Lit (..), UUID, RowID, ID, SqlValue (..), SqlTypeRep (..) , invalidRowId, isInvalidRowId, toRowId, fromRowId , fromId, toId, invalidId, isInvalidId, untyped , compLit, litType , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat ) where+import Control.Applicative ((<|>)) import Data.ByteString (ByteString, empty) import qualified Data.ByteString.Lazy as BSL+import Data.Maybe (fromJust) import Data.Proxy import Data.Text (Text, pack, unpack) import Data.Time import Data.Typeable+import Data.UUID.Types (UUID, toString, fromByteString, nil) -- | Format string used to represent date and time when--- talking to the database backend.+-- representing timestamps as text.+-- If at all possible, use 'SqlUTCTime' instead. sqlDateTimeFormat :: String-sqlDateTimeFormat = "%F %H:%M:%S%Q"+sqlDateTimeFormat = "%F %H:%M:%S%Q%z" -- | Format string used to represent date when--- talking to the database backend.+-- representing dates as text.+-- If at all possible, use 'SqlDate' instead. sqlDateFormat :: String sqlDateFormat = "%F" -- | Format string used to represent time of day when--- talking to the database backend.+-- representing time as text.+-- If at all possible, use 'SqlTime' instead. sqlTimeFormat :: String-sqlTimeFormat = "%H:%M:%S%Q"+sqlTimeFormat = "%H:%M:%S%Q%z" -- | Representation of an SQL type. data SqlTypeRep@@ -42,6 +48,8 @@ | TDate | TTime | TBlob+ | TUUID+ | TJSON deriving (Show, Eq, Ord) -- | Any datatype representable in (Selda's subset of) SQL.@@ -49,7 +57,7 @@ -- | Create a literal of this type. mkLit :: a -> Lit a default mkLit :: (Typeable a, SqlEnum a) => a -> Lit a- mkLit = LCustom . LText . toText+ mkLit = LCustom TText . LText . toText -- | The SQL representation for this type. sqlType :: Proxy a -> SqlTypeRep@@ -63,7 +71,7 @@ -- | Default value when using 'def' at this type. defaultValue :: Lit a default defaultValue :: (Typeable a, SqlEnum a) => Lit a- defaultValue = LCustom $ mkLit (toText (minBound :: a))+ defaultValue = mkLit (minBound :: a) -- | Any type that's bounded, enumerable and has a text representation, and -- thus representable as a Selda enumerable.@@ -88,13 +96,14 @@ LInt :: !Int -> Lit Int LDouble :: !Double -> Lit Double LBool :: !Bool -> Lit Bool- LDateTime :: !Text -> Lit UTCTime- LDate :: !Text -> Lit Day- LTime :: !Text -> Lit TimeOfDay+ LDateTime :: !UTCTime -> Lit UTCTime+ LDate :: !Day -> Lit Day+ LTime :: !TimeOfDay -> Lit TimeOfDay LJust :: SqlType a => !(Lit a) -> Lit (Maybe a) LBlob :: !ByteString -> Lit ByteString LNull :: SqlType a => Lit (Maybe a)- LCustom :: Lit a -> Lit b+ LCustom :: SqlTypeRep -> Lit a -> Lit b+ LUUID :: !UUID -> Lit UUID -- | The SQL type representation for the given literal. litType :: Lit a -> SqlTypeRep@@ -111,7 +120,8 @@ where proxyFor :: Lit (Maybe a) -> Proxy a proxyFor _ = Proxy-litType (LCustom x) = litType x+litType (LCustom t _) = t+litType (LUUID{}) = TUUID instance Eq (Lit a) where a == b = compLit a b == EQ@@ -132,6 +142,7 @@ litConTag (LBlob{}) = 8 litConTag (LNull) = 9 litConTag (LCustom{}) = 10+litConTag (LUUID{}) = 11 -- | Compare two literals of different type for equality. compLit :: Lit a -> Lit b -> Ordering@@ -144,25 +155,32 @@ compLit (LTime x) (LTime x') = x `compare` x' compLit (LBlob x) (LBlob x') = x `compare` x' compLit (LJust x) (LJust x') = x `compLit` x'-compLit (LCustom x) (LCustom x') = x `compLit` x'+compLit (LCustom _ x) (LCustom _ x') = x `compLit` x'+compLit (LUUID x) (LUUID x') = x `compare` x' compLit a b = litConTag a `compare` litConTag b -- | Some value that is representable in SQL. data SqlValue where- SqlInt :: !Int -> SqlValue- SqlFloat :: !Double -> SqlValue- SqlString :: !Text -> SqlValue- SqlBool :: !Bool -> SqlValue- SqlBlob :: !ByteString -> SqlValue- SqlNull :: SqlValue+ SqlInt :: !Int -> SqlValue+ SqlFloat :: !Double -> SqlValue+ SqlString :: !Text -> SqlValue+ SqlBool :: !Bool -> SqlValue+ SqlBlob :: !ByteString -> SqlValue+ SqlUTCTime :: !UTCTime -> SqlValue+ SqlTime :: !TimeOfDay -> SqlValue+ SqlDate :: !Day -> SqlValue+ SqlNull :: SqlValue instance Show SqlValue where- show (SqlInt n) = "SqlInt " ++ show n- show (SqlFloat f) = "SqlFloat " ++ show f- show (SqlString s) = "SqlString " ++ show s- show (SqlBool b) = "SqlBool " ++ show b- show (SqlBlob b) = "SqlBlob " ++ show b- show (SqlNull) = "SqlNull"+ show (SqlInt n) = "SqlInt " ++ show n+ show (SqlFloat f) = "SqlFloat " ++ show f+ show (SqlString s) = "SqlString " ++ show s+ show (SqlBool b) = "SqlBool " ++ show b+ show (SqlBlob b) = "SqlBlob " ++ show b+ show (SqlUTCTime t) = "SqlUTCTime " ++ show t+ show (SqlTime t) = "SqlTime " ++ show t+ show (SqlDate d) = "SqlDate " ++ show d+ show (SqlNull) = "SqlNull" instance Show (Lit a) where show (LText s) = show s@@ -175,7 +193,8 @@ show (LBlob b) = show b show (LJust x) = "Just " ++ show x show (LNull) = "Nothing"- show (LCustom l) = show l+ show (LCustom _ l) = show l+ show (LUUID u) = toString u -- | A row identifier for some table. -- This is the type of auto-incrementing primary keys.@@ -233,14 +252,14 @@ isInvalidId = isInvalidRowId . untyped instance SqlType RowID where- mkLit (RowID n) = LCustom $ LInt n+ mkLit (RowID n) = LCustom TRowID (LInt n) sqlType _ = TRowID fromSql (SqlInt x) = RowID x fromSql v = error $ "fromSql: RowID column with non-int value: " ++ show v defaultValue = mkLit invalidRowId instance Typeable a => SqlType (ID a) where- mkLit (ID n) = LCustom $ mkLit n+ mkLit (ID n) = LCustom TRowID (mkLit n) sqlType _ = TRowID fromSql = ID . fromSql defaultValue = mkLit (ID invalidRowId)@@ -276,35 +295,47 @@ defaultValue = LBool False instance SqlType UTCTime where- mkLit = LDateTime . pack . formatTime defaultTimeLocale sqlDateTimeFormat- sqlType _ = TDateTime+ mkLit = LDateTime+ sqlType _ = TDateTime+ fromSql (SqlUTCTime t) = t fromSql (SqlString s) =- case parseTimeM True defaultTimeLocale sqlDateTimeFormat (unpack s) of+ case withWeirdTimeZone sqlDateTimeFormat (unpack s) of Just t -> t _ -> error $ "fromSql: bad datetime string: " ++ unpack s- fromSql v = error $ "fromSql: datetime column with non-datetime value: " ++ show v- defaultValue = LDateTime "1970-01-01 00:00:00"+ fromSql v = error $ "fromSql: datetime column with non-datetime value: " ++ show v+ defaultValue = LDateTime $ UTCTime (ModifiedJulianDay 40587) 0 instance SqlType Day where- mkLit = LDate . pack . formatTime defaultTimeLocale sqlDateFormat- sqlType _ = TDate+ mkLit = LDate+ sqlType _ = TDate+ fromSql (SqlDate d) = d fromSql (SqlString s) = case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of Just t -> t _ -> error $ "fromSql: bad date string: " ++ unpack s- fromSql v = error $ "fromSql: date column with non-date value: " ++ show v- defaultValue = LDate "1970-01-01"+ fromSql v = error $ "fromSql: date column with non-date value: " ++ show v+ defaultValue = LDate $ ModifiedJulianDay 40587 instance SqlType TimeOfDay where- mkLit = LTime . pack . formatTime defaultTimeLocale sqlTimeFormat- sqlType _ = TTime+ mkLit = LTime+ sqlType _ = TTime+ fromSql (SqlTime s) = s fromSql (SqlString s) =- case parseTimeM True defaultTimeLocale sqlTimeFormat (unpack s) of+ case withWeirdTimeZone sqlTimeFormat (unpack s) of Just t -> t _ -> error $ "fromSql: bad time string: " ++ unpack s- fromSql v = error $ "fromSql: time column with non-time value: " ++ show v- defaultValue = LTime "00:00:00"+ fromSql v = error $ "fromSql: time column with non-time value: " ++ show v+ defaultValue = LTime $ TimeOfDay 0 0 0 +-- | Both PostgreSQL and SQLite to weird things with time zones.+-- Long term solution is to use proper binary types internally for+-- time values, so this is really just an interim solution.+withWeirdTimeZone :: ParseTime t => String -> String -> Maybe t+withWeirdTimeZone fmt s =+ parseTimeM True defaultTimeLocale fmt (s++"00")+ <|> parseTimeM True defaultTimeLocale fmt s+ <|> parseTimeM True defaultTimeLocale fmt (s++"+0000")+ instance SqlType ByteString where mkLit = LBlob sqlType _ = TBlob@@ -313,11 +344,19 @@ defaultValue = LBlob empty instance SqlType BSL.ByteString where- mkLit = LCustom . LBlob . BSL.toStrict+ mkLit = LCustom TBlob . LBlob . BSL.toStrict sqlType _ = TBlob fromSql (SqlBlob x) = BSL.fromStrict x fromSql v = error $ "fromSql: blob column with non-blob value: " ++ show v- defaultValue = LCustom $ LBlob empty+ defaultValue = LCustom TBlob (LBlob empty)++-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID.+instance SqlType UUID where+ mkLit = LUUID+ sqlType _ = TUUID+ fromSql (SqlBlob x) = fromJust . fromByteString $ BSL.fromStrict x+ fromSql v = error $ "fromSql: UUID column with non-blob value: " ++ show v+ defaultValue = LUUID nil instance SqlType a => SqlType (Maybe a) where mkLit (Just x) = LJust $ mkLit x
src/Database/Selda/Table.hs view
@@ -2,21 +2,28 @@ {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}-{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-}+{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds, MagicHash #-}+#if MIN_VERSION_base(4, 10, 0)+{-# LANGUAGE TypeApplications #-}+#endif module Database.Selda.Table- ( Attr (..), Table (..), Attribute- , ColInfo (..), ColAttr (..), IndexMethod (..)+ ( SelectorLike, Group (..), Attr (..), Table (..), Attribute+ , ColInfo (..), AutoIncType (..), ColAttr (..), IndexMethod (..) , ForeignKey (..)- , table, tableFieldMod -- , tableWithSelectors, selectors- , primary, autoPrimary, untypedAutoPrimary, unique+ , table, tableFieldMod+ , primary, autoPrimary, weakAutoPrimary+ , untypedAutoPrimary, weakUntypedAutoPrimary+ , unique , index, indexUsing- , tableExpr+ , tableExpr, indexedCols+ , isAutoPrimary, isPrimary, isUnique ) where import Data.Text (Text) #if MIN_VERSION_base(4, 10, 0) import Data.Typeable #else import Data.Proxy+import GHC.Prim #endif import Database.Selda.Types import Database.Selda.Selectors@@ -25,12 +32,30 @@ import Database.Selda.Generic import Database.Selda.Table.Type import Database.Selda.Table.Validation (snub)+import GHC.OverloadedLabels +instance forall x t a. IsLabel x (Selector t a) => IsLabel x (Group t a) where+#if MIN_VERSION_base(4, 10, 0)+ fromLabel = Single (fromLabel @x)+#else+ fromLabel _ = Single (fromLabel (proxy# :: Proxy# x))+#endif++-- | A non-empty list of selectors, where the element selectors need not have+-- the same type. Used to specify constraints, such as uniqueness or primary+-- key, potentially spanning multiple columns.+data Group t a where+ (:+) :: Selector t a -> Group t b -> Group t (a :*: b)+ Single :: Selector t a -> Group t a+infixr 1 :++ -- | A generic column attribute. -- Essentially a pair or a record selector over the type @a@ and a column--- attribute.+-- attribute. An attribute may be either a 'Group' attribute, meaning that+-- it can span multiple columns, or a 'Selector' -- single column -- attribute. data Attr a where- (:-) :: Selector a b -> Attribute a b -> Attr a+ (:-) :: SelectorLike g => g t a -> Attribute g t a -> Attr t+infixl 0 :- -- | Generate a table from the given table name and list of column attributes. -- All @Maybe@ fields in the table's type will be represented by nullable@@ -47,8 +72,7 @@ -- > deriving Generic -- > -- > people :: Table Person--- > people = table "people" [pId :- autoPrimary]--- > pId :*: pName :*: pAge :*: pPet = selectors people+-- > people = table "people" [#id :- autoPrimary] -- -- This will result in a table of @Person@s, with an auto-incrementing primary -- key.@@ -75,7 +99,9 @@ -- > deriving Generic -- > -- > people :: Table Person--- > people = tableFieldMod "people" [personName :- autoPrimaryGen] (stripPrefix "person")+-- > people = tableFieldMod "people"+-- > [#personName :- autoPrimaryGen]+-- > (fromJust . stripPrefix "person") -- -- This will create a table with the columns named -- @Id@, @Name@, @Age@ and @Pet@.@@ -88,65 +114,107 @@ { tableName = tn , tableCols = map tidy cols , tableHasAutoPK = apk+ , tableAttrs = concat [combinedAttrs, pkAttrs] } where+ combinedAttrs =+ [ (ixs, a)+ | sel :- Attribute [a] <- attrs+ , let ixs = indices sel+ , case ixs of+ (_:_:_) -> True+ [_] | a == Unique -> True+ _ -> False+ ]+ pkAttrs = concat+ [ [(ixs, Primary), (ixs, Required)]+ | sel :- Attribute [Primary,Required] <- attrs+ , let ixs = indices sel+ ] cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a) fieldMod)- apk = or [AutoIncrement `elem` as | _ :- Attribute as <- attrs]+ apk = or [any isAutoPrimary as | _ :- Attribute as <- attrs] addAttrs n ci = ci { colAttrs = colAttrs ci ++ concat [ as | sel :- Attribute as <- attrs- , selectorIndex sel == n+ , case indices sel of+ [colIx] -> colIx == n+ _ -> False ] , colFKs = colFKs ci ++ [ thefk | sel :- ForeignKey thefk <- attrs- , selectorIndex sel == n+ , case indices sel of+ [colIx] -> colIx == n+ _ -> False ] } +class SelectorLike g where+ indices :: g t a -> [Int]++instance SelectorLike Selector where+ indices s = [selectorIndex s]+instance SelectorLike Group where+ indices (s :+ ss) = selectorIndex s : indices ss+ indices (Single s) = [selectorIndex s]+ -- | Remove duplicate attributes. tidy :: ColInfo -> ColInfo tidy ci = ci {colAttrs = snub $ colAttrs ci} -- | Some attribute that may be set on a column of type @c@, in a table of -- type @t@.-data Attribute t c+data Attribute (g :: * -> * -> *) t c = Attribute [ColAttr] | ForeignKey (Table (), ColName) -- | A primary key which does not auto-increment.-primary :: Attribute t c-primary = Attribute [Primary, Required, Unique]+primary :: Attribute Group t a+primary = Attribute [Primary, Required] -- | Create an index on this column.-index :: Attribute t c+index :: Attribute Selector t c index = Attribute [Indexed Nothing] -- | Create an index using the given index method on this column.-indexUsing :: IndexMethod -> Attribute t c+indexUsing :: IndexMethod -> Attribute Selector t c indexUsing m = Attribute [Indexed (Just m)] -- | An auto-incrementing primary key.-autoPrimary :: Attribute t (ID t)-autoPrimary = Attribute [Primary, AutoIncrement, Required, Unique]+autoPrimary :: Attribute Selector t (ID t)+autoPrimary = Attribute [AutoPrimary Strong, Required] +-- | A "weakly auto-incrementing" primary key.+-- Behaves like 'autoPrimary', but the sequence of generated keys is not+-- guaranteed to be monotonically increasing.+--+-- This gives better performance on some backends, but means that+-- the relation @a > b <=> a was inserted at a later point in time than b@+-- does not hold.+weakAutoPrimary :: Attribute Selector t (ID t)+weakAutoPrimary = Attribute [AutoPrimary Weak, Required]+ -- | An untyped auto-incrementing primary key. -- You should really only use this for ad hoc tables, such as tuples.-untypedAutoPrimary :: Attribute t RowID-untypedAutoPrimary = Attribute [Primary, AutoIncrement, Required, Unique]+untypedAutoPrimary :: Attribute Selector t RowID+untypedAutoPrimary = Attribute [AutoPrimary Strong, Required] +-- | Like 'weakAutoPrimary', but for untyped IDs.+weakUntypedAutoPrimary :: Attribute Selector t RowID+weakUntypedAutoPrimary = Attribute [AutoPrimary Weak, Required]+ -- | A table-unique value.-unique :: Attribute t c+unique :: Attribute Group t a unique = Attribute [Unique] -mkFK :: Table t -> Selector a b -> Attribute c d-mkFK (Table tn tcs tapk) sel =- ForeignKey (Table tn tcs tapk, colName (tcs !! selectorIndex sel))+mkFK :: Table t -> Selector a b -> Attribute Selector c d+mkFK (Table tn tcs tapk tas) sel =+ ForeignKey (Table tn tcs tapk tas, colName (tcs !! selectorIndex sel)) class ForeignKey a b where -- | A foreign key constraint referencing the given table and column.- foreignKey :: Table t -> Selector t a -> Attribute self b+ foreignKey :: Table t -> Selector t a -> Attribute Selector self b instance ForeignKey a a where foreignKey = mkFK
src/Database/Selda/Table/Compile.hs view
@@ -3,7 +3,7 @@ module Database.Selda.Table.Compile where import Database.Selda.Table import Database.Selda.Table.Validation-import Data.List ((\\), foldl')+import Data.List (foldl') #if !MIN_VERSION_base(4, 11, 0) import Data.Monoid #endif@@ -19,44 +19,64 @@ -- | Compile a sequence of queries to create the given table, including indexes. -- The first query in the sequence is always @CREATE TABLE@.-compileCreateTable :: PPConfig -> OnError -> Table a -> [Text]+compileCreateTable :: PPConfig -> OnError -> Table a -> Text compileCreateTable cfg ifex tbl =- ensureValid `seq` (createTable : createIndexes)+ ensureValid `seq` createTable where createTable = mconcat [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("- , intercalate ", " (map (compileTableCol cfg) (tableCols tbl))+ , intercalate ", " (map (compileTableCol cfg) (tableCols tbl) ++ multiUniques ++ multiPrimary) , case allFKs of [] -> "" _ -> ", " <> intercalate ", " compFKs , ")" ]- createIndexes =- [ compileCreateIndex cfg (tableName tbl) (colName col) mmethod- | col <- tableCols tbl- , Indexed mmethod <- colAttrs col+ multiPrimary =+ [ mconcat ["PRIMARY KEY(", intercalate ", " (colNames ixs), ")"]+ | (ixs, Primary) <- tableAttrs tbl ]+ multiUniques =+ [ mconcat ["UNIQUE(", intercalate ", " (colNames ixs), ")"]+ | (ixs, Unique) <- tableAttrs tbl+ ]+ colNames ixs = [fromColName (colName (tableCols tbl !! ix)) | ix <- ixs] ifNotExists Fail = "" ifNotExists Ignore = "IF NOT EXISTS " allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci] compFKs = zipWith (uncurry compileFK) allFKs [0..] ensureValid = validateOrThrow (tableName tbl) (tableCols tbl) +-- | Compile the @CREATE INDEX@ queries for all indexes on the given table.+compileCreateIndexes :: PPConfig -> OnError -> Table a -> [Text]+compileCreateIndexes cfg ifex tbl =+ [ compileCreateIndex cfg ifex (tableName tbl) col mmethod+ | (col, mmethod) <- indexedCols tbl+ ]++-- | Get the name to use for an index on the given column in the given table.+indexNameFor :: TableName -> ColName -> Text+indexNameFor t c =+ fromColName $ addColPrefix c ("ix" <> rawTableName t <> "_")+ -- | Compile a @CREATE INDEX@ query for the given index.-compileCreateIndex :: PPConfig -> TableName -> ColName -> Maybe IndexMethod -> Text-compileCreateIndex cfg tbl col mmethod = mconcat- [ "CREATE INDEX "- , fromColName $ addColPrefix col ("ix" <> rawTableName tbl <> "_")- , " ON ", fromTableName tbl+compileCreateIndex :: PPConfig+ -> OnError+ -> TableName+ -> ColName+ -> Maybe IndexMethod+ -> Text+compileCreateIndex cfg ifex tbl col mmethod = mconcat+ [ "CREATE INDEX ", indexNameFor tbl col, " ON ", fromTableName tbl , case mmethod of Just method -> " " <> ppIndexMethodHook cfg method _ -> "" , " (", fromColName col, ")"+ , if ifex == Ignore then " IF NOT EXISTS" else "" ] -- | Compile a foreign key constraint. compileFK :: ColName -> (Table (), ColName) -> Int -> Text-compileFK col (Table ftbl _ _, fcol) n = mconcat+compileFK col (Table ftbl _ _ _, fcol) n = mconcat [ "CONSTRAINT ", fkName, " FOREIGN KEY (", fromColName col, ") " , "REFERENCES ", fromTableName ftbl, "(", fromColName fcol, ")" ]@@ -75,9 +95,8 @@ cty = colType ci attrs = colAttrs ci ppType'- | cty == TRowID && [Primary, AutoIncrement] `areIn` attrs = ppTypePK+ | cty == TRowID && any isAutoPrimary attrs = ppTypePK | otherwise = ppType- areIn x y = null (x \\ y) -- | Compile a @DROP TABLE@ query. compileDropTable :: OnError -> Table a -> Text@@ -123,7 +142,7 @@ -- primary keys. mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param]) mkCol n (Left def) col ps- | AutoIncrement `elem` colAttrs col =+ | any isAutoPrimary (colAttrs col) = (n, ppAutoIncInsert cfg, ps) | otherwise = (n+1, pack ('$':show n), def:ps)
src/Database/Selda/Table/Type.hs view
@@ -18,8 +18,19 @@ -- | Does the given table have an auto-incrementing primary key? , tableHasAutoPK :: Bool++ -- | Attributes involving multiple columns.+ , tableAttrs :: [([Int], ColAttr)] } +-- | Get all table columns with an explicit index.+indexedCols :: Table a -> [(ColName, Maybe IndexMethod)]+indexedCols t =+ [ (colName col, mmethod)+ | col <- tableCols t+ , Indexed mmethod <- colAttrs col+ ]+ -- | A complete description of a database column. data ColInfo = ColInfo { colName :: ColName@@ -29,18 +40,35 @@ , colExpr :: UntypedCol SQL } +-- | Strongly or weakly auto-incrementing primary key?+data AutoIncType = Weak | Strong+ deriving (Show, Eq, Ord)+ -- | Column attributes such as nullability, auto increment, etc. -- When adding elements, make sure that they are added in the order -- required by SQL syntax, as this list is only sorted before being -- pretty-printed. data ColAttr = Primary- | AutoIncrement+ | AutoPrimary AutoIncType | Required | Optional | Unique | Indexed (Maybe IndexMethod) deriving (Show, Eq, Ord)++isAutoPrimary :: ColAttr -> Bool+isAutoPrimary (AutoPrimary _) = True+isAutoPrimary _ = False++isPrimary :: ColAttr -> Bool+isPrimary Primary = True+isPrimary attr = isAutoPrimary attr++isUnique :: ColAttr -> Bool+isUnique Unique = True+isUnique (Indexed _) = True+isUnique attr = isPrimary attr -- | Method to use for indexing with 'indexedUsing'. -- Index methods are ignored by the SQLite backend, as SQLite doesn't support
src/Database/Selda/Table/Validation.hs view
@@ -54,15 +54,15 @@ dupes = ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis] pkDupes =- ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]+ if moreThanOne pkAttrs then ["multiple primary keys"] else [] nonPkFks = [ "column is used as a foreign key, but is not primary or unique: " <> fromTableName ftn <> "." <> fromColName fcn | ci <- cis- , (Table ftn fcs _, fcn) <- colFKs ci+ , (Table ftn fcs _ _, fcn) <- colFKs ci , fc <- fcs , colName fc == fcn- , not (Unique `elem` colAttrs fc)+ , not $ Prelude.any isUnique (colAttrs fc) ] -- This should be impossible, but...@@ -71,6 +71,15 @@ <> " is both optional and required" | ci <- cis , Optional `elem` colAttrs ci && Required `elem` colAttrs ci+ ]++ moreThanOne [] = False+ moreThanOne [_] = False+ moreThanOne _ = True+ pkAttrs =+ [ attr+ | attr <- concatMap colAttrs cis+ , isPrimary attr ] -- | Return all columns of the given table if the table schema is valid,
src/Database/Selda/Types.hs view
@@ -6,7 +6,7 @@ -- | Basic Selda types. module Database.Selda.Types ( (:*:)(..), Head, Tup (..)- , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth+ , first, second, third, fourth, fifth , ColName, TableName , modColName, mkColName, mkTableName, addColSuffix, addColPrefix , fromColName, fromTableName, rawTableName@@ -16,13 +16,6 @@ import Data.Text (Text, replace, append) import GHC.Generics (Generic) -#ifndef NO_LOCALCACHE-import Data.Hashable--instance Hashable TableName where- hashWithSalt s (TableName tn) = hashWithSalt s tn-#endif- -- | Name of a database column. newtype ColName = ColName Text deriving (Ord, Eq, Show, IsString)@@ -117,24 +110,3 @@ -- | Get the fifth element of an inductive tuple. fifth :: Tup e => (a :*: b :*: c :*: d :*: e) -> Head e fifth (_ :*: _ :*: _ :*: _ :*: e) = tupHead e---- | Get the sixth element of an inductive tuple.-sixth :: Tup f => (a :*: b :*: c :*: d :*: e :*: f) -> Head f-sixth (_ :*: _ :*: _ :*: _ :*: _ :*: f) = tupHead f---- | Get the seventh element of an inductive tuple.-seventh :: Tup g => (a :*: b :*: c :*: d :*: e :*: f :*: g) -> Head g-seventh (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: g) = tupHead g---- | Get the eighth element of an inductive tuple.-eighth :: Tup h => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h) -> Head h-eighth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: h) = tupHead h---- | Get the ninth element of an inductive tuple.-ninth :: Tup i => (a :*: b :*: c :*: d :*: e :*: f :*: h :*: h :*: i) -> Head i-ninth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: i) = tupHead i---- | Get the tenth element of an inductive tuple.-tenth :: Tup j => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j)- -> Head j-tenth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: j) = tupHead j
src/Database/Selda/Unsafe.hs view
@@ -2,18 +2,18 @@ -- | Unsafe operations giving the user unchecked low-level control over -- the generated SQL. module Database.Selda.Unsafe- ( fun, fun2, fun0+ ( fun, fun2, fun0, operator , aggr- , cast- , castAggr+ , cast, castAggr, sink, sink2 , unsafeSelector ) where import Database.Selda.Column-import Database.Selda.Inner (Aggr, aggr, liftAggr)+import Database.Selda.Inner (Inner, Aggr, aggr, liftAggr) import Database.Selda.Selectors (unsafeSelector) import Database.Selda.SqlType import Data.Text (Text) import Data.Proxy+import Unsafe.Coerce -- | Cast a column to another type, using whichever coercion semantics are used -- by the underlying SQL implementation.@@ -25,16 +25,46 @@ castAggr :: forall s a b. SqlType b => Aggr s a -> Aggr s b castAggr = liftAggr cast +-- | Sink the given function into an inner scope.+--+-- Be careful not to use this function with functions capturing rows or columns+-- from an outer scope. For instance, the following usage will likely+-- lead to disaster:+--+-- > query $ do+-- > x <- #age `from` select person+-- > inner $ sink (\p -> x + (p ! #age)) <$> select person+--+-- Really, if you have to use this function, ONLY do so in the global scope.+sink :: (f s a -> f s b) -> f (Inner s) a -> f (Inner s) b+sink = unsafeCoerce++-- | Like 'sink', but with two arguments.+sink2 :: (f s a -> f s b -> f s c) -> f (Inner s) a -> f (Inner s) b -> f (Inner s) c+sink2 = unsafeCoerce+ -- | A unary operation. Note that the provided function name is spliced -- directly into the resulting SQL query. Thus, this function should ONLY -- be used to implement well-defined functions that are missing from Selda's -- standard library, and NOT in an ad hoc manner during queries. fun :: Text -> Col s a -> Col s b-fun f = liftC $ UnOp (Fun f)+fun = liftC . UnOp . Fun -- | Like 'fun', but with two arguments. fun2 :: Text -> Col s a -> Col s b -> Col s c-fun2 f = liftC2 (Fun2 f)+fun2 = liftC2 . Fun2++-- | A custom operator. @operator "~>" a b@ will compile down to+-- @a ~> b@, with parentheses around @a@ and @b@ iff they are not atomic.+-- This means that SQL operator precedence is disregarded, as all+-- subexpressions are parenthesized. In the following example for instance,+-- @foo a b c@ will compile down to @(a ~> b) ~> c@.+--+-- > (~>) = operator "~>"+-- > infixl 5 ~>+-- > foo a b c = a ~> b ~> c+operator :: Text -> Col s a -> Col s b -> Col s c+operator = liftC2 . BinOp . CustomOp -- | Like 'fun', but with zero arguments. fun0 :: Text -> Col s a
src/Database/Selda/Validation.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}+{-# LANGUAGE OverloadedStrings, TupleSections, CPP #-} -- | Utilities for validating and inspecting Selda tables. module Database.Selda.Validation ( TableDiff (..), ColumnDiff (..)- , TableName, ColName, ColumnInfo, SqlTypeRep, columnInfo+ , TableName, ColName, ColumnInfo, SqlTypeRep, tableInfo , showTableDiff, showColumnDiff , describeTable, diffTable, diffTables , validateTable, validateSchema@@ -10,7 +10,10 @@ import Control.Monad.Catch import Data.List ((\\)) import Data.Maybe (catMaybes)-import Data.Text (pack, unpack)+#if !MIN_VERSION_base(4, 11, 0)+import Data.Monoid ((<>))+#endif+import Data.Text (pack, unpack, intercalate) import Database.Selda import Database.Selda.Backend import Database.Selda.Table.Type (tableName, tableCols)@@ -47,6 +50,10 @@ data TableDiff = TableOK | TableMissing+ | UniqueMissing [[ColName]]+ | UniquePresent [[ColName]]+ | PkMissing [ColName]+ | PkPresent [ColName] | InconsistentColumns [(ColName, [ColumnDiff])] deriving Eq instance Show TableDiff where@@ -60,14 +67,11 @@ | NameMismatch ColName | UnknownType Text | TypeMismatch SqlTypeRep SqlTypeRep- | PrimaryKeyMismatch Bool | AutoIncrementMismatch Bool | NullableMismatch Bool- | UniqueMismatch Bool | ForeignKeyMissing TableName ColName | ForeignKeyPresent TableName ColName- | IndexMissing- | IndexPresent+ | IndexMismatch Bool deriving Eq instance Show ColumnDiff where@@ -77,6 +81,32 @@ showTableDiff :: TableDiff -> Text showTableDiff TableOK = "no inconsistencies detected" showTableDiff TableMissing = "table does not exist"+showTableDiff (UniqueMissing cs) = mconcat+ [ "table should have uniqueness constraints on the following column groups, "+ , "but doesn't in database:\n"+ , intercalate ", "+ [ "(" <> intercalate ", " (map fromColName constraintGroup) <> ")"+ | constraintGroup <- cs+ ]+ ]+showTableDiff (UniquePresent cs) = mconcat+ [ "table shouldn't have uniqueness constraints on the following column groups, "+ , "but does in database:\n"+ , intercalate ", "+ [ "(" <> intercalate ", " (map fromColName constraintGroup) <> ")"+ | constraintGroup <- cs+ ]+ ]+showTableDiff (PkMissing cs) = mconcat+ [ "table should have a primary key constraint on the following column group, "+ , "but doesn't in database:\n"+ , "(" <> intercalate ", " (map fromColName cs) <> ")"+ ]+showTableDiff (PkPresent cs) = mconcat+ [ "table shouldn't have a primary key constraint group, "+ , "but does in database:\n"+ , "(" <> intercalate ", " (map fromColName cs) <> ")"+ ] showTableDiff (InconsistentColumns cols) = mconcat [ "table has inconsistent columns:\n" , mconcat (map showColDiffs cols)@@ -96,10 +126,6 @@ "column does not exist in database" showColumnDiff ColumnPresent = "column exists in database even though it shouldn't"-showColumnDiff IndexMissing =- "column does not have an index in the database, even though it should"-showColumnDiff IndexPresent =- "column has an index in the database, even though it shouldn't" showColumnDiff (NameMismatch n) = mconcat ["column is called ", fromColName n, " in database"] showColumnDiff (UnknownType t) =@@ -119,14 +145,12 @@ , fromColName col, " of table ", fromTableName tbl , ", in database, even though it shouldn't be" ]-showColumnDiff (PrimaryKeyMismatch dbval) =- showBoolDiff dbval "primary key" showColumnDiff (AutoIncrementMismatch dbval) = showBoolDiff dbval "auto-incrementing" showColumnDiff (NullableMismatch dbval) = showBoolDiff dbval "nullable"-showColumnDiff (UniqueMismatch dbval) =- showBoolDiff dbval "unique"+showColumnDiff (IndexMismatch dbval) =+ showBoolDiff dbval "indexed" showBoolDiff :: Bool -> Text -> Text showBoolDiff True what =@@ -135,10 +159,8 @@ mconcat ["column is not ", what, " in database, even though it should be"] -- | Get a description of the table by the given name currently in the database.-describeTable :: MonadSelda m => TableName -> m [ColumnInfo]-describeTable tbl = do- b <- seldaBackend- liftIO $ getTableInfo b tbl+describeTable :: MonadSelda m => TableName -> m TableInfo+describeTable tbl = withBackend (liftIO . flip getTableInfo tbl) -- | Check the given table for consistency with the current database, returning -- a description of all inconsistencies found.@@ -146,31 +168,45 @@ diffTable :: MonadSelda m => Table a -> m TableDiff diffTable tbl = do dbInfos <- describeTable (tableName tbl)- return $ diffColumns (columnInfo tbl) dbInfos+ return $ diffColumns (tableInfo tbl) dbInfos -- | Compute the difference between the two given tables. -- The first table is considered to be the schema, and the second the database. diffTables :: Table a -> Table b -> TableDiff-diffTables schema db = diffColumns (columnInfo schema) (columnInfo db)+diffTables schema db = diffColumns (tableInfo schema) (tableInfo db) -- | Compute the difference between the columns of two tables. -- The first table is considered to be the schema, and the second the database.-diffColumns :: [ColumnInfo] -> [ColumnInfo] -> TableDiff-diffColumns infos dbInfos =+diffColumns :: TableInfo -> TableInfo -> TableDiff+diffColumns inschema indb = case ( zipWith diffColumn infos dbInfos , map colName infos \\ map colName dbInfos- , map colName dbInfos \\ map colName infos) of- ([], _, _) ->+ , map colName dbInfos \\ map colName infos+ , tableUniqueGroups inschema \\ tableUniqueGroups indb+ , tableUniqueGroups indb \\ tableUniqueGroups inschema+ , tablePrimaryKey inschema \\ tablePrimaryKey indb+ , tablePrimaryKey indb \\ tablePrimaryKey inschema) of+ ([], _, _, _, _, _, _) -> TableMissing- (diffs, [], []) | all consistent diffs ->+ (diffs, [], [], [], [], [], []) | all consistent diffs -> TableOK- (diffs, missing, extras) ->+ (diffs, missing, extras, [], [], [], []) -> InconsistentColumns $ concat [ filter (not . consistent) diffs , map (, [ColumnMissing]) missing , map (, [ColumnPresent]) extras ]+ (_, _, _, schemaUniques, [], [], []) ->+ UniqueMissing schemaUniques+ (_, _, _, _, dbUniques, [], []) ->+ UniquePresent dbUniques+ (_, _, _, _, _, schemaPks, []) ->+ PkMissing schemaPks+ (_, _, _, _, _, _, dbPks) ->+ PkPresent dbPks where+ infos = tableColumnInfos inschema+ dbInfos = tableColumnInfos indb consistent (_, diffs) = null diffs diffColumn schema db = (colName schema, catMaybes ([ check colName NameMismatch@@ -181,10 +217,9 @@ Just (TypeMismatch schemaColType t) _ -> Nothing- , check colIsPK PrimaryKeyMismatch- , check colIsAutoIncrement AutoIncrementMismatch+ , check colIsAutoPrimary AutoIncrementMismatch , check colIsNullable NullableMismatch- , check colIsUnique UniqueMismatch+ , check colHasIndex IndexMismatch ] ++ mconcat [ map (Just . uncurry ForeignKeyPresent) (colFKs schema \\ colFKs db)