diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # GenericPersistence - A Haskell Persistence Layer using Generics +[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Actions Status](https://github.com/thma/generic-persistence/workflows/Haskell%20CI/badge.svg)](https://github.com/thma/generic-persistence/actions) [![codecov](https://codecov.io/gh/thma/generic-persistence/graph/badge.svg?token=DBCFLEA8JZ)](https://codecov.io/gh/thma/generic-persistence) [![Available on Hackage](https://img.shields.io/hackage/v/generic-persistence.svg?style=flat)](https://github.com/thma/generic-persistence) @@ -14,6 +15,7 @@ - [Status](#status) - [Available on Hackage](#available-on-hackage) - [Short demo](#short-demo) +- [Real world examples](#real-world-examples) - [Deal with runtime exceptions or use total functions? Your choice!](#deal-with-runtime-exceptions-or-use-total-functions-your-choice) - [Exceptions in the default API](#exceptions-in-the-default-api) - [Total functions in the safe API](#total-functions-in-the-safe-api) @@ -155,6 +157,31 @@ disconnect conn ``` +## Real world examples + +To learn how to use the library in more complex scenarios, I recommend looking at the following examples: + +### Building a REST service with Servant and GenericPersistence + +[This example](https://github.com/thma/servant-gp) shows how to use servant to build a REST API that provides CRUD operations for a medium-complex data model. +GenericPersistence is used to execute the CRUD operation against a SQLite database. +A Swagger UI is provided to interact with the API. + +### Building a REST service with Scotty and GenericPersistence +[This example](https://github.com/thma/scotty-gp-service) shows how to use Scotty to build a REST API that provides CRUD operations for a simple data model. +GenericPersistence is used to execute the CRUD operation against a SQLite database. +This example also demonstrate how a paging mechanism can be implemented with GenericPersistence. +The code also shows how to use GenericPersistence to manage BearerTokens for validating incoming requests. + +### The Elephantine library review + +The Elephantine library review provides a good overview of the different libraries available for working with PostgreSQL in Haskell. It also contains a section on *Generic-Persistence*: + +[How to use PostgreSQL with Haskell. Elephantine Library Review 2023](https://github.com/Zelenya/elephants#generic-persistence) + +In this review all libraries are compared by implementing the same real world application scenario with each library. The source code for *Generic-Persistence* can be found [here](https://github.com/Zelenya/elephants/blob/main/src/Elephants/GenericPersistence.hs). + + ## Deal with runtime exceptions or use total functions? Your choice! GenericPersistence provides two different APIs for accessing the database: @@ -454,18 +481,18 @@ fromRow :: Conn -> [SqlValue] -> IO Article fromRow conn row = do authorById <- fromJust <$> selectById conn (row !! 2) -- load author by foreign key - return $ rawArticle {author = authorById} -- add author to article + return $ rawArticle {author = authorById} -- add author to article where - rawArticle = Article (col 0) (col 1) -- create article from row, - (Author (col 2) "" "") (col 3) -- using a dummy author + rawArticle = Article (col 0) (col 1) -- create article from row, + (Author (col 2) "" "") (col 3) -- using a dummy author where col i = fromSql (row !! i) toRow :: Conn -> Article -> IO [SqlValue] toRow conn a = do - persist conn (author a) -- persist author first - return [toSql (articleID a), toSql (title a), -- return row for article table where - toSql $ authorID (author a), toSql (year a)] -- authorID is foreign key to author table + upsert conn (author a) -- persist author first + return [toSql (articleID a), toSql (title a), -- return row for article table where + toSql $ authorID (author a), toSql (year a)] -- authorID is foreign key to author table ``` Persisting the `Author`as a side effect in `toRow` may sound like an *interesting* idea... @@ -518,7 +545,7 @@ toRow :: Conn -> Author -> IO [SqlValue] toRow conn a = do - mapM_ (persist conn) (articles a) -- persist all articles of this author (update or insert) + mapM_ (upsert conn) (articles a) -- persist all articles of this author (update or insert) return [toSql (authorID a), -- return the author as a list of SqlValues toSql (name a), toSql (address a)] ``` @@ -683,3 +710,5 @@ You'll find a more complete example in the [servant-gp repo](https://github.com/thma/servant-gp/blob/main/src/ServerUtils.hs#L45). There I have set up a sample REST service based on Servant that uses *Generic-Persistence* and a connection pool to manage the database connections. + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/generic-persistence.cabal b/generic-persistence.cabal --- a/generic-persistence.cabal +++ b/generic-persistence.cabal @@ -1,12 +1,12 @@ cabal-version: 1.12 name: generic-persistence -version: 0.6.0 +version: 0.7.0.0 license: BSD3 license-file: LICENSE -copyright: 2023 Thomas Mahler +copyright: 2023,2024 Thomas Mahler maintainer: thma@apache.org author: Thomas Mahler -tested-with: ghc ==9.2.5 ghc ==9.4.4 +tested-with: ghc ==9.2 ghc ==9.4 ghc ==9.6 ghc ==9.8 homepage: https://github.com/thma/generic-persistence#readme bug-reports: https://github.com/thma/generic-persistence/issues synopsis: Database persistence using generics @@ -37,7 +37,7 @@ default-language: GHC2021 default-extensions: DuplicateRecordFields DeriveAnyClass DerivingStrategies - OverloadedRecordDot TemplateHaskell QuasiQuotes + OverloadedRecordDot TemplateHaskell QuasiQuotes LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates @@ -76,7 +76,7 @@ default-language: GHC2021 default-extensions: DuplicateRecordFields DeriveAnyClass DerivingStrategies - OverloadedRecordDot TemplateHaskell QuasiQuotes + OverloadedRecordDot TemplateHaskell QuasiQuotes LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates diff --git a/src/Database/GP.hs b/src/Database/GP.hs --- a/src/Database/GP.hs +++ b/src/Database/GP.hs @@ -1,19 +1,25 @@ module Database.GP ( selectById, select, + count, entitiesFromRows, sql, persist, + upsert, insert, insertMany, update, updateMany, delete, + deleteById, deleteMany, - setupTableFor, - Conn(..), + deleteManyById, + setupTable, + defaultSqliteMapping, + defaultPostgresMapping, + Conn (..), connect, - Database(..), + Database (..), TxHandling (..), ConnectionPool, createConnPool, @@ -25,7 +31,7 @@ maybeFieldTypeFor, TypeInfo (..), typeInfo, - PersistenceException(..), + PersistenceException (..), WhereClauseExpr, Field, field, @@ -49,7 +55,7 @@ SortOrder (..), limit, limitOffset, - NonEmpty(..), + NonEmpty (..), SqlValue, fromSql, toSql, @@ -59,12 +65,13 @@ rollback, withTransaction, runRaw, - disconnect + disconnect, ) where -- We are just re-exporting from the GenericPersistence module. import Database.GP.GenericPersistence -import Database.HDBC (SqlValue, fromSql, toSql, quickQuery, run, - commit, rollback, withTransaction, - IConnection(runRaw, disconnect)) +import Database.HDBC (IConnection (disconnect, runRaw), + SqlValue, commit, fromSql, + quickQuery, rollback, run, + toSql, withTransaction) diff --git a/src/Database/GP/Conn.hs b/src/Database/GP/Conn.hs --- a/src/Database/GP/Conn.hs +++ b/src/Database/GP/Conn.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} module Database.GP.Conn ( Conn (..), connect, @@ -27,24 +26,18 @@ -- This module also defines a ConnectionPool type, which provides basic connection pooling functionality. -- | A wrapper around an HDBC IConnection. -data Conn = forall conn. - IConnection conn => - Conn - { - -- | If True, the GenericPersistence functions will commit the transaction after each operation. - implicitCommit :: Bool, - -- | The wrapped connection - connection :: conn - } +data Conn = forall conn. IConnection conn => + Conn + Bool -- | If True, the GenericPersistence functions will commit the transaction after each operation. + conn -- | The wrapped HDBC IConnection -data TxHandling = AutoCommit | ExplicitCommit +data TxHandling = AutoCommit | ExplicitCommit -- | a smart constructor for the Conn type. -connect :: forall conn. IConnection conn => TxHandling -> conn -> Conn +connect :: forall conn. IConnection conn => TxHandling -> conn -> Conn connect = \case AutoCommit -> Conn True ExplicitCommit -> Conn False - -- | allows to execute a function that requires an `IConnection` argument on a `Conn`. withWConn :: forall b. Conn -> (forall conn. IConnection conn => conn -> b) -> b @@ -72,8 +65,9 @@ type ConnectionPool = Pool Conn -- | Creates a connection pool. -createConnPool :: IConnection conn => - -- | the transaction mode +createConnPool :: + IConnection conn => + -- | the transaction mode TxHandling -> -- | the connection string String -> diff --git a/src/Database/GP/Entity.hs b/src/Database/GP/Entity.hs --- a/src/Database/GP/Entity.hs +++ b/src/Database/GP/Entity.hs @@ -13,8 +13,8 @@ GToRow, GFromRow, maybeFieldTypeFor, - Conn(..), - TxHandling(..), + Conn (..), + TxHandling (..), maybeIdFieldIndex, fieldIndex, ) @@ -23,36 +23,32 @@ import Data.Char (toLower) import Data.Convertible import Data.Kind +import Data.List (elemIndex) import Data.Typeable (Proxy (..), TypeRep) +import Database.GP.Conn import Database.GP.TypeInfo import Database.HDBC (SqlValue) import GHC.Generics import GHC.TypeNats -import Database.GP.Conn -import Data.List (elemIndex) -{- | This is the Entity class. It is a type class that is used to define the mapping -between a Haskell product type in record notation and a database table. -The class has a default implementation for all methods. -The default implementation uses the type information to determine a simple 1:1 mapping. - -That means that -- the type name is used as the table name and the -- field names are used as the column names. -- A field named 'ID' is used as the primary key field. - -The default implementation can be overridden by defining a custom instance for a type. - -Please note the following constraints, which apply to all valid Entity type, -but that are not explicitely encoded in the type class definition: - -- The type must be a product type in record notation. -- The type must have exactly one constructor. -- There must be single primary key field, compund primary keys are not supported. - --} - - +-- | This is the Entity class. It is a type class that is used to define the mapping +-- between a Haskell product type in record notation and a database table. +-- The class has a default implementation for all methods. +-- The default implementation uses the type information to determine a simple 1:1 mapping. +-- +-- That means that +-- - the type name is used as the table name and the +-- - field names are used as the column names. +-- - A field named 'ID' is used as the primary key field. +-- +-- The default implementation can be overridden by defining a custom instance for a type. +-- +-- Please note the following constraints, which apply to all valid Entity type, +-- but that are not explicitely encoded in the type class definition: +-- +-- - The type must be a product type in record notation. +-- - The type must have exactly one constructor. +-- - There must be single primary key field, compound primary keys are not supported. class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where -- | Converts a database row to a value of type 'a'. fromRow :: Conn -> [SqlValue] -> IO a diff --git a/src/Database/GP/GenericPersistence.hs b/src/Database/GP/GenericPersistence.hs --- a/src/Database/GP/GenericPersistence.hs +++ b/src/Database/GP/GenericPersistence.hs @@ -1,20 +1,27 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + module Database.GP.GenericPersistence ( selectById, select, + count, entitiesFromRows, sql, persist, + upsert, insert, insertMany, update, updateMany, delete, + deleteById, deleteMany, - setupTableFor, - Conn(..), + deleteManyById, + setupTable, + defaultSqliteMapping, + defaultPostgresMapping, + Conn (..), connect, - Database(..), + Database (..), TxHandling (..), ConnectionPool, createConnPool, @@ -26,7 +33,7 @@ maybeFieldTypeFor, TypeInfo (..), typeInfo, - PersistenceException(..), + PersistenceException (..), WhereClauseExpr, Field, field, @@ -39,9 +46,9 @@ (<=.), (<>.), like, - --contains, + -- contains, between, - in', + in', isNull, not', sqlFun, @@ -51,16 +58,16 @@ SortOrder (..), limit, limitOffset, - NonEmpty(..) + NonEmpty (..), ) where import Control.Exception ---import Control.Monad (when) import Data.Convertible (Convertible) import Database.GP.Conn import Database.GP.Entity -import Database.GP.GenericPersistenceSafe (PersistenceException, sql, setupTableFor) +import Database.GP.GenericPersistenceSafe (PersistenceException, + setupTable, sql) import qualified Database.GP.GenericPersistenceSafe as GpSafe import Database.GP.SqlGenerator import Database.GP.TypeInfo @@ -86,16 +93,6 @@ Left ex -> throw ex Right entity -> pure $ Just entity --- | This function retrieves all entities of type `a` from a database. --- The function takes an HDBC connection as parameter. --- The type `a` is determined by the context of the function call. --- retrieveAll :: forall a. (Entity a) => Conn -> IO [a] --- retrieveAll conn = do --- eitherExRow <- GpSafe.retrieveAll @a conn --- case eitherExRow of --- Left ex -> throw ex --- Right rows -> pure rows - -- | This function retrieves all entities of type `a` that match some query criteria. -- The function takes an HDBC connection and a `WhereClauseExpr` as parameters. -- The type `a` is determined by the context of the function call. @@ -108,6 +105,13 @@ Left ex -> throw ex Right entities -> pure entities +count :: forall a. (Entity a) => Conn -> WhereClauseExpr -> IO Int +count conn whereClause = do + eitherExCount <- GpSafe.count @a conn whereClause + case eitherExCount of + Left ex -> throw ex + Right cnt -> pure cnt + fromEitherExOrA :: IO (Either PersistenceException a) -> IO a fromEitherExOrA ioEitherExUnit = do eitherExUnit <- ioEitherExUnit @@ -127,9 +131,18 @@ -- The function takes an HDBC connection and an entity as parameters. -- The entity is either inserted or updated, depending on whether it already exists in the database. -- The required SQL statements are generated dynamically using Haskell generics and reflection +-- deprecated: use upsert instead +{-# DEPRECATED persist "use upsert instead" #-} persist :: forall a. (Entity a) => Conn -> a -> IO () -persist = (fromEitherExOrA .) . GpSafe.persist +persist = upsert +-- | A function that upserts an entity into a database. +-- The function takes an HDBC connection and an entity as parameters. +-- The entity is either inserted or updated, depending on whether it already exists in the database. +-- The required SQL statements are generated dynamically using Haskell generics and reflection +upsert :: forall a. (Entity a) => Conn -> a -> IO () +upsert = (fromEitherExOrA .) . GpSafe.upsert + -- | A function that explicitely inserts an entity into a database. insert :: forall a. (Entity a) => Conn -> a -> IO a insert = (fromEitherExOrA .) . GpSafe.insert @@ -155,16 +168,20 @@ delete :: forall a. (Entity a) => Conn -> a -> IO () delete = (fromEitherExOrA .) . GpSafe.delete +-- | A function that deletes an entity from a database. +-- The function takes an HDBC connection and an entity id as parameters. +deleteById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> id -> IO () +deleteById = (fromEitherExOrA .) . GpSafe.deleteById @a + -- | A function that deletes a list of entities from a database. -- The function takes an HDBC connection and a list of entities as parameters. -- The delete-statement is compiled only once and then executed for each entity. deleteMany :: forall a. (Entity a) => Conn -> [a] -> IO () deleteMany = (fromEitherExOrA .) . GpSafe.deleteMany --- -- | set up a table for a given entity type. The table is dropped (if existing) and recreated. --- -- The function takes an HDBC connection as parameter. --- setupTableFor :: forall a. (Entity a) => Conn -> IO () --- setupTableFor conn = do --- runRaw conn $ dropTableStmtFor @a --- runRaw conn $ createTableStmtFor @a (db conn) --- when (implicitCommit conn) $ commit conn +-- | A function that deletes a list of entities from a database. +-- The function takes an HDBC connection and a list of entity ids as parameters. +deleteManyById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> [id] -> IO () +deleteManyById = (fromEitherExOrA .) . GpSafe.deleteManyById @a + + diff --git a/src/Database/GP/GenericPersistenceSafe.hs b/src/Database/GP/GenericPersistenceSafe.hs --- a/src/Database/GP/GenericPersistenceSafe.hs +++ b/src/Database/GP/GenericPersistenceSafe.hs @@ -1,24 +1,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Database.GP.GenericPersistenceSafe ( selectById, select, + count, entitiesFromRows, sql, persist, + upsert, insert, insertMany, update, updateMany, delete, + deleteById, deleteMany, - setupTableFor, - Conn(..), + deleteManyById, + setupTable, + defaultSqliteMapping, + defaultPostgresMapping, + Conn (..), connect, - Database(..), + Database (..), TxHandling (..), ConnectionPool, createConnPool, @@ -30,7 +34,7 @@ maybeFieldTypeFor, TypeInfo (..), typeInfo, - PersistenceException(..), + PersistenceException (..), WhereClauseExpr, Field, field, @@ -55,36 +59,36 @@ limit, limitOffset, fieldIndex, - handleDuplicateInsert + handleDuplicateInsert, + removeAutoIncIdField, ) where -import Control.Exception (Exception, SomeException, try) -import Control.Monad (when) -import Data.Convertible (ConvertResult, Convertible) -import Data.Convertible.Base (Convertible (safeConvert)) -import Data.List (isInfixOf) +import Control.Exception (Exception, SomeException, try) +import Control.Monad (when) +import Data.Convertible (ConvertResult, Convertible) +import Data.Convertible.Base (Convertible (safeConvert)) +import Data.List (isInfixOf) import Database.GP.Conn import Database.GP.Entity import Database.GP.SqlGenerator import Database.GP.TypeInfo import Database.HDBC -import Text.RawString.QQ import Language.Haskell.TH.Quote (QuasiQuoter) - -{- | - This is the "safe" version of the module Database.GP.GenericPersistence. It uses Either to return errors. - - This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'. - I call instances of such a data type Entities. +import Text.RawString.QQ (r) - The Persistence operations are using Haskell generics to provide compile time reflection capabilities. - HDBC is used to access the RDBMS. --} +-- | +-- This is the "safe" version of the module Database.GP.GenericPersistence. It uses Either to return errors. +-- +-- This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'. +-- I call instances of such a data type Entities. +-- +-- The Persistence operations are using Haskell generics to provide compile time reflection capabilities. +-- HDBC is used to access the RDBMS. -- | exceptions that may occur during persistence operations -data PersistenceException = - EntityNotFound String +data PersistenceException + = EntityNotFound String | DuplicateInsert String | DatabaseError String | NoUniqueKey String @@ -97,7 +101,7 @@ -- An error is thrown if there are more than one entity with the given id. selectById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> id -> IO (Either PersistenceException a) selectById conn idx = do - --print stmt + -- print stmt eitherExResultRows <- try $ quickQuery conn stmt [eid] case eitherExResultRows of Left ex -> return $ Left $ fromException ex @@ -118,15 +122,14 @@ fromException :: SomeException -> PersistenceException fromException ex = DatabaseError $ show ex - -- | This function retrieves all entities of type `a` that match some query criteria. -- The function takes an HDBC connection and a `WhereClauseExpr` as parameters. -- The type `a` is determined by the context of the function call. -- The function returns a (possibly empty) list of all matching entities. --- The `WhereClauseExpr` is typically constructed using any tiny query dsl based on infix operators. +-- The `WhereClauseExpr` is typically constructed using a tiny query dsl based on infix operators. select :: forall a. (Entity a) => Conn -> WhereClauseExpr -> IO (Either PersistenceException [a]) select conn whereClause = do - --print stmt + -- print stmt eitherExRows <- tryPE $ quickQuery conn stmt values case eitherExRows of Left ex -> return $ Left ex @@ -135,6 +138,21 @@ stmt = selectFromStmt @a whereClause values = whereClauseValues whereClause +-- | This function retrieves the number of entities of type `a` that match some query criteria. +-- The function takes an HDBC connection and a `WhereClauseExpr` as parameters. +-- The type `a` is determined by the context of the function call. +-- The function returns the number of all matching entities. +-- The `WhereClauseExpr` is typically constructed using a tiny query dsl based on infix operators. +count :: forall a. (Entity a) => Conn -> WhereClauseExpr -> IO (Either PersistenceException Int) +count conn whereClause = do + eitherExRows <- tryPE $ quickQuery conn stmt values + case eitherExRows of + Left ex -> return $ Left ex + Right resultRows -> return $ Right $ fromSql $ head $ head resultRows -- using head twice is safe here + where + stmt = countStmtFor @a whereClause + values = whereClauseValues whereClause + -- | This function converts a list of database rows, represented as a `[[SqlValue]]` to a list of entities. -- The function takes an HDBC connection and a list of database rows as parameters. -- The type `a` is determined by the context of the function call. @@ -148,39 +166,49 @@ -- The function takes an HDBC connection and an entity as parameters. -- The entity is either inserted or updated, depending on whether it already exists in the database. -- The required SQL statements are generated dynamically using Haskell generics and reflection +upsert :: forall a. (Entity a) => Conn -> a -> IO (Either PersistenceException ()) +upsert conn entity = do + eitherExOrA <- try $ do + row <- toRow conn entity + _ <- quickQuery' conn (upsertStmtFor @a) (row <> row) + commitIfAutoCommit conn + case eitherExOrA of + Left ex -> return $ Left $ fromException ex + Right _ -> return $ Right () + +-- | A function that persists an entity to a database. +-- The function takes an HDBC connection and an entity as parameters. +-- The entity is either inserted or updated, depending on whether it already exists in the database. +-- The required SQL statements are generated dynamically using Haskell generics and reflection +-- deprecated: use upsert instead +{-# DEPRECATED persist "use upsert instead" #-} persist :: forall a. (Entity a) => Conn -> a -> IO (Either PersistenceException ()) -persist conn entity = do - eitherExRes <- try $ do - eid <- idValue conn entity - let stmt = selectFromStmt @a byIdColumn - quickQuery conn stmt [eid] >>= - \case - [] -> insert conn entity >> return (Right ()) - [_singleRow] -> update conn entity - _ -> return $ Left $ NoUniqueKey $ "More than one entity found for id " ++ show eid - case eitherExRes of - Left ex -> return $ Left $ fromException ex - Right res -> return res +persist = upsert + -- | A function that commits a transaction if the connection is in auto commit mode. -- The function takes an HDBC connection as parameter. commitIfAutoCommit :: Conn -> IO () -commitIfAutoCommit conn = when (implicitCommit conn) $ commit conn +commitIfAutoCommit (Conn autoCommit conn) = when autoCommit $ commit conn -- | A function that explicitely inserts an entity into a database. +-- The function takes an HDBC connection and an entity as parameters. +-- The entity, as retrieved from the database, is returned as a Right value if the entity was successfully inserted. +-- (this allows to handle automatically updated fields like auto-incremented primary keys) +-- If the entity could not be inserted, a Left value is returned, containing a PersistenceException. insert :: forall a. (Entity a) => Conn -> a -> IO (Either PersistenceException a) insert conn entity = do eitherExOrA <- try $ do row <- toRow conn entity - [singleRow] <- quickQuery' conn (insertReturningStmtFor @a) (removeIdField @a row) + [singleRow] <- quickQuery' conn (insertReturningStmtFor @a) (removeAutoIncIdField @a row) commitIfAutoCommit conn fromRow @a conn singleRow case eitherExOrA of Left ex -> return $ Left $ handleDuplicateInsert ex - Right a -> return $ Right a + Right a -> return $ Right a -removeIdField :: forall a. (Entity a) => [SqlValue] -> [SqlValue] -removeIdField row = +removeAutoIncIdField :: forall a. (Entity a) => [SqlValue] -> [SqlValue] +removeAutoIncIdField row = if autoIncrement @a then case maybeIdFieldIndex @a of Nothing -> row @@ -188,9 +216,11 @@ else row handleDuplicateInsert :: SomeException -> PersistenceException -handleDuplicateInsert ex = - if "UNIQUE constraint failed" `isInfixOf` show ex || - "duplicate key value violates unique constraint" `isInfixOf` show ex +handleDuplicateInsert ex = + if "UNIQUE constraint failed" + `isInfixOf` show ex + || "duplicate key value violates unique constraint" + `isInfixOf` show ex then DuplicateInsert "Entity already exists in DB, use update instead" else fromException ex @@ -209,14 +239,14 @@ eitherExUnit <- try $ do rows <- mapM (toRow conn) entities stmt <- prepare conn (insertStmtFor @a) - executeMany stmt (map (removeIdField @a) rows) + executeMany stmt (map (removeAutoIncIdField @a) rows) commitIfAutoCommit conn case eitherExUnit of Left ex -> return $ Left $ handleDuplicateInsert ex Right _ -> return $ Right () - -- | A function that explicitely updates an entity in a database. +-- The function takes an HDBC connection and an entity as parameters. update :: forall a. (Entity a) => Conn -> a -> IO (Either PersistenceException ()) update conn entity = do eitherExUnit <- try $ do @@ -260,6 +290,30 @@ Left ex -> return $ Left $ fromException ex Right result -> return result +-- | A function that deletes an entity from a database by its id. +-- The function takes an HDBC connection and an entity id as parameters. +deleteById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> id -> IO (Either PersistenceException ()) +deleteById conn idx = do + eitherExRes <- try $ do + let eid = toSql idx + rowCount <- run conn (deleteStmtFor @a) [eid] + if rowCount == 0 + then return (Left (EntityNotFound (constructorName (typeInfo @a) ++ " " ++ show eid ++ " does not exist"))) + else do + commitIfAutoCommit conn + return $ Right () + case eitherExRes of + Left ex -> return $ Left $ fromException ex + Right result -> return result + +-- | A function that deletes a list of entities from a database by their ids. +-- The function takes an HDBC connection and a list of entity ids as parameters. +deleteManyById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> [id] -> IO (Either PersistenceException ()) +deleteManyById conn ids = tryPE $ do + stmt <- prepare conn (deleteStmtFor @a) + executeMany stmt (map ((: []) . toSql) ids) + commitIfAutoCommit conn + -- | A function that deletes a list of entities from a database. -- The function takes an HDBC connection and a list of entities as parameters. -- The delete-statement is compiled only once and then executed for each entity. @@ -271,15 +325,12 @@ commitIfAutoCommit conn -- | set up a table for a given entity type. The table is dropped (if existing) and recreated. --- The function takes an HDBC connection as parameter. -setupTableFor :: forall a. (Entity a) => Database -> Conn -> IO () -setupTableFor db conn = do - --print stmt +-- The function takes an HDBC connection and a column type mapping as parameters. +setupTable :: forall a. (Entity a) => Conn -> ColumnTypeMapping -> IO () +setupTable conn mapping = do runRaw conn $ dropTableStmtFor @a - runRaw conn $ stmt -- createTableStmtFor @a (db conn) + runRaw conn $ createTableStmtFor @a mapping commitIfAutoCommit conn - where - stmt = createTableStmtFor @a db -- | A function that returns the primary key value of an entity as a SqlValue. -- The function takes an HDBC connection and an entity as parameters. @@ -290,7 +341,7 @@ where idFieldIndex = fieldIndex @a (idField @a) --- an alias for a simple quasiqouter +-- | an alias for a simple quasiqouter sql :: QuasiQuoter sql = r diff --git a/src/Database/GP/Query.hs b/src/Database/GP/Query.hs --- a/src/Database/GP/Query.hs +++ b/src/Database/GP/Query.hs @@ -29,7 +29,7 @@ SortOrder (..), limit, limitOffset, - NonEmpty(..) + NonEmpty (..), ) where @@ -45,12 +45,12 @@ import Data.Convertible (Convertible) import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Database.GP.Entity (Entity, columnNameFor, idField) import Database.HDBC (SqlValue, toSql) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) -data CompareOp = Eq | Gt | Lt | GtEq | LtEq | NotEq | Like +data CompareOp = Eq | Gt | Lt | GtEq | LtEq | NotEq | Like data Field = Field [String] String @@ -69,7 +69,7 @@ | Limit WhereClauseExpr Int | LimitOffset WhereClauseExpr Int Int -data SortOrder = ASC | DESC +data SortOrder = ASC | DESC deriving (Show) field :: String -> Field @@ -85,7 +85,7 @@ (||.) :: WhereClauseExpr -> WhereClauseExpr -> WhereClauseExpr (||.) = Or -infixl 4 =., >., <., >=., <=., <>., `like`, `between`, `in'` +infixl 4 =., >., <., >=., <=., <>., `like`, `between`, `in'` (=.), (>.), (<.), (>=.), (<=.), (<>.), like :: (Convertible b SqlValue) => Field -> b -> WhereClauseExpr a =. b = Where a Eq (toSql b) @@ -126,12 +126,11 @@ orderBy = OrderBy limit :: WhereClauseExpr -> Int -> WhereClauseExpr -limit = Limit +limit = Limit limitOffset :: WhereClauseExpr -> (Int, Int) -> WhereClauseExpr limitOffset c (offset, lim) = LimitOffset c offset lim - whereClauseExprToSql :: forall a. (Entity a) => WhereClauseExpr -> String whereClauseExprToSql (Where f op _) = columnToSql @a f ++ " " ++ opToSql op ++ " ?" whereClauseExprToSql (And e1 e2) = "(" ++ whereClauseExprToSql @a e1 ++ ") AND (" ++ whereClauseExprToSql @a e2 ++ ")" @@ -145,22 +144,22 @@ whereClauseExprToSql (WhereIsNull f) = columnToSql @a f ++ " IS NULL" whereClauseExprToSql All = "1=1" whereClauseExprToSql (ById _eid) = idColumn @a ++ " = ?" -whereClauseExprToSql ByIdColumn = idColumn @a ++ " = ?" +whereClauseExprToSql ByIdColumn = idColumn @a ++ " = ?" whereClauseExprToSql (OrderBy clause pairs) = whereClauseExprToSql @a clause ++ " ORDER BY " ++ renderedPairs pairs where renderedPairs :: NonEmpty (Field, SortOrder) -> String - renderedPairs ne = intercalate ", " (NE.toList (NE.map (\(f,order) -> columnToSql @a f ++ " " ++ show order) ne)) + renderedPairs ne = intercalate ", " (NE.toList (NE.map (\(f, order) -> columnToSql @a f ++ " " ++ show order) ne)) whereClauseExprToSql (Limit clause x) = whereClauseExprToSql @a clause ++ " LIMIT " ++ show x -whereClauseExprToSql (LimitOffset clause offset lim) = whereClauseExprToSql @a clause ++ " LIMIT " ++ show lim ++ " OFFSET " ++ show offset - +whereClauseExprToSql (LimitOffset clause offset lim) = whereClauseExprToSql @a clause ++ " LIMIT " ++ show lim ++ " OFFSET " ++ show offset + opToSql :: CompareOp -> String -opToSql Eq = "=" -opToSql Gt = ">" -opToSql Lt = "<" -opToSql GtEq = ">=" -opToSql LtEq = "<=" -opToSql NotEq = "<>" -opToSql Like = "LIKE" +opToSql Eq = "=" +opToSql Gt = ">" +opToSql Lt = "<" +opToSql GtEq = ">=" +opToSql LtEq = "<=" +opToSql NotEq = "<>" +opToSql Like = "LIKE" columnToSql :: forall a. (Entity a) => Field -> String columnToSql = expandFunctions @a @@ -168,7 +167,7 @@ idColumn :: forall a. (Entity a) => String idColumn = columnNameFor @a (idField @a) -expandFunctions :: forall a. (Entity a) => Field -> String -- -> String +expandFunctions :: forall a. (Entity a) => Field -> String expandFunctions (Field [] name) = columnNameFor @a name expandFunctions (Field (f : fs) name) = f ++ "(" ++ expandFunctions @a (Field fs name) ++ ")" diff --git a/src/Database/GP/SqlGenerator.hs b/src/Database/GP/SqlGenerator.hs --- a/src/Database/GP/SqlGenerator.hs +++ b/src/Database/GP/SqlGenerator.hs @@ -1,11 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} module Database.GP.SqlGenerator ( insertStmtFor, insertReturningStmtFor, updateStmtFor, + upsertStmtFor, selectFromStmt, + countStmtFor, deleteStmtFor, createTableStmtFor, dropTableStmtFor, @@ -35,14 +36,17 @@ SortOrder (..), limit, limitOffset, - NonEmpty(..), + NonEmpty (..), Database (..), + defaultSqliteMapping, + defaultPostgresMapping, + ColumnTypeMapping, ) where import Data.List (intercalate) -import Database.GP.Entity -import Database.GP.Query +import Database.GP.Entity +import Database.GP.Query -- | -- This module defines some basic SQL statements for Record Data Types that are instances of 'Entity'. @@ -57,34 +61,52 @@ "INSERT INTO " ++ tableName @a ++ " (" - ++ intercalate ", " insertColumns + ++ intercalate ", " insertCols ++ ") VALUES (" - ++ intercalate ", " (params (length insertColumns)) + ++ intercalate ", " (params (length insertCols)) ++ ");" where + insertCols = insertColumns @a + +upsertStmtFor :: forall a. Entity a => String +upsertStmtFor = + "INSERT INTO " + ++ tableName @a + ++ " (" + ++ intercalate ", " insertCols + ++ ") VALUES (" + ++ intercalate ", " (params (length insertCols)) + ++ ") ON CONFLICT (" + ++ idColumn @a + ++ ") DO UPDATE SET " + ++ intercalate ", " updatePairs + ++ ";" + where + insertCols = columnNamesFor @a + updatePairs = map (++ " = ?") insertCols + +insertColumns :: forall a. Entity a => [String] +insertColumns = + if autoIncrement @a + then filter (/= idColumn @a) columns + else columns + where columns = columnNamesFor @a - insertColumns = if autoIncrement @a - then filter (/= idColumn @a) columns - else columns insertReturningStmtFor :: forall a. Entity a => String insertReturningStmtFor = "INSERT INTO " ++ tableName @a ++ " (" - ++ intercalate ", " insertColumns + ++ intercalate ", " insertCols ++ ") VALUES (" - ++ intercalate ", " (params (length insertColumns)) + ++ intercalate ", " (params (length insertCols)) ++ ") RETURNING " - ++ returnColumns + ++ returnCols ++ ";" where - columns = columnNamesFor @a - insertColumns = if autoIncrement @a - then filter (/= idColumn @a) columns - else columns - returnColumns = intercalate ", " columns - + insertCols = insertColumns @a + returnCols = intercalate ", " (columnNamesFor @a) columnNamesFor :: forall a. Entity a => [String] columnNamesFor = map snd fieldColumnPairs @@ -117,6 +139,17 @@ ++ whereClauseExprToSql @a whereClauseExpr ++ ";" +-- | A function that returns an SQL count statement for an entity. Type 'a' must be an instance of Entity. +-- The function takes a where clause expression as parameter. This expression is used to filter the result set. +countStmtFor :: forall a. (Entity a) => WhereClauseExpr -> String +countStmtFor whereClauseExpr = + "SELECT COUNT(*) FROM " + ++ tableName @a + ++ " WHERE " + ++ whereClauseExprToSql @a whereClauseExpr + ++ ";" + +-- | A function that returns an SQL delete statement for an entity. Type 'a' must be an instance of Entity. deleteStmtFor :: forall a. (Entity a) => String deleteStmtFor = "DELETE FROM " @@ -125,58 +158,63 @@ ++ idColumn @a ++ " = ?;" --- | An enumeration of the supported database types. -data Database = Postgres | SQLite -- | Oracle | MSSQL | MySQL - deriving (Show, Eq) +-- | An enumeration of the supported database types. +data Database = Postgres | SQLite -createTableStmtFor :: forall a. (Entity a) => Database -> String -createTableStmtFor dbServer = +-- | A function that returns an SQL create table statement for an entity type. Type 'a' must be an instance of Entity. +createTableStmtFor :: forall a. (Entity a) => ColumnTypeMapping -> String +createTableStmtFor columnTypeMapping = "CREATE TABLE " ++ tableName @a ++ " (" - ++ intercalate ", " (map (\(f, c) -> c ++ " " ++ columnTypeFor @a dbServer f ++ optionalPK f) (fieldsToColumns @a)) + ++ intercalate ", " (map (\(f, c) -> c ++ " " ++ columnTypeFor @a columnTypeMapping f ++ optionalPK f) (fieldsToColumns @a)) ++ ");" where - optionalPK f = if isIdField @a f - then case dbServer of - SQLite -> " PRIMARY KEY AUTOINCREMENT" - Postgres -> " PRIMARY KEY" - else "" + optionalPK f = if isIdField @a f then " PRIMARY KEY" else "" isIdField :: forall a. (Entity a) => String -> Bool isIdField f = f == idField @a -- | A function that returns the column type for a field of an entity. --- TODO: Support other databases than just SQLite and Postgres. -columnTypeFor :: forall a. (Entity a) => Database -> String -> String -columnTypeFor dbDialect fieldName = - case dbDialect of - SQLite -> columnTypeForSQLite fType - Postgres -> if isIdField @a fieldName - then "serial" - else columnTypeForPostgres fType +-- The function takes a column type mapping function as parameter. +-- This function is used to map Haskell field types to SQL column types. +columnTypeFor :: forall a. (Entity a) => ColumnTypeMapping -> String -> String +columnTypeFor columnTypeMapping fieldName = columnTypeMapping fType where - maybeFType = maybeFieldTypeFor @a fieldName - fType = maybe "OTHER" show maybeFType - - columnTypeForSQLite :: String -> String - columnTypeForSQLite = \case - "Int" -> "INTEGER" - "[Char]" -> "TEXT" - "Double" -> "REAL" - "Float" -> "REAL" - "Bool" -> "INT" - _ -> "TEXT" + fType = + if isIdField @a fieldName + then "primaryKey" + else maybe "OTHER" show $ maybeFieldTypeFor @a fieldName - columnTypeForPostgres :: String -> String - columnTypeForPostgres = \case - "Int" -> "numeric" - "[Char]" -> "varchar" - "Double" -> "numeric" - "Float" -> "numeric" - "Bool" -> "boolean" - _ -> "varchar" +-- | A type alias for mapping a Haskell field type to a SQL column type. +-- this type can be used to define custom mappings for field types. +type ColumnTypeMapping = String -> String +-- | The default mapping for SQLite databases. +-- This mapping is used when no custom mapping is provided. +defaultSqliteMapping :: ColumnTypeMapping +defaultSqliteMapping = \case + "primaryKey" -> "INTEGER" + "Int" -> "INTEGER" + "[Char]" -> "TEXT" + "Double" -> "REAL" + "Float" -> "REAL" + "Bool" -> "INT" + _ -> "TEXT" + +-- | The default mapping for Postgres databases. +-- This mapping is used when no custom mapping is provided. +defaultPostgresMapping :: ColumnTypeMapping +defaultPostgresMapping = \case + "primaryKey" -> "serial" + "Int" -> "numeric" + "[Char]" -> "varchar" + "Double" -> "numeric" + "Float" -> "numeric" + "Bool" -> "boolean" + _ -> "varchar" + +-- | This function generates a DROP TABLE statement for an entity type. dropTableStmtFor :: forall a. (Entity a) => String dropTableStmtFor = "DROP TABLE IF EXISTS " diff --git a/src/Database/GP/TypeInfo.hs b/src/Database/GP/TypeInfo.hs --- a/src/Database/GP/TypeInfo.hs +++ b/src/Database/GP/TypeInfo.hs @@ -34,7 +34,7 @@ { constructorName = gConstrName (undefined :: a), fieldNames = map fst (gSelectors (undefined :: a)), fieldTypes = map snd (gSelectors (undefined :: a)) - } + } -- Generic implementations gConstrName :: (HasConstructor (Rep a), Generic a) => a -> String diff --git a/test/ConnSpec.hs b/test/ConnSpec.hs --- a/test/ConnSpec.hs +++ b/test/ConnSpec.hs @@ -1,6 +1,3 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} - module ConnSpec ( test, spec, @@ -8,13 +5,13 @@ where import Database.GP +import Database.HDBC import Database.HDBC.Sqlite3 import GHC.Generics import Test.Hspec -import Database.HDBC -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -22,7 +19,7 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn + setupTable @Article conn defaultSqliteMapping return conn data Article = Article @@ -36,9 +33,9 @@ spec = do describe "Connection Handling" $ do it "can work with embedded connection" $ do - Conn{implicitCommit=ic, connection=conn} <- prepareDB + (Conn ic conn) <- prepareDB ic `shouldBe` True - + runRaw conn "DROP TABLE IF EXISTS Person;" let conn' = connect AutoCommit conn @@ -47,9 +44,9 @@ it "can handle rollback" $ do conn <- prepareDB - let conn' = conn{implicitCommit=False} + let conn' = connect ExplicitCommit conn let article = Article 1 "Hello" 2023 - + _ <- insert conn' article allArticles <- select conn' allEntries :: IO [Article] allArticles `shouldBe` [article] @@ -59,10 +56,10 @@ it "provide the IConnection methods" $ do conn <- prepareDB - allTables <- getTables conn + allTables <- getTables conn allTables `shouldContain` ["Article"] - desc <- describeTable conn "Article" + desc <- describeTable conn "Article" length desc `shouldBe` 3 let driverName = hdbcDriverName conn @@ -83,14 +80,6 @@ let txSupport = dbTransactionSupport conn txSupport `shouldBe` True - clonedConn <- clone conn - implicitCommit clonedConn `shouldBe` implicitCommit conn - - - - - - - - - + let (Conn autoCommit _) = conn + (Conn clonedAutoCommit _) <- clone conn + clonedAutoCommit `shouldBe` autoCommit diff --git a/test/DemoSpec.hs b/test/DemoSpec.hs --- a/test/DemoSpec.hs +++ b/test/DemoSpec.hs @@ -9,8 +9,8 @@ import Database.GP import Database.HDBC.Sqlite3 (connectSqlite3) import GHC.Generics -import Test.Hspec import Prelude hiding (print) +import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is -- not needed for automatic spec discovery. @@ -41,7 +41,7 @@ conn <- connect AutoCommit <$> connectSqlite3 "sqlite.db" -- initialize Person table - setupTableFor @Person SQLite conn + setupTable @Person conn defaultSqliteMapping alice <- insert conn Person {name = "Alice", age = 25, address = "Elmstreet 1"} print alice diff --git a/test/EmbeddedSpec.hs b/test/EmbeddedSpec.hs --- a/test/EmbeddedSpec.hs +++ b/test/EmbeddedSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} - module EmbeddedSpec ( test, spec, @@ -13,7 +11,7 @@ import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -21,7 +19,7 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn + setupTable @Article conn defaultSqliteMapping return conn data Article = Article diff --git a/test/EnumSpec.hs b/test/EnumSpec.hs --- a/test/EnumSpec.hs +++ b/test/EnumSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} - module EnumSpec ( test, spec, @@ -14,7 +12,7 @@ import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -22,7 +20,7 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Book SQLite conn + setupTable @Book conn defaultSqliteMapping return conn data Book = Book diff --git a/test/ExceptionsSpec.hs b/test/ExceptionsSpec.hs --- a/test/ExceptionsSpec.hs +++ b/test/ExceptionsSpec.hs @@ -1,21 +1,18 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} - module ExceptionsSpec ( test, spec, ) where +import Control.Exception import Database.GP.GenericPersistenceSafe +import Database.HDBC import Database.HDBC.Sqlite3 import GHC.Generics import Test.Hspec -import Database.HDBC -import Control.Exception -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -23,7 +20,7 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn + setupTable @Article conn defaultSqliteMapping return conn data Article = Article @@ -35,20 +32,21 @@ instance Entity Article where autoIncrement = False + idField = "articleID" data Bogus = Bogus - { bogusID :: Int, + { bogusID :: Int, bogusTitle :: String, - bogusYear :: Int + bogusYear :: Int } deriving (Generic, Show, Eq) instance Entity Bogus where tableName = "Article" - - fieldsToColumns :: [(String, String)] -- ommitting the articles field, - fieldsToColumns = -- as this can not be mapped to a single column + fieldsToColumns :: [(String, String)] -- ommitting the articles field, + fieldsToColumns = + -- as this can not be mapped to a single column [ ("bogusID", "articleID"), ("bogusTitle", "title"), ("bogusYear", "year") @@ -57,7 +55,6 @@ fromRow :: Conn -> [SqlValue] -> IO Bogus fromRow _conn _row = throw $ DatabaseError "can't create bogus" - yearField :: Field yearField = field "year" @@ -76,39 +73,35 @@ eitherExRes <- insert conn article :: IO (Either PersistenceException Article) case eitherExRes of Left di@(DuplicateInsert _msg) -> show di `shouldContain` "Entity already exists" - _ -> expectationFailure "Expected DuplicateInsert exception" + _ -> expectationFailure "Expected DuplicateInsert exception" it "detects duplicate inserts in insertMany" $ do conn <- prepareDB _ <- insert conn article - eitherExRes <- insertMany conn [article,article] :: IO (Either PersistenceException ()) + eitherExRes <- insertMany conn [article, article] :: IO (Either PersistenceException ()) case eitherExRes of Left (DuplicateInsert msg) -> msg `shouldContain` "Entity already exists" - _ -> expectationFailure "Expected DuplicateInsert exception" - it "detects duplicate inserts in persist" $ do - conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - runRaw conn "CREATE TABLE article (articleID INTEGER, title TEXT, year INTEGER)" - _ <- insert conn article - _ <- insert conn article{title="another title"} - eitherExRes <- persist conn article :: IO (Either PersistenceException ()) + _ -> expectationFailure "Expected DuplicateInsert exception" + it "returns () for successful upsert" $ do + conn <- prepareDB + eitherExRes <- upsert conn article :: IO (Either PersistenceException ()) case eitherExRes of - Left (NoUniqueKey msg) -> msg `shouldContain` "More than one entity found for id SqlInt64 1" - Left pe -> expectationFailure $ "Expected NoUniqueKey exception, got " ++ show pe - _ -> expectationFailure "Expected NoUniqueKey exception" + Right () -> expectationSuccess + _ -> expectationFailure "Expected ()" it "detects missing entities in selectById" $ do conn <- prepareDB eitherExRes <- selectById conn "1" :: IO (Either PersistenceException Article) case eitherExRes of Left (EntityNotFound msg) -> msg `shouldContain` "not found" - _ -> expectationFailure "Expected EntityNotFound exception" + _ -> expectationFailure "Expected EntityNotFound exception" it "detects non unique entities in selectById" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" runRaw conn "CREATE TABLE article (articleID INTEGER, title TEXT, year INTEGER)" _ <- insert conn article - _ <- insert conn article{title="another title"} + _ <- insert conn article {title = "another title"} eitherExRes <- selectById conn "1" :: IO (Either PersistenceException Article) case eitherExRes of Left (NoUniqueKey msg) -> msg `shouldContain` "More than one Article found for id SqlString \"1\"" - _ -> expectationFailure "Expected DuplicateEntity exception" + _ -> expectationFailure "Expected DuplicateEntity exception" it "detects bogus data in selectById" $ do conn <- prepareDB @@ -116,36 +109,48 @@ eitherExRes <- selectById conn "1" :: IO (Either PersistenceException Bogus) case eitherExRes of Left (DatabaseError msg) -> msg `shouldContain` "can't create bogus" - Left pe -> expectationFailure $ "Expected DatabaseError exception, got " ++ show pe - _ -> expectationFailure "Expected DatabaseError exception" + Left pe -> expectationFailure $ "Expected DatabaseError exception, got " ++ show pe + _ -> expectationFailure "Expected DatabaseError exception" it "detects missing entities in update" $ do conn <- prepareDB eitherExRes <- update conn article :: IO (Either PersistenceException ()) case eitherExRes of Left (EntityNotFound msg) -> msg `shouldContain` "does not exist" - _ -> expectationFailure "Expected EntityNotFound exception" + _ -> expectationFailure "Expected EntityNotFound exception" it "detects missing entities in delete" $ do conn <- prepareDB eitherExRes <- delete conn article :: IO (Either PersistenceException ()) case eitherExRes of Left (EntityNotFound msg) -> msg `shouldContain` "does not exist" - _ -> expectationFailure "Right: Expected EntityNotFound exception" + _ -> expectationFailure "Right: Expected EntityNotFound exception" + it "detects missing entities in deleteById" $ do + conn <- prepareDB + eitherExRes <- deleteById @Article conn "1" :: IO (Either PersistenceException ()) + case eitherExRes of + Left (EntityNotFound msg) -> msg `shouldContain` "does not exist" + _ -> expectationFailure "Expected EntityNotFound exception" + it "detects general db issues in deleteById" $ do + conn <- connect AutoCommit <$> connectSqlite3 ":memory:" + eitherExRes <- deleteById @Article conn "1" :: IO (Either PersistenceException ()) + case eitherExRes of + Left (DatabaseError msg) -> msg `shouldContain` "SqlError" + _ -> expectationFailure "Expected DatabaseError exception" it "detects general backend issues" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" eitherExRes <- update conn article :: IO (Either PersistenceException ()) case eitherExRes of Left (DatabaseError msg) -> msg `shouldContain` "SqlError" - _ -> expectationFailure "Expected DatabaseError exception" + _ -> expectationFailure "Expected DatabaseError exception" it "has no leaking backend exceptions" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" _ <- update conn article :: IO (Either PersistenceException ()) _ <- insert conn article :: IO (Either PersistenceException Article) - _ <- persist conn article :: IO (Either PersistenceException ()) + _ <- upsert conn article :: IO (Either PersistenceException ()) _ <- delete conn article :: IO (Either PersistenceException ()) _ <- selectById conn "1" :: IO (Either PersistenceException Article) _ <- select conn allEntries :: IO (Either PersistenceException [Article]) - _ <- select conn (yearField =. "2023") :: IO (Either PersistenceException [Article]) + _ <- select conn (yearField =. "2023") :: IO (Either PersistenceException [Article]) _ <- insertMany conn [article] :: IO (Either PersistenceException ()) _ <- updateMany conn [article] :: IO (Either PersistenceException ()) _ <- deleteMany conn [article] :: IO (Either PersistenceException ()) @@ -164,5 +169,42 @@ print index `shouldThrow` errorCall "expectJust Field unknown is not present in type Article" it "handles duplicate insert exceptions" $ do - handleDuplicateInsert (toException $ EntityNotFound "24" ) `shouldBe` DatabaseError "EntityNotFound \"24\"" - + handleDuplicateInsert (toException $ EntityNotFound "24") `shouldBe` DatabaseError "EntityNotFound \"24\"" + + it "handles autoincrement edge cases" $ do + conn <- connect AutoCommit <$> connectSqlite3 ":memory:" + let article' = Article 200 "title" 2023 + expectedRow = [SqlInt64 200, SqlString "title", SqlInt64 2023] + articleRow <- toRow conn article' + articleRow `shouldBe` expectedRow + -- Article is defined with autoIncrement = False + removeAutoIncIdField @Article articleRow `shouldBe` expectedRow + + -- ArticleWithoutPK is defined with autoIncrement = True, but has no primary key field + let articleWithoutPK = ArticleWithoutPK "title" 2023 + rowWithoutPK = [SqlString "title", SqlInt64 2023] + articleRowWithoutPK <- toRow conn articleWithoutPK + removeAutoIncIdField @ArticleWithoutPK articleRowWithoutPK `shouldBe` rowWithoutPK + + -- ArticleWithPKatEnd is defined with autoIncrement = True and has a primary key field as last column + let articleWithPKatEnd = ArticleWithPKatEnd "title" 2023 200 + expectedRow2 = [SqlString "title", SqlInt64 2023] + articleRowWithPKatEnd <- toRow conn articleWithPKatEnd + removeAutoIncIdField @ArticleWithPKatEnd articleRowWithPKatEnd `shouldBe` expectedRow2 + +data ArticleWithoutPK = ArticleWithoutPK + { title1 :: String, + year1 :: Int + } + deriving (Generic, Show, Entity, Eq) + +data ArticleWithPKatEnd = ArticleWithPKatEnd + { title2 :: String, + year2 :: Int, + articleID2 :: Int + } + deriving (Generic, Show, Eq) + +instance Entity ArticleWithPKatEnd where + autoIncrement = True + idField = "articleID2" diff --git a/test/GenericPersistenceSpec.hs b/test/GenericPersistenceSpec.hs --- a/test/GenericPersistenceSpec.hs +++ b/test/GenericPersistenceSpec.hs @@ -1,6 +1,6 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} module GenericPersistenceSpec ( test, @@ -8,15 +8,15 @@ ) where +import Control.Exception import Database.GP.GenericPersistence import Database.HDBC import Database.HDBC.Sqlite3 -import GHC.Generics hiding (Selector) +import GHC.Generics hiding (Selector) import Test.Hspec -import Control.Exception -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -24,8 +24,10 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Person SQLite conn - setupTableFor @Book SQLite conn + setupTable @Person conn defaultSqliteMapping + setupTable @Book conn defaultSqliteMapping + setupTable @Car conn defaultSqliteMapping + setupTable @Boat conn defaultSqliteMapping return conn -- | A data type with several fields, using record syntax. @@ -38,14 +40,27 @@ deriving (Generic, Show, Eq) instance Entity Person where - autoIncrement = False + autoIncrement = False data Car = Car - { carID :: Int, - carType :: String + { carID :: Int, + carType :: String } - deriving (Generic, Entity, Show, Eq) + deriving (Generic, Show, Eq) +instance Entity Car where + autoIncrement = True + idField = "carID" + +data Boat = Boat + { boatID :: Int, + boatType :: String + } + deriving (Generic, Show, Eq) + +instance Entity Boat where + autoIncrement = False + data Book = Book { book_id :: Int, title :: String, @@ -60,8 +75,13 @@ instance Entity Book where idField = "book_id" - fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), - ("year", "bookYear"), ("category", "bookCategory")] + fieldsToColumns = + [ ("book_id", "bookId"), + ("title", "bookTitle"), + ("author", "bookAuthor"), + ("year", "bookYear"), + ("category", "bookCategory") + ] tableName = "BOOK_TBL" fromRow _c row = pure $ Book (col 0) (col 1) (col 2) (col 3) (col 4) where @@ -99,17 +119,28 @@ head allPersons `shouldBe` bob person' <- selectById conn (1 :: Int) :: IO (Maybe Person) person' `shouldBe` Just bob + it "retrieves the number of selected Entities" $ do + conn <- prepareDB + insertMany conn manyPersons + countPersons <- count @Person conn allEntries + countPersons `shouldBe` 6 + it "signals if counting fails" $ do + conn <- connect AutoCommit <$> connectSqlite3 ":memory:" -- no tables in db + eitherEA <- try (count @Person conn allEntries) + case eitherEA of + Left (DatabaseError msg) -> msg `shouldContain` "no such table: Person" + _ -> expectationFailure "Expected DatabaseError" it "selectById returns Nothing if no Entity was found" $ do conn <- prepareDB person' <- selectById conn (1 :: Int) :: IO (Maybe Person) person' `shouldBe` Nothing - it "selectById throws a DatabaseError if things go wrong in the DB" $ do + it "selectById throws a DatabaseError if things go wrong in the DB" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" eitherEA <- try (selectById conn (1 :: Int) :: IO (Maybe Person)) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "no such table: Person" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" it "retrieves Entities using user implementation" $ do conn <- prepareDB let hobbit = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction @@ -120,35 +151,60 @@ length allBooks `shouldBe` 3 head allBooks `shouldBe` hobbit book' <- selectById conn (1 :: Int) :: IO (Maybe Book) - book' `shouldBe` Just hobbit + book' `shouldBe` Just hobbit it "select returns Nothing if no Entity was found" $ do conn <- prepareDB allPersons' <- select @Person conn allEntries allPersons' `shouldBe` [] - it "select throws a DatabaseError if things go wrong" $ do + it "select throws a DatabaseError if things go wrong" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" eitherEA <- try (select @Person conn allEntries) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "no such table: Person" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" - it "can materialize Entities from user defined SQL queries" $ do + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" + it "can materialize Entities from user defined SQL queries" $ do conn <- prepareDB insertMany conn manyPersons - let stmt = [sql| - SELECT * - FROM Person + let stmt = + [sql| + SELECT * + FROM Person WHERE age >= ? ORDER BY age ASC |] resultRows <- quickQuery conn stmt [toSql (40 :: Int)] allPersons <- entitiesFromRows @Person conn resultRows length allPersons `shouldBe` 3 + it "can upsert Entities with AutoIncrement" $ do + conn <- prepareDB + let car = Car 1 "Honda Jazz" + -- insert the car + upsert conn car + car' <- selectById conn (1 :: Int) :: IO (Maybe Car) + car' `shouldBe` Just car + -- now update the car + let car2 = Car 1 "Honda Civic" + upsert conn car2 + car2' <- selectById conn (1 :: Int) :: IO (Maybe Car) + car2' `shouldBe` Just car2 + it "can upsert Entities without autoIncrement" $ do + conn <- prepareDB + let boat = Boat 1 "Sailboat" + -- insert the boat + upsert conn boat + boat' <- selectById conn (1 :: Int) :: IO (Maybe Boat) + boat' `shouldBe` Just boat + -- now update the boat + let boat2 = Boat 1 "Motorboat" + upsert conn boat2 + boat2' <- selectById conn (1 :: Int) :: IO (Maybe Boat) + boat2' `shouldBe` Just boat2 it "persists new Entities using Generics" $ do conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] length allPersons `shouldBe` 0 - persist conn person + upsert conn person allPersons' <- select conn allEntries :: IO [Person] length allPersons' `shouldBe` 1 person' <- selectById conn (123456 :: Int) :: IO (Maybe Person) @@ -162,13 +218,13 @@ length allbooks' `shouldBe` 1 book' <- selectById conn (1 :: Int) :: IO (Maybe Book) book' `shouldBe` Just book - it "persist throws an exception if things go wrong" $ do + it "persist throws an exception if things go wrong" $ do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" eitherEA <- try (persist conn book) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "no such table: BOOK_TBL" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" it "persists existing Entities using Generics" $ do conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] @@ -188,7 +244,7 @@ length allbooks' `shouldBe` 1 eitherEA <- try $ persist conn book {year = 1938} :: IO (Either PersistenceException ()) case eitherEA of - Left _ -> expectationFailure "should not throw an exception" + Left _ -> expectationFailure "should not throw an exception" Right x -> x `shouldBe` () book' <- selectById conn (1 :: Int) :: IO (Maybe Book) book' `shouldBe` Just book {year = 1938} @@ -196,15 +252,14 @@ conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] length allPersons `shouldBe` 0 - _ <- insert conn person + _ <- insert conn person allPersons' <- select conn allEntries :: IO [Person] length allPersons' `shouldBe` 1 person' <- selectById conn (123456 :: Int) :: IO (Maybe Person) person' `shouldBe` Just person it "inserts Entities with autoincrement handling" $ do conn <- prepareDB - _ <- run conn "CREATE TABLE Car (carID INTEGER PRIMARY KEY AUTOINCREMENT, carType TEXT);" [] - myCar@(Car carId _) <- insert conn (Car 0 "Honda Jazz") + myCar@(Car carId _) <- insert conn Car {carType = "Honda Jazz"} myCar' <- selectById conn carId :: IO (Maybe Car) myCar' `shouldBe` Just myCar it "inserts many Entities re-using a single prepared stmt" $ do @@ -214,6 +269,12 @@ insertMany conn manyPersons allPersons' <- select conn allEntries :: IO [Person] length allPersons' `shouldBe` 6 + it "inserts many alsodoes autoincrement handling" $ do + conn <- prepareDB + insertMany conn [Car {carType = "Honda Jazz"}] + [Car carId typ] <- select @Car conn allEntries + typ `shouldBe` "Honda Jazz" + carId `shouldBe` 1 it "updates many Entities re-using a single prepared stmt" $ do conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] @@ -231,11 +292,32 @@ length allPersons `shouldBe` 0 insertMany conn manyPersons allPersons' <- select conn allEntries :: IO [Person] - length allPersons' `shouldBe` 6 + length allPersons' `shouldBe` 6 deleteMany conn allPersons' allPersons'' <- select conn allEntries :: IO [Person] length allPersons'' `shouldBe` 0 + it "deletes a single entity by a given id" $ do + conn <- prepareDB + insertMany conn manyPersons + res <- deleteById @Person conn (6 :: Int) + res `shouldBe` () + allPersons <- select conn allEntries :: IO [Person] + length allPersons `shouldBe` 5 + it "signals if deleting by id fails" $ do + conn <- prepareDB + eitherEA <- try (deleteById @Person conn (6 :: Int)) + case eitherEA of + Left (EntityNotFound msg) -> msg `shouldContain` "does not exist" + _ -> expectationFailure "Expected EntityNotFound exception" + + it "deletes multiple entities by a list of ids" $ do + conn <- prepareDB + insertMany conn manyPersons + deleteManyById @Person conn ([2,4,6] :: [Int]) + allPersons <- select conn allEntries :: IO [Person] + length allPersons `shouldBe` 3 + it "inserts Entities using user implementation" $ do conn <- prepareDB allbooks <- select conn allEntries :: IO [Book] @@ -274,9 +356,9 @@ allBooks' <- select conn allEntries :: IO [Book] length allBooks' `shouldBe` 0 it "provides a Connection Pool" $ do - connPool <- sqlLitePool ":memory:" + connPool <- sqlLitePool ":memory:" withResource connPool $ \conn -> do - setupTableFor @Person SQLite conn + setupTable @Person conn defaultSqliteMapping _ <- insert conn person allPersons <- select conn allEntries :: IO [Person] length allPersons `shouldBe` 1 diff --git a/test/OneToManySafeSpec.hs b/test/OneToManySafeSpec.hs --- a/test/OneToManySafeSpec.hs +++ b/test/OneToManySafeSpec.hs @@ -1,21 +1,18 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} - module OneToManySafeSpec ( test, spec, ) where +import Data.Either (fromRight) import Database.GP.GenericPersistenceSafe import Database.HDBC import Database.HDBC.Sqlite3 import GHC.Generics import Test.Hspec -import Data.Either (fromRight) -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl -- test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -23,8 +20,8 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn - setupTableFor @Author SQLite conn + setupTable @Article conn defaultSqliteMapping + setupTable @Author conn defaultSqliteMapping return conn data Article = Article @@ -36,7 +33,7 @@ deriving (Generic, Show, Eq) instance Entity Article where - autoIncrement = False + autoIncrement = False data Author = Author { authorID :: Int, @@ -47,8 +44,9 @@ deriving (Generic, Show, Eq) instance Entity Author where - fieldsToColumns :: [(String, String)] -- ommitting the articles field, - fieldsToColumns = -- as this can not be mapped to a single column + fieldsToColumns :: [(String, String)] -- ommitting the articles field, + fieldsToColumns = + -- as this can not be mapped to a single column [ ("authorID", "authorID"), ("name", "name"), ("address", "address") @@ -56,18 +54,21 @@ fromRow :: Conn -> [SqlValue] -> IO Author fromRow conn row = do - let authID = head row -- authorID is the first column - articlesBy <- (fromRight []) <$> select @Article conn (field "authorId" =. authID) -- retrieve all articles by this author - return rawAuthor {articles = articlesBy} -- add the articles to the author + let authID = head row -- authorID is the first column + articlesBy <- fromRight [] <$> select @Article conn (field "authorId" =. authID) -- retrieve all articles by this author + return rawAuthor {articles = articlesBy} -- add the articles to the author where - rawAuthor = Author (col 0) (col 1) (col 2) [] -- create the author from row (w/o articles) - col i = fromSql (row !! i) -- helper function to convert SqlValue to Haskell type + rawAuthor = Author (col 0) (col 1) (col 2) [] -- create the author from row (w/o articles) + col i = fromSql (row !! i) -- helper function to convert SqlValue to Haskell type toRow :: Conn -> Author -> IO [SqlValue] toRow conn a = do - mapM_ (persist conn) (articles a) -- persist all articles of this author (update or insert) - return [toSql (authorID a), -- return the author as a list of SqlValues - toSql (name a), toSql (address a)] + mapM_ (persist conn) (articles a) -- persist all articles of this author (update or insert) + return + [ toSql (authorID a), -- return the author as a list of SqlValues + toSql (name a), + toSql (address a) + ] autoIncrement = False article1 :: Article @@ -127,7 +128,7 @@ Left _ -> fail "should not happen" Right author -> do length (articles author) `shouldBe` 2 - + _ <- persist conn arthur {address = "New York"} eitherPeAuthor' <- selectById @Author conn "2" eitherPeAuthor' `shouldBe` Right arthur {address = "New York"} @@ -141,10 +142,10 @@ eitherPeUnit <- delete conn arthur case eitherPeUnit of Left (DatabaseError msg) -> msg `shouldContain` "no such table: Author" - _ -> fail "should not happen" + _ -> fail "should not happen" it "insertMany works with references" $ do conn <- prepareDB - let authors = [arthur, arthur{name="Bob", authorID=3, articles=[]}] + let authors = [arthur, arthur {name = "Bob", authorID = 3, articles = []}] eitherPeUnit <- insertMany conn authors eitherPeUnit `shouldBe` Right () eitherPeAuthors <- select @Author conn allEntries @@ -158,7 +159,7 @@ eitherPeAuthor `shouldBe` Right arthur {address = "New York"} it "updateMany works with references" $ do conn <- prepareDB - let authors = [arthur, arthur{name="Bob", authorID=3, articles=[]}] + let authors = [arthur, arthur {name = "Bob", authorID = 3, articles = []}] _ <- insertMany conn authors eitherPeUnit <- updateMany conn (map (\a -> a {address = "New York"}) authors) eitherPeUnit `shouldBe` Right () @@ -166,11 +167,9 @@ eitherPeAuthors `shouldBe` Right (map (\a -> a {address = "New York"}) authors) it "deleteMany works with references" $ do conn <- prepareDB - let authors = [arthur, arthur{name="Bob", authorID=3, articles=[]}] + let authors = [arthur, arthur {name = "Bob", authorID = 3, articles = []}] _ <- insertMany conn authors eitherPeUnit <- deleteMany conn authors eitherPeUnit `shouldBe` Right () eitherPeAuthors <- select @Author conn allEntries eitherPeAuthors `shouldBe` Right [] - - diff --git a/test/OneToManySpec.hs b/test/OneToManySpec.hs --- a/test/OneToManySpec.hs +++ b/test/OneToManySpec.hs @@ -1,6 +1,3 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} - module OneToManySpec ( test, spec, @@ -15,7 +12,7 @@ import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl -- test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -23,8 +20,8 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn - setupTableFor @Author SQLite conn + setupTable @Article conn defaultSqliteMapping + setupTable @Author conn defaultSqliteMapping return conn data Article = Article @@ -36,7 +33,7 @@ deriving (Generic, Show, Eq) instance Entity Article where - autoIncrement = False + autoIncrement = False data Author = Author { authorID :: Int, @@ -47,8 +44,9 @@ deriving (Generic, Show, Eq) instance Entity Author where - fieldsToColumns :: [(String, String)] -- ommitting the articles field, - fieldsToColumns = -- as this can not be mapped to a single column + fieldsToColumns :: [(String, String)] -- ommitting the articles field, + fieldsToColumns = + -- as this can not be mapped to a single column [ ("authorID", "authorID"), ("name", "name"), ("address", "address") @@ -57,19 +55,21 @@ fromRow :: Conn -> [SqlValue] -> IO Author fromRow conn row = do - let authID = head row -- authorID is the first column + let authID = head row -- authorID is the first column articlesBy <- select conn (field "authorId" =. authID) -- retrieve all articles by this author - return rawAuthor {articles = articlesBy} -- add the articles to the author + return rawAuthor {articles = articlesBy} -- add the articles to the author where - rawAuthor = Author (col 0) (col 1) (col 2) [] -- create the author from row (w/o articles) - col i = fromSql (row !! i) -- helper function to convert SqlValue to Haskell type + rawAuthor = Author (col 0) (col 1) (col 2) [] -- create the author from row (w/o articles) + col i = fromSql (row !! i) -- helper function to convert SqlValue to Haskell type toRow :: Conn -> Author -> IO [SqlValue] toRow conn a = do - mapM_ (persist conn) (articles a) -- persist all articles of this author (update or insert) - return [toSql (authorID a), -- return the author as a list of SqlValues - toSql (name a), toSql (address a)] - + mapM_ (persist conn) (articles a) -- persist all articles of this author (update or insert) + return + [ toSql (authorID a), -- return the author as a list of SqlValues + toSql (name a), + toSql (address a) + ] article1 :: Article article1 = diff --git a/test/PostgresQuerySpec.hs b/test/PostgresQuerySpec.hs --- a/test/PostgresQuerySpec.hs +++ b/test/PostgresQuerySpec.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DeriveAnyClass #-} -module PostgresQuerySpec -( test -, spec -) -where +module PostgresQuerySpec + ( test, + spec, + ) +where import Database.GP import Database.GP.SqlGenerator @@ -12,15 +11,15 @@ import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec prepareDB :: IO Conn prepareDB = do - conn <- connect ExplicitCommit <$> connectPostgreSQL "host=localhost dbname=postgres user=postgres password=admin port=5431" - setupTableFor @Person Postgres conn + conn <- connect ExplicitCommit <$> connectPostgreSQL "host=localhost dbname=postgres user=postgres password=admin port=5431" + setupTable @Person conn defaultPostgresMapping insertMany conn [alice, bob, charlie] commit conn @@ -36,7 +35,7 @@ deriving (Generic, Show, Eq) instance Entity Person where - autoIncrement = False + autoIncrement = False alice, bob, charlie, dave :: Person bob = Person 1 "Bob" 36 "West Street 79" @@ -50,10 +49,10 @@ addressField = field "address" lower :: Field -> Field -lower = sqlFun "LOWER"; +lower = sqlFun "LOWER" upper :: Field -> Field -upper = sqlFun "UPPER"; +upper = sqlFun "UPPER" spec :: Spec spec = do @@ -64,12 +63,12 @@ length one `shouldBe` 1 head one `shouldBe` bob commit conn - -- TODO: FIXME + -- TODO: FIXME it "supports disjunction with ||." $ do conn <- prepareDB two <- select @Person conn (nameField =. "Bob" ||. ageField =. (25 :: Int)) length two `shouldBe` 2 - two `shouldContain` [alice,bob] + two `shouldContain` [alice, bob] commit conn it "supports LIKE" $ do conn <- prepareDB @@ -77,7 +76,7 @@ length three `shouldBe` 3 commit conn it "supports NOT" $ do - conn <- prepareDB + conn <- prepareDB empty <- select conn (not' $ addressField `like` "West Street %") :: IO [Person] length empty `shouldBe` 0 commit conn @@ -119,7 +118,7 @@ commit conn it "supports SQL functions on columns" $ do conn <- prepareDB - peopleFromWestStreet <- select conn (lower(upper addressField) `like` "west street %") :: IO [Person] + peopleFromWestStreet <- select conn (lower (upper addressField) `like` "west street %") :: IO [Person] length peopleFromWestStreet `shouldBe` 3 commit conn it "supports selection by id" $ do @@ -130,14 +129,14 @@ commit conn it "supports ORDER BY" $ do conn <- prepareDB - sortedPersons <- select @Person conn (allEntries `orderBy` (ageField,ASC) :| []) + sortedPersons <- select @Person conn (allEntries `orderBy` (ageField, ASC) :| []) length sortedPersons `shouldBe` 3 sortedPersons `shouldBe` [alice, charlie, bob] commit conn it "supports multiple columns in ORDER BY" $ do conn <- prepareDB _ <- insert conn dave -- dave and charlie have the same age - sortedPersons <- select @Person conn (allEntries `orderBy` (ageField,ASC) :| [(nameField,DESC)]) + sortedPersons <- select @Person conn (allEntries `orderBy` (ageField, ASC) :| [(nameField, DESC)]) length sortedPersons `shouldBe` 4 sortedPersons `shouldBe` [alice, dave, charlie, bob] commit conn @@ -150,34 +149,33 @@ it "supports LIMIT OFFSET" $ do conn <- prepareDB _ <- insert conn dave - limitedPersons <- select @Person conn (allEntries `limitOffset` (2,1)) + limitedPersons <- select @Person conn (allEntries `limitOffset` (2, 1)) length limitedPersons `shouldBe` 1 head limitedPersons `shouldBe` charlie commit conn it "can create column types for a SqlLite" $ do - columnTypeFor @SomeRecord SQLite "someRecordID" `shouldBe` "INTEGER" - columnTypeFor @SomeRecord SQLite "someRecordName" `shouldBe` "TEXT" - columnTypeFor @SomeRecord SQLite "someRecordAge" `shouldBe` "REAL" - columnTypeFor @SomeRecord SQLite "someRecordTax" `shouldBe` "REAL" - columnTypeFor @SomeRecord SQLite "someRecordFlag" `shouldBe` "INT" - columnTypeFor @SomeRecord SQLite "someRecordDate" `shouldBe` "TEXT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordID" `shouldBe` "INTEGER" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordName" `shouldBe` "TEXT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordAge" `shouldBe` "REAL" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordTax" `shouldBe` "REAL" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordFlag" `shouldBe` "INT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordDate" `shouldBe` "TEXT" it "can create column types for a Postgres" $ do - columnTypeFor @SomeRecord Postgres "someRecordID" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordName" `shouldBe` "varchar" - columnTypeFor @SomeRecord Postgres "someRecordAge" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordTax" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordFlag" `shouldBe` "boolean" - columnTypeFor @SomeRecord Postgres "someRecordDate" `shouldBe` "varchar" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordID" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordName" `shouldBe` "varchar" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordAge" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordTax" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordFlag" `shouldBe` "boolean" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordDate" `shouldBe` "varchar" it "can create whereclauses" $ do whereClauseValues byIdColumn `shouldBe` [] - + data SomeRecord = SomeRecord - { someRecordID :: Int, + { someRecordID :: Int, someRecordName :: String, - someRecordAge :: Double, - someRecordTax :: Float, + someRecordAge :: Double, + someRecordTax :: Float, someRecordFlag :: Bool, someRecordDate :: Integer } deriving (Generic, Entity, Show, Eq) - diff --git a/test/PostgresSpec.hs b/test/PostgresSpec.hs --- a/test/PostgresSpec.hs +++ b/test/PostgresSpec.hs @@ -1,5 +1,4 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module PostgresSpec ( test, @@ -7,24 +6,24 @@ ) where +import Control.Exception import Database.GP import Database.HDBC.PostgreSQL -import GHC.Generics hiding (Selector) +import GHC.Generics hiding (Selector) import Test.Hspec -import Control.Exception -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec prepareDB :: IO Conn prepareDB = do - con <- connect AutoCommit <$> connectPostgreSQL "host=localhost dbname=postgres user=postgres password=admin port=5431" - let conn = con{implicitCommit=False} - setupTableFor @Person Postgres conn - setupTableFor @Book Postgres conn + conn <- connect ExplicitCommit <$> connectPostgreSQL "host=localhost dbname=postgres user=postgres password=admin port=5431" + setupTable @Person conn defaultPostgresMapping + setupTable @Book conn defaultPostgresMapping + setupTable @Boat conn defaultPostgresMapping _ <- run conn "DROP TABLE IF EXISTS Car;" [] _ <- run conn "CREATE TABLE Car (carID serial4 PRIMARY KEY, carType varchar);" [] commit conn @@ -40,14 +39,23 @@ deriving (Generic, Show, Eq) instance Entity Person where - autoIncrement = False + autoIncrement = False data Car = Car - { carID :: Int, - carType :: String + { carID :: Int, + carType :: String } deriving (Generic, Entity, Show, Eq) +data Boat = Boat + { boatID :: Int, + boatType :: String + } + deriving (Generic, Show, Eq) + +instance Entity Boat where + autoIncrement = False + data Book = Book { book_id :: Int, title :: String, @@ -62,8 +70,13 @@ instance Entity Book where idField = "book_id" - fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), - ("year", "bookYear"), ("category", "bookCategory")] + fieldsToColumns = + [ ("book_id", "bookId"), + ("title", "bookTitle"), + ("author", "bookAuthor"), + ("year", "bookYear"), + ("category", "bookCategory") + ] tableName = "BOOK_TBL" fromRow _c row = pure $ Book (col 0) (col 1) (col 2) (col 3) (col 4) where @@ -111,15 +124,15 @@ person' <- selectById conn (1 :: Int) :: IO (Maybe Person) person' `shouldBe` Nothing commit conn - it "selectById throws a DatabaseError if things go wrong in the DB" $ do + it "selectById throws a DatabaseError if things go wrong in the DB" $ do conn <- prepareDB runRaw conn "DROP TABLE Person;" commit conn eitherEA <- try (selectById conn (1 :: Int) :: IO (Maybe Person)) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "does not exist" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" rollback conn it "retrieves Entities using user implementation" $ do conn <- prepareDB @@ -132,22 +145,22 @@ length allBooks `shouldBe` 3 head allBooks `shouldBe` hobbit book' <- selectById conn (1 :: Int) :: IO (Maybe Book) - book' `shouldBe` Just hobbit + book' `shouldBe` Just hobbit commit conn it "select returns Nothing if no Entity was found" $ do conn <- prepareDB allPersons' <- select @Person conn allEntries allPersons' `shouldBe` [] commit conn - it "select throws a DatabaseError if things go wrong" $ do + it "select throws a DatabaseError if things go wrong" $ do conn <- prepareDB runRaw conn "DROP TABLE Person;" commit conn eitherEA <- try (select @Person conn allEntries) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "does not exist" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" rollback conn it "persists new Entities using Generics" $ do conn <- prepareDB @@ -171,24 +184,24 @@ book' <- selectById conn (1 :: Int) :: IO (Maybe Book) book' `shouldBe` Just book commit conn - it "persist throws an exception if things go wrong" $ do + it "persist throws an exception if things go wrong" $ do conn <- prepareDB runRaw conn "DROP TABLE BOOK_TBL;" commit conn eitherEA <- try (persist conn book) case eitherEA of Left (DatabaseError msg) -> msg `shouldContain` "does not exist" - Left _ -> expectationFailure "Expected DatabaseError" - Right _ -> expectationFailure "Expected DatabaseError" + Left _ -> expectationFailure "Expected DatabaseError" + Right _ -> expectationFailure "Expected DatabaseError" it "persists existing Entities using Generics" $ do conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] length allPersons `shouldBe` 0 - persist conn person + upsert conn person commit conn allPersons' <- select conn allEntries :: IO [Person] length allPersons' `shouldBe` 1 - persist conn person {age = 26} + upsert conn person {age = 26} commit conn person' <- selectById conn (123456 :: Int) :: IO (Maybe Person) person' `shouldBe` Just person {age = 26} @@ -203,11 +216,39 @@ length allbooks' `shouldBe` 1 eitherEA <- try $ persist conn book {year = 1938} :: IO (Either PersistenceException ()) case eitherEA of - Left _ -> expectationFailure "should not throw an exception" + Left _ -> expectationFailure "should not throw an exception" Right x -> x `shouldBe` () book' <- selectById conn (1 :: Int) :: IO (Maybe Book) book' `shouldBe` Just book {year = 1938} commit conn + it "can upsert Entities with AutoIncrement" $ do + conn <- prepareDB + let car = Car 1 "Honda Jazz" + -- insert the car + upsert conn car + car' <- selectById conn (1 :: Int) :: IO (Maybe Car) + car' `shouldBe` Just car + -- now update the car + let car2 = Car 1 "Honda Civic" + upsert conn car2 + car2' <- selectById conn (1 :: Int) :: IO (Maybe Car) + car2' `shouldBe` Just car2 + commit conn + + it "can upsert Entities without autoIncrement" $ do + conn <- prepareDB + let boat = Boat 1 "Sailboat" + -- insert the boat + upsert conn boat + boat' <- selectById conn (1 :: Int) :: IO (Maybe Boat) + boat' `shouldBe` Just boat + -- now update the boat + let boat2 = Boat 1 "Motorboat" + upsert conn boat2 + boat2' <- selectById conn (1 :: Int) :: IO (Maybe Boat) + boat2' `shouldBe` Just boat2 + commit conn + it "inserts Entities using Generics" $ do conn <- prepareDB allPersons <- select conn allEntries :: IO [Person] @@ -255,7 +296,7 @@ insertMany conn manyPersons commit conn allPersons' <- select conn allEntries :: IO [Person] - length allPersons' `shouldBe` 6 + length allPersons' `shouldBe` 6 deleteMany conn allPersons' commit conn allPersons'' <- select conn allEntries :: IO [Person] @@ -271,7 +312,7 @@ length allbooks' `shouldBe` 1 book' <- selectById conn (1 :: Int) :: IO (Maybe Book) book' `shouldBe` Just book - commit conn + commit conn it "updates Entities using Generics" $ do conn <- prepareDB _ <- insert conn person @@ -307,9 +348,9 @@ length allBooks' `shouldBe` 0 commit conn it "provides a Connection Pool" $ do - connPool <- postgreSQLPool "host=localhost dbname=postgres user=postgres password=admin port=5431" + connPool <- postgreSQLPool "host=localhost dbname=postgres user=postgres password=admin port=5431" withResource connPool $ \conn -> do - setupTableFor @Person Postgres conn + setupTable @Person conn defaultPostgresMapping _ <- insert conn person allPersons <- select conn allEntries :: IO [Person] length allPersons `shouldBe` 1 diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE DeriveAnyClass #-} -module QuerySpec -( test -, spec -) -where +module QuerySpec + ( test, + spec, + ) +where import Database.GP import Database.GP.SqlGenerator -import Database.HDBC.Sqlite3 ( connectSqlite3 ) +import Database.HDBC.Sqlite3 (connectSqlite3) import GHC.Generics import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -20,7 +19,7 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Person SQLite conn + setupTable @Person conn defaultSqliteMapping insertMany conn [alice, bob, charlie] return conn @@ -49,10 +48,10 @@ addressField = field "address" lower :: Field -> Field -lower = sqlFun "LOWER"; +lower = sqlFun "LOWER" upper :: Field -> Field -upper = sqlFun "UPPER"; +upper = sqlFun "UPPER" spec :: Spec spec = do @@ -72,7 +71,7 @@ three <- select conn (addressField `like` "West Street %") :: IO [Person] length three `shouldBe` 3 it "supports NOT" $ do - conn <- prepareDB + conn <- prepareDB empty <- select conn (not' $ addressField `like` "West Street %") :: IO [Person] length empty `shouldBe` 0 it "supports fieldwise comparisons like >" $ do @@ -108,7 +107,7 @@ length allPersons `shouldBe` 3 it "supports SQL functions on columns" $ do conn <- prepareDB - peopleFromWestStreet <- select conn (lower(upper addressField) `like` "west street %") :: IO [Person] + peopleFromWestStreet <- select conn (lower (upper addressField) `like` "west street %") :: IO [Person] length peopleFromWestStreet `shouldBe` 3 it "supports selection by id" $ do conn <- prepareDB @@ -117,13 +116,13 @@ head charlie' `shouldBe` charlie it "supports ORDER BY" $ do conn <- prepareDB - sortedPersons <- select @Person conn (allEntries `orderBy` (ageField,ASC) :| []) + sortedPersons <- select @Person conn (allEntries `orderBy` (ageField, ASC) :| []) length sortedPersons `shouldBe` 3 sortedPersons `shouldBe` [alice, charlie, bob] it "supports multiple columns in ORDER BY" $ do conn <- prepareDB _ <- insert conn dave -- dave and charlie have the same age - sortedPersons <- select @Person conn (allEntries `orderBy` (ageField,ASC) :| [(nameField,DESC)]) + sortedPersons <- select @Person conn (allEntries `orderBy` (ageField, ASC) :| [(nameField, DESC)]) length sortedPersons `shouldBe` 4 sortedPersons `shouldBe` [alice, dave, charlie, bob] it "supports LIMIT" $ do @@ -134,33 +133,42 @@ it "supports LIMIT OFFSET" $ do conn <- prepareDB _ <- insert conn dave - limitedPersons <- select @Person conn (allEntries `limitOffset` (2,1)) + limitedPersons <- select @Person conn (allEntries `limitOffset` (2, 1)) length limitedPersons `shouldBe` 1 head limitedPersons `shouldBe` charlie it "can create column types for a SqlLite" $ do - columnTypeFor @SomeRecord SQLite "someRecordID" `shouldBe` "INTEGER" - columnTypeFor @SomeRecord SQLite "someRecordName" `shouldBe` "TEXT" - columnTypeFor @SomeRecord SQLite "someRecordAge" `shouldBe` "REAL" - columnTypeFor @SomeRecord SQLite "someRecordTax" `shouldBe` "REAL" - columnTypeFor @SomeRecord SQLite "someRecordFlag" `shouldBe` "INT" - columnTypeFor @SomeRecord SQLite "someRecordDate" `shouldBe` "TEXT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordID" `shouldBe` "INTEGER" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordName" `shouldBe` "TEXT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordAge" `shouldBe` "REAL" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordTax" `shouldBe` "REAL" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordFlag" `shouldBe` "INT" + columnTypeFor @SomeRecord defaultSqliteMapping "someRecordDate" `shouldBe` "TEXT" it "can create column types for a Postgres" $ do - columnTypeFor @SomeRecord Postgres "someRecordID" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordName" `shouldBe` "varchar" - columnTypeFor @SomeRecord Postgres "someRecordAge" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordTax" `shouldBe` "numeric" - columnTypeFor @SomeRecord Postgres "someRecordFlag" `shouldBe` "boolean" - columnTypeFor @SomeRecord Postgres "someRecordDate" `shouldBe` "varchar" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordID" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordName" `shouldBe` "varchar" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordAge" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordTax" `shouldBe` "numeric" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordFlag" `shouldBe` "boolean" + columnTypeFor @SomeRecord defaultPostgresMapping "someRecordDate" `shouldBe` "varchar" it "can create whereclauses" $ do whereClauseValues byIdColumn `shouldBe` [] - + it "allows to write custom SQL queries" $ do + conn <- prepareDB + _ <- insert conn dave + let stmt = [sql| + SELECT * + FROM person + WHERE name = (?)|] + persons <- entitiesFromRows @Person conn =<< quickQuery conn stmt [toSql "Dave"] + length persons `shouldBe` 1 + head persons `shouldBe` dave + data SomeRecord = SomeRecord - { someRecordID :: Int, + { someRecordID :: Int, someRecordName :: String, - someRecordAge :: Double, - someRecordTax :: Float, + someRecordAge :: Double, + someRecordTax :: Float, someRecordFlag :: Bool, someRecordDate :: Integer } deriving (Generic, Entity, Show, Eq) - diff --git a/test/ReferenceSpec.hs b/test/ReferenceSpec.hs --- a/test/ReferenceSpec.hs +++ b/test/ReferenceSpec.hs @@ -1,6 +1,3 @@ --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} - module ReferenceSpec ( test, spec, @@ -15,7 +12,7 @@ import Test.Hspec -- `test` is here so that this module can be run from GHCi on its own. It is --- not needed for automatic spec discovery. +-- not needed for automatic spec discovery. -- (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec @@ -23,8 +20,8 @@ prepareDB :: IO Conn prepareDB = do conn <- connect AutoCommit <$> connectSqlite3 ":memory:" - setupTableFor @Article SQLite conn - setupTableFor @Author SQLite conn + setupTable @Article conn defaultSqliteMapping + setupTable @Author conn defaultSqliteMapping return conn data Article = Article @@ -43,35 +40,44 @@ deriving (Generic, Show, Eq) instance Entity Author where - autoIncrement = False + autoIncrement = False instance Entity Article where autoIncrement :: Bool autoIncrement = False - - fieldsToColumns :: [(String, String)] -- ommitting the author field, - fieldsToColumns = -- as this can not be mapped to a single column - [ ("articleID", "articleID"), -- instead we invent a new column authorID + + fieldsToColumns :: [(String, String)] -- ommitting the author field, + fieldsToColumns = + -- as this can not be mapped to a single column + [ ("articleID", "articleID"), -- instead we invent a new column authorID ("title", "title"), ("authorID", "authorID"), ("year", "year") ] fromRow :: Conn -> [SqlValue] -> IO Article - fromRow conn row = do - authorById <- fromJust <$> selectById conn (row !! 2) -- load author by foreign key - return $ rawArticle {author = authorById} -- add author to article + fromRow conn row = do + authorById <- fromJust <$> selectById conn (row !! 2) -- load author by foreign key + return $ rawArticle {author = authorById} -- add author to article where - rawArticle = Article (col 0) (col 1) -- create article from row, - (Author (col 2) "" "") (col 3) -- using a dummy author + rawArticle = + Article + (col 0) + (col 1) -- create article from row, + (Author (col 2) "" "") + (col 3) -- using a dummy author where col i = fromSql (row !! i) toRow :: Conn -> Article -> IO [SqlValue] toRow conn a = do - persist conn (author a) -- persist author first - return [toSql (articleID a), toSql (title a), -- return row for article table where - toSql $ authorID (author a), toSql (year a)] -- authorID is foreign key to author table + persist conn (author a) -- persist author first + return + [ toSql (articleID a), + toSql (title a), -- return row for article table where + toSql $ authorID (author a), + toSql (year a) -- authorID is foreign key to author table + ] article :: Article article =