diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,13 @@ -# GenericPersistence - A Haskell persistence layer using Generics and Reflection +# GenericPersistence - A Haskell Persistence Layer using Generics [![Actions Status](https://github.com/thma/generic-persistence/workflows/Haskell%20CI/badge.svg)](https://github.com/thma/generic-persistence/actions) -![GP Logo](gp-logo-300.png) +![GP Logo](https://github.com/thma/generic-persistence/blob/main/gp-logo-300.png?raw=true) ## Introduction -GenericPersistence is a minimalistic Haskell persistence layer (on top of HDBC). -The approach relies on Generics (`Data.Data`, `Data.Typeable`) and Reflection (`Type.Reflection`). +GenericPersistence is a minimalistic Haskell persistence layer for relational databases. +The approach relies on [GHC.Generics](https://hackage.haskell.org/package/base-4.17.0.0/docs/GHC-Generics.html). The actual database access is provided by the [HDBC](https://hackage.haskell.org/package/HDBC) library. The *functional goal* of the persistence layer is to provide hassle-free RDBMS persistence for Haskell data types in Record notation (for brevity I call them *Entities*). @@ -25,13 +25,20 @@ In an ideal world we would be able to take any POHO (Plain old Haskell Object) and persist it to any RDBMS without any additional effort. -A lot of things are still missing: +## Status +The library is in an early stage of development. All test cases are green and it should be ready for early adopters. +Several things are still missing: + - A query language -- Handling of nested transactions - Handling auto-incrementing primary keys +- caching +- coding free support for 1:1 and 1:n relationships (using more generics magic) +- schema migration - ... +Feature requests, feedback and pull requests are welcome! + ## Available on Hackage [https://hackage.haskell.org/package/generic-persistence](https://hackage.haskell.org/package/generic-persistence) @@ -43,24 +50,28 @@ - generic-persistence ``` +I would also recommend to add the setting `language: GHC2021` to your `package.yaml` file: + +```yaml +language: GHC2021 +``` + +This drastically reduces the amount of LANGUAGE extensions that need to be added to your source files. + + ## Short demo Here now follows a short demo that shows how the library looks and feels from the user's point of view. ```haskell --- allows automatic derivation from Entity type class -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class module Main (main) where -import Data.Data (Data) -import Database.GP (Entity (..), GP, delete, insert, liftIO, - persist, retrieveAll, retrieveById, - runGP, setupTableFor, update) -import Database.HDBC (IConnection (disconnect), fromSql, - toSql) -import Database.HDBC.Sqlite3 (connectSqlite3) - +import Database.GP +import Database.HDBC +import Database.HDBC.Sqlite3 +import GHC.Generics -- | An Entity data type with several fields, using record syntax. data Person = Person @@ -69,86 +80,167 @@ age :: Int, address :: String } - deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence + deriving (Generic, Entity, Show) -- deriving Entity allows us to use the GenericPersistence API -data Book = Book - { book_id :: Int, - title :: String, - author :: String, - year :: Int - } - deriving (Data, Show) -- no auto deriving of Entity, so we have to implement the Entity type class: -instance Entity Book where - -- this is the primary key field of the Book data type - idField _ = "book_id" +main :: IO () +main = do + -- connect to a database + conn <- connect SQLite <$> connectSqlite3 "sqlite.db" - -- this defines the mapping between the field names of the Book data type and the column names of the database table - fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")] + -- initialize Person table + setupTableFor @Person conn - -- this is the name of the database table - tableName _ = "BOOK_TBL" + -- create a Person entity + let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} - -- this is the function that converts a row from the database table into a Book data type - fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) - where - col i = fromSql (row !! i) + -- insert a Person into a database + insert conn alice - -- this is the function that converts a Book data type into a row for the database table - toRow b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)] + -- update a Person + update conn alice {address = "Main Street 200"} -main :: IO () -main = do - -- connect to a database - conn <- connectSqlite3 "sqlite.db" - -- take the connection and execute all persistence operations in the GP monad (type alias for RIO Ctx) - runGP conn $ do - _ <- setupTableFor :: GP Person - _ <- setupTableFor :: GP Book + -- select a Person from a database + -- The result type must be provided by the call site, + -- as `retrieveEntityById` has a polymorphic return type `IO (Maybe a)`. + alice' <- retrieveById @Person conn "123456" + print alice' - let alice = Person 123456 "Alice" 25 "123 Main St" - book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 + -- select all Persons from a database + allPersons <- retrieveAll @Person conn + print allPersons - -- insert a Person into the database (persist will either insert or update) - persist alice + -- delete a Person from a database + delete conn alice - -- insert a second Person - persist alice {personID = 123457, name = "Bob"} + -- select all Persons from a database. Now it should be empty. + allPersons' <- retrieveAll conn :: IO [Person] + print allPersons' - -- update a Person - persist alice {address = "Elmstreet 1"} + -- close connection + disconnect conn +``` - -- select a Person from a database - alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ print alice' +## How it works - -- select all Persons from the database - allPersons <- retrieveAll :: GP [Person] - liftIO $ print allPersons +In order to store Haskell data types in a relational database, we need to define a mapping between Haskell types and database tables. +This mapping is defined by the `Entity` type class. This type class comes with default implementations for all methods which define +the standard behaviour. (The default implementations internally use `GHC.Generics`.) - -- delete a Person - delete alice +This default mapping will work for many cases, but it can be customized by overriding the default implementations. - -- select all Persons from a database. The deleted Person is not in the result. - allPersons' <- retrieveAll :: GP [Person] - liftIO $ print allPersons' +### The Entity type class - let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954} +The `Entity` type class specifies the following methods: - -- this time we are using insert directly - insert book - insert book2 - allBooks <- retrieveAll :: GP [Book] - liftIO $ print allBooks +```haskell +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 - -- explicitly updating a Book - update book2 {title = "The Lord of the Rings"} - delete book + -- | Converts a value of type 'a' to a database row. + toRow :: Conn -> a -> IO [SqlValue] - allBooks' <- retrieveAll :: GP [Book] - liftIO $ print allBooks' + -- | Returns the name of the primary key field for a type 'a'. + idField :: String + + -- | Returns a list of tuples that map field names to column names for a type 'a'. + fieldsToColumns :: [(String, String)] + + -- | Returns the name of the table for a type 'a'. + tableName :: String ``` +### Default Behaviour + +`idField`, `fieldsToColumns` and `tableName` are used to define the mapping between Haskell types and database tables. + +- The default implementations of `idField` returns a default value for the field name of the primary key field of a type `a`: +The type name in lower case, plus "ID". +E.g. `idField @Book` will return `"bookID"`. + +- `tableName` returns the name of the database table used for type `a`. The default implementation simply returns the constructor name of `a`. E.g. `tableName @Book` will return `"Book"`. + +- `fieldsToColumns` returns a list of tuples that map field names of type `a` to database column names for a type. The default implementation simply returns a list of tuples that map the field names of `a` to the field names of `a`. E.g. `fieldsToColumns @Person` will return `[("personID","personID"),("name","name"),("age","age"),("address","address")]`. + +`fromRow` and `toRow` are used to convert between Haskell types and database rows. + +- `fromRow` converts a database row, represented by a `[SqlValue]` to a value of type `a`. + +- `toRow` converts a value of type `a` to a `[SqlValue]`, representing a database row. + +The default implementations of `fromRow` and `toRow` expects that type `a` has a single constructor and a selector for each field. All fields are expected to have a 1:1 mapping to a column in the database table. +Thus each field must have a type that can be converted to and from a `SqlValue`. + +For example + +```haskell +toRow conn (Person {personID = 1234, name = "Alice", age = 27, address = "Elmstreet 1"}) +```` + +will return + +```haskell +[SqlInt64 1234,SqlString "Alice",SqlInt64 27,SqlString "Elmstreet 1"] +``` + +And `fromRow` does the inverse: +```haskell +fromRow conn [SqlInt64 1234,SqlString "Alice",SqlInt64 27,SqlString "Elmstreet 1"] :: IO Person +``` + +returns + +```haskell +Person {personID = 1234, name = "Alice", age = 27, address = "Elmstreet 1"} +``` + +The conversion functions `toRow` and `fromRow` both carry an additional `Conn` argument. This argument is not used by the default implementations, but it can be used to provide database access during the conversion process. We will cover this later. + +### Customizing the default behaviour + +The default implementations of `idField`, `fieldsToColumns`, `tableName`, `fromRow` and `toRow` can be customized by overriding the default implementations. +Overiding `idField`, `fieldsToColumns` and `tableName` will be required when your database tables do not follow the default naming conventions. + +For example, if we have a database table `BOOK_TBL` with the following columns: + +```sql +CREATE TABLE BOOK_TBL + ( bookId INTEGER PRIMARY KEY, + bookTitle TEXT, + bookAuthor TEXT, + bookYear INTEGER + ); +``` +and we want to map this table to a Haskell data type `Book`: + +```haskell +data Book = Book + { book_id :: Int, + title :: String, + author :: String, + year :: Int + } + deriving (Generic, Show) +``` + +Then we can customize the default implementations of `idField`, `fieldsToColumns` and `tableName` to achieve the desired mapping: + +```haskell +instance Entity Book where + -- this is the primary key field of the Book data type (not following the default naming convention) + idField = "book_id" + + -- this defines the mapping between the field names of the Book data type and the column names of the database table + fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")] + + -- this is the name of the database table + tableName = "BOOK_TBL" +``` + +Overriding `fromRow` and `toRow` will be required when your database tables do not follow the default mapping conventions. +We will see some examples in later sections. + ## Handling enumeration fields Say we have a data type `Book` with an enumeration field of type `BookCategory`: @@ -161,31 +253,19 @@ year :: Int, category :: BookCategory } - deriving (Data, Show) + deriving (Generic, Entity, Show) data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other - deriving (Data, Show, Enum) -``` - -In this case the `Entity` type class instance for `Book` has to be implemented manually, -as the automatic derivation of `Entity` does not cover this case (yet) - -```haskell -instance Entity Book where - fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) (col 4) - where - col i = fromSql (row !! i) - - toRow b = return [toSql (bookID b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)] + deriving (Generic, Show, Enum) ``` -`toSql` and `fromSql` expect `Convertible` instances as arguments. This works for `BookCatagory` as GenericPersistence provides `Convertible` instances for all `Enum` types. +In this case everything works out of the box, because *GenericPersistence* provides `Convertible` instances for all `Enum` types. `Convertible` instances are used to convert between Haskell types and database types. -If you do not want to use `Enum` types for your enumeration fields, you can implement `Convertible` instances for your own types: +If you do not want to use `Enum` types for your enumeration fields, you have to implement `Convertible` instances manually: ```haskell data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other - deriving (Data, Show, Read) + deriving (Generic, Show, Read) instance Convertible BookCategory SqlValue where safeConvert = Right . toSql . show @@ -196,7 +276,7 @@ ## Handling embedded Objects -Say we have a data type `Article` with an field of type `Author`: +Say we have a data type `Article` with a field of type `Author`: ```haskell data Article = Article @@ -205,14 +285,14 @@ author :: Author, year :: Int } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) data Author = Author { authorID :: Int, name :: String, address :: String } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) ``` If we don't want to store the `Author` as a separate table, we can use the following approach to embed the `Author` into the `Article` table: @@ -221,26 +301,26 @@ instance Entity Article where -- in the fields to column mapping we specify that all fields of the -- Author type are also mapped to columns of the Article table: - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), + fieldsToColumns :: [(String, String)] + fieldsToColumns = [("articleID", "articleID"), ("title", "title"), ("authorID", "authorID"), ("authorName", "authorName"), ("authorAddress", "authorAddress"), ("year", "year") - ] + ] -- in fromRow we have to manually construct the Author object from the -- respective columns of the Article table and insert it -- into the Article object: - fromRow row = return $ Article (col 0) (col 1) author (col 5) + fromRow _conn row = return $ Article (col 0) (col 1) author (col 5) where col i = fromSql (row !! i) author = Author (col 2) (col 3) (col 4) -- in toRow we have to manually extract the fields of the Author object -- and insert them into the respective columns of the Article table: - toRow a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)] + toRow _conn a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)] where authID = authorID (author a) authorName = name (author a) @@ -258,127 +338,153 @@ author :: Author, year :: Int } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) data Author = Author { authorID :: Int, name :: String, address :: String } - deriving (Data, Entity, Show, Eq) -- we derive Entity for Author + deriving (Generic, Entity, Show, Eq) + instance Entity Article where - -- in the fields to column mapping we specify an additional authorID field - -- that will be used to store the id of the referenced Author object: - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), - ("title", "title"), - ("authorID", "authorID"), - ("year", "year") - ] + 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") + ] - -- in fromRow we have to manually retrieve the Author object from the - -- database (by using authorID as a foreign key) - fromRow row = do - maybeAuthor <- retrieveById (row !! 2) :: GP (Maybe Author) - let author = fromJust maybeAuthor - pure $ Article (col 0) (col 1) author (col 3) + fromRow :: Conn -> [SqlValue] -> IO Article + fromRow conn row = do + authorById <- fromJust <$> retrieveById conn (row !! 2) -- load author by foreign key + return $ rawArticle {author = authorById} -- add author to article where - col i = fromSql (row !! i) - - -- in toRow we have manually persist the Author object and include - -- the authorID of the Author object in the Article row: - toRow a = do - persist (author a) - return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)] + 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 ``` + +Persisting the `Author`as a side effect in `toRow` may sound like an *interesting* idea... +This step is optional. But then the user has to make sure that the `Author` is persisted before the `Article` is persisted. + + ## Handling 1:n references -Now let's extend the previous example by also having a list of Àrticle`s in the `Author` type: +Now let's change the previous example by having a list of Articles in the `Author` type: ```haskell -data Article = Article - { articleID :: Int, - title :: String, - author :: Author, - year :: Int - } - deriving (Data, Show, Eq) - data Author = Author { authorID :: Int, name :: String, address :: String, articles :: [Article] } - deriving (Data, Show, Eq) -``` - -So now we have a 1:n relationship between `Author` and `Article`. And in addtion we have the 1:1 relationship between `Article` and `Author` that we have seen in the previous example. + deriving (Generic, Show, Eq) -This situation is a bit more complicated, as we have to handle relationships between `Article` and `Author` at the same time. And we have to make sure that we don't end up in an infinite loop when we persist an `Author` object that contains a list of `Article` objects that in turn contain the same `Author` object. +data Article = Article + { articleID :: Int, + title :: String, + authorId :: Int, + year :: Int + } + deriving (Generic, Entity, Show, Eq) +``` -The same problem occurs when we retrieve an `Author` object that contains a list of `Article` objects that in turn contain the same `Author` object. +So now we have a `1:n` relationship between `Author` and `Article`. -We can handle this situation by using the following approach: +We can handle this situation by using the following instance declaration for `Author`: ```haskell -instance Entity Article where - -- in the fields to column mapping we specify an additional authorID field: - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), - ("title", "title"), - ("authorID", "authorID"), - ("year", "year") - ] +instance Entity Author where + fieldsToColumns :: [(String, String)] -- ommitting the articles field, + fieldsToColumns = -- as this can not be mapped to a single column + [ ("authorID", "authorID"), + ("name", "name"), + ("address", "address") + ] - -- in fromRow we have to take care that we don't end up in an infinite loop - -- so we first place a dummy Article object into the cache and then - -- retrieve the Author object either from cache or from the db: - fromRow :: [SqlValue] -> GP Article - fromRow row = local (extendCtxCache rawArticle) $ do - maybeAuthor <- getElseRetrieve (entityId rawAuthor) - let author = fromJust maybeAuthor - pure $ Article (col 0) (col 1) author (col 3) + fromRow :: Conn -> [SqlValue] -> IO Author + fromRow conn row = do + let authID = head row -- authorID is the first column + articlesBy <- retrieveAllWhere conn "authorId" authID -- retrieve all articles by this author + return rawAuthor {articles = articlesBy} -- add the articles to the author where - col i = fromSql (row !! i) - rawAuthor = (evidence :: Author) {authorID = col 2} - rawArticle = Article (col 0) (col 1) rawAuthor (col 3) - - toRow a = do - persist (author a) - return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)] + 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)] +``` -instance Entity Author where - -- in the fields to column mapping we have anything for the articles field: - fieldsToColumns :: Author -> [(String, String)] - fieldsToColumns _ = [("authorID", "authorID"), - ("name", "name"), - ("address", "address") - ] +Persisting all articles of an author as a side effect during the conversion of the author to a row may seem *special*... +You can ommit this step. But then you have to persist the articles manually before persisting the author. - -- in fromRow we have to take care that we don't end up in an infinite loop. - -- So we first place a dummy Author object into the cache and then - -- retrieve matching list of Article objects (from cache or from the db): - fromRow :: [SqlValue] -> GP Author - fromRow row = local (extendCtxCache rawAuthor) $ do - articlesByAuth <- retrieveAllWhere (idField rawAuthor) (idValue rawAuthor) :: GP [Article] - pure $ rawAuthor {articles= articlesByAuth} - where - col i = fromSql (row !! i) - rawAuthor = Author (col 0) (col 1) (col 2) [] +## Integrating user defined queries - -- in toRow we do not safe the articles field to avoid infinite loops: - toRow :: Author -> GP [SqlValue] - toRow a = do - return [toSql (authorID a), toSql (name a), toSql (address a)] +As of now, the library only supports very basic support for queries: + +- `retrieveById` retrieves a single row of a table by its primary key +- `retrieveAll` retrieves all rows of a table +- `retrieveAllWhere` retrieves all rows of a table where a given column has a given value + +If you want to use more complex queries, you can integrate HDBC SQL queries by using the `entitiesFromRows` function as in the following example: + +```haskell +main :: IO () +main = do + -- connect to a database + conn <- connect SQLite <$> connectSqlite3 ":memory:" + + -- initialize Person table + setupTableFor @Person conn + + let alice = Person 1 "Alice" 25 "123 Main St" + bob = Person 2 "Bob" 30 "456 Elm St" + charlie = Person 3 "Charlie" 35 "789 Pine St" + dave = Person 4 "Dave" 40 "1011 Oak St" + eve = Person 5 "Eve" 45 "1213 Maple St" + frank = Person 6 "Frank" 50 "1415 Walnut St" + people = [alice, bob, charlie, dave, eve, frank] + + -- insert all persons into the database + insertMany conn people + + -- perform a custom query with HDBC + stmt = "SELECT * FROM Person WHERE age >= ?" + resultRows <- quickQuery conn stmt [toSql (40 :: Int)] + + -- convert the resulting rows into a list of Person objects + fourtplussers <- entitiesFromRows @Person conn resultRows + print fourtplussers ``` -## Todo +Of course this approach is not type safe. It is up to the user to make sure that the query returns the correct columns. -- coding free support for 1:1 and 1:n relationships -- coding free support for Enums -- resolution cache with proper Map +## The `Conn` Connection Type + +The `Conn` type is a wrapper around an `IConnection` obtained from an HDBC backend driver like `HDBC-sqlite3` or `hdbc-postgresql`. It is used to pass the connection to the database to *Generic-Persistence*. All functions of the library that require a database connection take a `Conn` as an argument. + +HDBC provides a very similar type called `ConnectionWrapper`. The main reason for such a wrapper type is to simplify the type signatures of the library functions. + +In addition, the `Conn` type provides additional database related information that is not available in the `ConnectionWrapper` type. For example, the `Conn` type contains the name of the database driver that is used. This information can be used to generate the correct SQL statements for different database backends. +`Conn` also carries a flag that indicates whether implicit commits should be used by the library. This flag is set to `True` by default. If you want to use explicit commits, you can set the flag to `False` by modifying the `Conn` value: + +```haskell +c <- connect SQLite <$> connectSqlite3 ":memory:" +let conn = c {implicitCommit = False} +``` + diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,15 +1,12 @@ -- allows automatic derivation from Entity type class {-# LANGUAGE DeriveAnyClass #-} -module Main (main, main1) where +module Main (main, main1, main2, main3) where -import Data.Data (Data) -import Database.GP (Entity (..), GP, delete, insert, liftIO, - persist, retrieveAll, retrieveById, - runGP, setupTableFor, update) -import Database.HDBC (IConnection (disconnect), fromSql, - toSql) -import Database.HDBC.Sqlite3 (connectSqlite3) +import Database.GP +import Database.HDBC +import Database.HDBC.Sqlite3 +import GHC.Generics -- | An Entity data type with several fields, using record syntax. data Person = Person @@ -18,7 +15,7 @@ age :: Int, address :: String } - deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence + deriving (Generic, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence data Book = Book { book_id :: Int, @@ -26,76 +23,59 @@ author :: String, year :: Int } - deriving (Data, Show) -- no auto deriving of Entity, so we have to implement the Entity type class: + deriving (Generic, Show) -- no auto deriving of Entity, so we have to implement the Entity type class: instance Entity Book where -- this is the primary key field of the Book data type - idField _ = "book_id" + idField = "book_id" -- this defines the mapping between the field names of the Book data type and the column names of the database table - fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")] + fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")] -- this is the name of the database table - tableName _ = "BOOK_TBL" + tableName = "BOOK_TBL" - -- this is the function that converts a row from the database table into a Book data type - fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) - where - col i = fromSql (row !! i) + -- -- this is the function that converts a row from the database table into a Book data type + -- fromRow _c row = return $ Book (col 0) (col 1) (col 2) (col 3) + -- where + -- col i = fromSql (row !! i) - -- this is the function that converts a Book data type into a row for the database table - toRow b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)] + -- -- this is the function that converts a Book data type into a row for the database table + -- toRow _c b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)] main :: IO () main = do -- connect to a database - conn <- connectSqlite3 "sqlite.db" - -- take the connection and execute all persistence operations in the GP monad (type alias for RIO Ctx) - runGP conn $ do - _ <- setupTableFor :: GP Person - _ <- setupTableFor :: GP Book - - let alice = Person 123456 "Alice" 25 "123 Main St" - book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 - - -- insert a Person into the database (persist will either insert or update) - persist alice - - -- insert a second Person - persist alice {personID = 123457, name = "Bob"} - - -- update a Person - persist alice {address = "Elmstreet 1"} + conn <- connect SQLite <$> connectSqlite3 "sqlite.db" - -- select a Person from a database - alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ print alice' + -- initialize Person table + setupTableFor @Person conn - -- select all Persons from the database - allPersons <- retrieveAll :: GP [Person] - liftIO $ print allPersons + -- create a Person entity + let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} - -- delete a Person - delete alice + -- insert a Person into a database + insert conn alice - -- select all Persons from a database. The deleted Person is not in the result. - allPersons' <- retrieveAll :: GP [Person] - liftIO $ print allPersons' + -- update a Person + update conn alice {address = "Main Street 200"} - let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954} + -- select a Person from a database + -- The result type must be provided by the call site, + -- as `retrieveEntityById` has a polymorphic return type `IO (Maybe a)`. + alice' <- retrieveById @Person conn "123456" + print alice' - -- this time we are using insert directly - insert book - insert book2 - allBooks <- retrieveAll :: GP [Book] - liftIO $ print allBooks + -- select all Persons from a database + allPersons <- retrieveAll @Person conn + print allPersons - -- explicitly updating a Book - update book2 {title = "The Lord of the Rings"} - delete book + -- delete a Person from a database + delete conn alice - allBooks' <- retrieveAll :: GP [Book] - liftIO $ print allBooks' + -- select all Persons from a database. Now it should be empty. + allPersons' <- retrieveAll conn :: IO [Person] + print allPersons' -- close connection disconnect conn @@ -103,31 +83,103 @@ main1 :: IO () main1 = do -- connect to a database - conn <- connectSqlite3 "sqlite.db" - runGP conn $ do - -- initialize Person table - _ <- setupTableFor :: GP Person + conn <- Conn SQLite False <$> connectSqlite3 "test.db" -- ":memory:" - -- create a Person entity - let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} + -- initialize Person and Book tables + setupTableFor @Person conn + setupTableFor @Book conn - -- insert a Person into a database - persist alice + let alice = Person 123456 "Alice" 25 "123 Main St" + book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 - -- update a Person - persist alice {address = "Main Street 200"} + -- insert a Person into the database (persist will either insert or update) + persist conn alice - -- select a Person from a database - -- The result type must be provided explicitly, as `retrieveEntityById` has a polymorphic return type `IO a`. - alice' <- retrieveById "123456" :: GP (Maybe Person) - liftIO $ print alice' + -- insert a second Person + persist conn alice {personID = 123457, name = "Bob"} - alice'' <- retrieveById "123456" :: GP (Maybe Person) + -- update a Person + persist conn alice {address = "Elmstreet 1"} - liftIO $ print alice'' + -- select a Person from a database + alice' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person) + print alice' - -- delete a Person from a database - delete alice + -- select all Persons from the database + allPersons <- retrieveAll conn :: IO [Person] + print allPersons + -- delete a Person + delete conn alice + + -- select all Persons from a database. The deleted Person is not in the result. + allPersons' <- retrieveAll conn :: IO [Person] + print allPersons' + + let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954} + + -- this time we are using insert directly + insert conn book + insert conn book2 + allBooks <- retrieveAll conn :: IO [Book] + print allBooks + + -- explicitly updating a Book + update conn book2 {title = "The Lord of the Rings"} + delete conn book + + allBooks' <- retrieveAll conn :: IO [Book] + print allBooks' + -- close connection disconnect conn + + +main2 :: IO () +main2 = do + -- connect to a database + conn <- connect SQLite <$> connectSqlite3 ":memory:" + + -- initialize Person table + setupTableFor @Person conn + + let alice = Person 1 "Alice" 25 "123 Main St" + bob = Person 2 "Bob" 30 "456 Elm St" + charlie = Person 3 "Charlie" 35 "789 Pine St" + dave = Person 4 "Dave" 40 "1011 Oak St" + eve = Person 5 "Eve" 45 "1213 Maple St" + frank = Person 6 "Frank" 50 "1415 Walnut St" + people = [alice, bob, charlie, dave, eve, frank] + stmt = "SELECT * FROM Person WHERE age >= ?" + + -- insert all persons into the database + insertMany conn people + + -- select all Person with age >= 40 + resultRows <- quickQuery conn stmt [toSql (40 :: Int)] + fourtplussers <- entitiesFromRows @Person conn resultRows + print fourtplussers + +main3 :: IO () +main3 = do + -- connect to a database + conn <- connect SQLite <$> connectSqlite3 "test.db" + + -- initialize Person table + setupTableFor @Person conn + + let alice = Person 1 "Alice" 25 "123 Main St" + bob = Person 2 "Bob" 30 "456 Elm St" + charlie = Person 3 "Charlie" 35 "789 Pine St" + dave = Person 4 "Dave" 40 "1011 Oak St" + eve = Person 5 "Eve" 45 "1213 Maple St" + frank = Person 6 "Frank" 50 "1415 Walnut St" + people = [alice, bob, charlie, dave, eve, frank] + + -- insert all persons into the database + insertMany conn people + + people' <- retrieveAll @Person conn + print $ length people' + + 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.2.0.1 +version: 0.3.0.0 license: BSD3 license-file: LICENSE copyright: 2023 Thomas Mahler maintainer: thma@apache.org author: Thomas Mahler -tested-with: ghc ==9.2.5 ghc ==9.0.2 ghc ==8.10.7 +tested-with: ghc ==9.2.5 ghc ==9.4.4 homepage: https://github.com/thma/generic-persistence#readme bug-reports: https://github.com/thma/generic-persistence/issues synopsis: Database persistence using generics @@ -24,9 +24,9 @@ library exposed-modules: Database.GP + Database.GP.Conn Database.GP.Entity Database.GP.GenericPersistence - Database.GP.RecordtypeReflection Database.GP.SqlGenerator Database.GP.TypeInfo @@ -40,18 +40,9 @@ build-depends: HDBC <2.5, - HDBC-sqlite3 <2.4, base >=4.7 && <5, - bytestring <0.12, convertible <1.2, - exceptions <0.11, - ghc <9.3, - ghc-prim <0.9, - rio <0.2, - syb <0.8, - text <1.3, - time <1.12, - transformers <0.6 + generic-deriving <1.15 executable generic-persistence-demo main-is: Main.hs @@ -68,17 +59,9 @@ HDBC <2.5, HDBC-sqlite3 <2.4, base >=4.7 && <5, - bytestring <0.12, convertible <1.2, - exceptions <0.11, - generic-persistence, - ghc <9.3, - ghc-prim <0.9, - rio <0.2, - syb <0.8, - text <1.3, - time <1.12, - transformers <0.6 + generic-deriving <1.15, + generic-persistence test-suite generic-persistence-test type: exitcode-stdio-1.0 @@ -105,16 +88,8 @@ HDBC-sqlite3 <2.4, QuickCheck <2.15, base >=4.7 && <5, - bytestring <0.12, convertible <1.2, - exceptions <0.11, + generic-deriving <1.15, generic-persistence, - ghc <9.3, - ghc-prim <0.9, hspec <2.10, - hspec-discover <2.10, - rio <0.2, - syb <0.8, - text <1.3, - time <1.12, - transformers <0.6 + hspec-discover <2.10 diff --git a/src/Database/GP.hs b/src/Database/GP.hs --- a/src/Database/GP.hs +++ b/src/Database/GP.hs @@ -1,37 +1,31 @@ -module Database.GP ( retrieveById, +module Database.GP + ( retrieveById, retrieveAll, retrieveAllWhere, + entitiesFromRows, persist, insert, + insertMany, update, + updateMany, delete, setupTableFor, idValue, Entity (..), + GToRow, + GFromRow, columnNameFor, - fieldTypeFor, maybeFieldTypeFor, toString, - evidence, - evidenceFrom, - ResolutionCache, EntityId, entityId, - getElseRetrieve, TypeInfo (..), - typeInfoFromContext, typeInfo, - Ctx (..), - GP, - extendCtxCache, - runGP, - liftIO, - local, - ask, + Conn (..), + Database (..), + connect, ) where --- We are just re-exporting the functions from the GenericPersistence module. +-- We are just re-exporting from the GenericPersistence module. import Database.GP.GenericPersistence - - diff --git a/src/Database/GP/Conn.hs b/src/Database/GP/Conn.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP/Conn.hs @@ -0,0 +1,61 @@ +module Database.GP.Conn + ( Conn (..), + connect, + Database (..), + ) +where + +import Control.Monad ((>=>)) +import Database.HDBC hiding (withWConn) + +{-- + This module defines a wrapper around an HDBC IConnection. Using this wrapper `Conn` simplifies the signature of the functions in the `Database.GP` module. + It allows to use any HDBC connection without having to define a new function for each connection type. + It also provides additional attributes to the connection, like the database type and the implicit commit flag. + These attributes can be used to implement database specific functionality, modify transaction behaviour, etc. + + This code has been inspired by the HDBC ConnectionWrapper and some parts have been copied from the HDBC Database.HDBC.Types module. +--} + +-- | A wrapper around an HDBC IConnection. +data Conn = forall conn. + IConnection conn => + Conn + { -- | The database type + db :: Database, + -- | If True, the GenericPersistence functions will commit the transaction after each operation. + implicitCommit :: Bool, + -- | The wrapped connection + connection :: conn + } + +-- | An enumeration of the supported database types. +data Database = Postgres | MySQL | SQLite | Oracle | MSSQL + deriving (Show, Eq, Enum) + +-- | a smart constructor for the Conn type. +connect :: forall conn. IConnection conn => Database -> conn -> Conn +connect db = Conn db True + +-- | allows to execute a function that requires an `IConnection` argument on a `Conn`. +withWConn :: forall b. Conn -> (forall conn. IConnection conn => conn -> b) -> b +withWConn (Conn _db _ic conn) f = f conn + + +-- | manually implement the IConnection type class for the Conn type. +instance IConnection Conn where + disconnect w = withWConn w disconnect + commit w = withWConn w commit + rollback w = withWConn w rollback + runRaw w = withWConn w runRaw + run w = withWConn w run + prepare w = withWConn w prepare + clone w@(Conn db ic _) = withWConn w (clone >=> return . Conn db ic) + hdbcDriverName w = withWConn w hdbcDriverName + hdbcClientVer w = withWConn w hdbcClientVer + proxiedClientName w = withWConn w proxiedClientName + proxiedClientVer w = withWConn w proxiedClientVer + dbServerVer w = withWConn w dbServerVer + dbTransactionSupport w = withWConn w dbTransactionSupport + getTables w = withWConn w getTables + describeTable w = withWConn w describeTable 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 @@ -1,42 +1,50 @@ -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Database.GP.Entity ( Entity (..), columnNameFor, - fieldTypeFor, - maybeFieldTypeFor, toString, - evidence, - evidenceFrom, - ResolutionCache, EntityId, - Ctx (..), - GP, + gtoRow, + GToRow, + GFromRow, + maybeFieldTypeFor, + Conn(..), + Database(..), ) where import Data.Char (toLower) -import Data.Data -import Database.HDBC (SqlValue, fromSql, ConnWrapper) -import Database.GP.RecordtypeReflection (gFromRow, gToRow) -import Database.GP.TypeInfo -import Data.Dynamic -import RIO +import Data.Convertible +import Data.Kind +import Data.Typeable (Proxy (..), TypeRep) +import Database.GP.TypeInfo +import Database.HDBC (SqlValue) +import GHC.Generics +import GHC.TypeNats +import Generics.Deriving.Show (GShow' (..), gshowsPrecdefault) +import Database.GP.Conn {-- -This is the Entity class. It is a type class that is used to define the mapping +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 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 +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, +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. @@ -45,102 +53,128 @@ --} -class (Data a) => Entity a where + +class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where -- | Converts a database row to a value of type 'a'. - fromRow :: [SqlValue] -> GP a + fromRow :: Conn -> [SqlValue] -> IO a -- | Converts a value of type 'a' to a database row. - toRow :: a -> GP [SqlValue] + toRow :: Conn -> a -> IO [SqlValue] -- | Returns the name of the primary key field for a type 'a'. - idField :: a -> String + idField :: String -- | Returns a list of tuples that map field names to column names for a type 'a'. - fieldsToColumns :: a -> [(String, String)] + fieldsToColumns :: [(String, String)] -- | Returns the name of the table for a type 'a'. - tableName :: a -> String + tableName :: String - -- | generic default implementation - default fromRow :: [SqlValue] -> GP a - fromRow = pure . gFromRow + -- | fromRow generic default implementation + default fromRow :: (GFromRow (Rep a)) => Conn -> [SqlValue] -> IO a + fromRow _conn = pure . to <$> gfromRow - -- | generic default implementation - default toRow :: a -> GP [SqlValue] - toRow = pure . gToRow + -- | toRow generic default implementation + default toRow :: GToRow (Rep a) => Conn -> a -> IO [SqlValue] + toRow _ = pure . gtoRow . from - -- | default implementation: the ID field is the field with the same name + -- | idField default implementation: the ID field is the field with the same name -- as the type name in lower case and appended with "ID", e.g. "bookID" - default idField :: a -> String - idField = idFieldName . typeInfo + default idField :: String + idField = idFieldName where - idFieldName :: TypeInfo a -> String - idFieldName ti = map toLower (typeName ti) ++ "ID" - - -- | default implementation: the field names are used as column names - default fieldsToColumns :: a -> [(String, String)] - fieldsToColumns x = zip (fieldNames (typeInfo x)) (fieldNames (typeInfo x)) - - -- | default implementation: the type name is used as table name - default tableName :: a -> String - tableName = typeName . typeInfo - --- | type Ctx defines the context in which the persistence operations are executed. --- It contains a connection to the database and a resolution cache for circular lookups. -data Ctx = - Ctx - {connection :: ConnWrapper, - cache :: ResolutionCache - } + idFieldName :: String + idFieldName = map toLower (constructorName ti) ++ "ID" + ti = typeInfo @a -type GP = RIO Ctx + -- | fieldsToColumns default implementation: the field names are used as column names + default fieldsToColumns :: [(String, String)] + fieldsToColumns = zip (fieldNames (typeInfo @a)) (fieldNames (typeInfo @a)) --- | The EntityId is a tuple of the TypeRep and the primary key value of an Entity. --- It is used as a key in the resolution cache. -type EntityId = (TypeRep, SqlValue) + -- | tableName default implementation: the type name is used as table name + default tableName :: String + tableName = constructorName ti + where + ti = typeInfo @a --- | The resolution cache maps an EntityId to a Dynamic value (representing an Entity). --- It is used to resolve circular references during loading and storing of Entities. -type ResolutionCache = [(EntityId, Dynamic)] +-- | The EntityId is a tuple of the constructor name and the primary key value of an Entity. +type EntityId = (String, SqlValue) -- | A convenience function: returns the name of the column for a field of a type 'a'. -columnNameFor :: Entity a => a -> String -> String -columnNameFor x fieldName = - case maybeColumnNameFor x fieldName of +columnNameFor :: forall a. (Entity a) => String -> String +columnNameFor fieldName = + case maybeColumnNameFor fieldName of Just columnName -> columnName - Nothing -> error ("columnNameFor: " ++ toString x ++ - " has no column mapping for " ++ fieldName) + Nothing -> + error + ( "columnNameFor: " + ++ tableName @a + ++ " has no column mapping for " + ++ fieldName + ) where - maybeColumnNameFor :: Entity a => a -> String -> Maybe String - maybeColumnNameFor a field = lookup field (fieldsToColumns a) - --- | A convenience function: returns the TypeRep of a field of a type 'a'. -fieldTypeFor :: Entity a => a -> String -> TypeRep -fieldTypeFor x fieldName = - case maybeFieldTypeFor x fieldName of - Just tyRep -> tyRep - Nothing -> error ("fieldTypeFor: " ++ toString x ++ - " has no field " ++ fieldName) + maybeColumnNameFor :: String -> Maybe String + maybeColumnNameFor field = lookup field (fieldsToColumns @a) -maybeFieldTypeFor :: Entity a => a -> String -> Maybe TypeRep -maybeFieldTypeFor a field = lookup field (fieldsAndTypes (typeInfo a)) +maybeFieldTypeFor :: forall a. (Entity a) => String -> Maybe TypeRep +maybeFieldTypeFor field = lookup field (fieldsAndTypes (typeInfo @a)) where fieldsAndTypes :: TypeInfo a -> [(String, TypeRep)] fieldsAndTypes ti = zip (fieldNames ti) (fieldTypes ti) -- | Returns a string representation of a value of type 'a'. -toString :: (Entity a) => a -> String -toString x = typeName (typeInfo x) ++ " " ++ unwords mappedRow +toString :: forall a. (Generic a, GShow' (Rep a)) => a -> String +toString = gshow where - mappedRow = map fromSql (gToRow x) + gshows :: a -> ShowS + gshows = gshowsPrecdefault 0 --- | A convenience function: returns an evidence instance of type 'a'. --- This is useful for type inference where no instance is available. -evidence :: forall a. (Entity a) => a -evidence = evidenceFrom ti - where - ti = typeInfoFromContext :: TypeInfo a + gshow :: a -> String + gshow x = gshows x "" +-- generics based implementations for gFromRow and gToRow +-- toRow +class GToRow f where + gtoRow :: f a -> [SqlValue] -evidenceFrom :: forall a. (Entity a) => TypeInfo a -> a -evidenceFrom = fromConstr . typeConstructor +instance GToRow U1 where + gtoRow U1 = mempty + +instance (Convertible a SqlValue) => GToRow (K1 i a) where + gtoRow (K1 a) = pure $ convert a + +instance (GToRow a, GToRow b) => GToRow (a :*: b) where + gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b + +instance GToRow a => GToRow (M1 i c a) where + gtoRow (M1 a) = gtoRow a + +-- fromRow +class GFromRow f where + gfromRow :: [SqlValue] -> f a + +instance GFromRow U1 where + gfromRow = pure U1 + +instance (Convertible SqlValue a) => GFromRow (K1 i a) where + gfromRow = K1 <$> convert . head + +instance GFromRow a => GFromRow (M1 i c a) where + gfromRow = M1 <$> gfromRow + +-- | This instance is the most interesting one. It splits the list of +-- 'SqlValue's into two parts, one for the first field and one for the +-- rest. Then it uses the 'GFromRow' instance for the first field to +-- convert the first part of the list and the 'GFromRow' instance for +-- the rest of the fields to convert the second part of the list. +-- Finally, it combines the two results using the ':*:' constructor. +-- https://stackoverflow.com/questions/75485429/how-to-use-ghc-generics-to-convert-from-product-data-types-to-a-list-of-sqlvalue/75485650#75485650 +instance (KnownNat (NumFields f), GFromRow f, GFromRow g) => GFromRow (f :*: g) where + gfromRow row = gfromRow rowf :*: gfromRow rowg + where + (rowf, rowg) = splitAt fNumFields row + fNumFields = fromIntegral (natVal (Proxy :: Proxy (NumFields f))) + +type family NumFields (f :: Type -> Type) :: Nat where + NumFields (M1 i c f) = 1 + NumFields (f :*: g) = NumFields f + NumFields g 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,48 +1,44 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Database.GP.GenericPersistence ( retrieveById, retrieveAll, retrieveAllWhere, + entitiesFromRows, persist, insert, + insertMany, update, + updateMany, delete, setupTableFor, idValue, + Conn(..), + connect, + Database(..), Entity (..), + GToRow, + GFromRow, columnNameFor, - fieldTypeFor, maybeFieldTypeFor, toString, - evidence, - evidenceFrom, - ResolutionCache, EntityId, entityId, - getElseRetrieve, TypeInfo (..), - typeInfoFromContext, typeInfo, - Ctx (..), - GP, - extendCtxCache, - runGP, - liftIO, - local, - ask, ) where -import Data.Convertible ( Convertible, ConvertResult ) -import Database.HDBC +import Data.Convertible (ConvertResult, Convertible) +import Data.Convertible.Base (Convertible (safeConvert)) +import Data.List (elemIndex) +import Database.GP.Conn import Database.GP.Entity -import Database.GP.RecordtypeReflection import Database.GP.SqlGenerator import Database.GP.TypeInfo -import Data.Dynamic (toDyn, fromDynamic) -import Data.Data -import Data.Convertible.Base (Convertible(safeConvert)) -import RIO +import Database.HDBC +import Control.Monad (when) {-- This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'. @@ -52,142 +48,157 @@ HDBC is used to access the RDBMS. --} - - - -- | A function that retrieves an entity from a database. -- The function takes entity id as parameter. -- If an entity with the given id exists in the database, it is returned as a Just value. -- If no such entity exists, Nothing is returned. -- An error is thrown if there are more than one entity with the given id. -retrieveById :: forall a id. (Entity a, Convertible id SqlValue) => id -> GP (Maybe a) -retrieveById idx = do - conn <- askConnection - resultRowsSqlValues <- liftIO $ quickQuery conn stmt [eid] +retrieveById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> id -> IO (Maybe a) +retrieveById conn idx = do + resultRowsSqlValues <- quickQuery conn stmt [eid] case resultRowsSqlValues of - [] -> pure Nothing - [singleRow] -> Just <$> fromRow singleRow - _ -> error $ "More than one" ++ show (typeConstructor ti) ++ " found for id " ++ show eid + [] -> pure Nothing + [singleRow] -> Just <$> fromRow conn singleRow + _ -> error $ "More than one" ++ constructorName ti ++ " found for id " ++ show eid where - ti = typeInfoFromContext :: TypeInfo a - stmt = selectStmtFor ti + ti = typeInfo @a + stmt = selectStmtFor @a eid = toSql idx - -- | 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) => GP [a] -retrieveAll = do - conn <- askConnection - resultRows <- liftIO $ quickQuery conn stmt [] - mapM fromRow resultRows +retrieveAll :: forall a. (Entity a) => Conn -> IO [a] +retrieveAll conn = do + resultRows <- quickQuery conn stmt [] + entitiesFromRows conn resultRows where - ti = typeInfoFromContext :: TypeInfo a - stmt = selectAllStmtFor ti + stmt = selectAllStmtFor @a -retrieveAllWhere :: forall a. (Entity a) => String -> SqlValue -> GP [a] -retrieveAllWhere field val = do - conn <- askConnection - resultRows <- liftIO $ quickQuery conn stmt [val] - mapM fromRow resultRows +-- | This function retrieves all entities of type `a` where a given field has a given value. +-- The function takes an HDBC connection, the name of the field and the value 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. +retrieveAllWhere :: forall a. (Entity a) => Conn -> String -> SqlValue -> IO [a] +retrieveAllWhere conn field val = do + resultRows <- quickQuery conn stmt [val] + entitiesFromRows conn resultRows where - ti = typeInfoFromContext :: TypeInfo a - stmt = selectAllWhereStmtFor ti field + stmt = selectAllWhereStmtFor @a field +-- | 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. +-- The function returns a (possibly empty) list of all matching entities. +-- The function is used internally by `retrieveAll` and `retrieveAllWhere`. +-- But it can also be used to convert the result of a custom SQL query to a list of entities. +entitiesFromRows :: forall a. (Entity a) => Conn -> [[SqlValue]] -> IO [a] +entitiesFromRows = mapM . fromRow + -- | 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 -persist :: (Entity a) => a -> GP () -persist entity = do - conn <- askConnection - resultRows <- liftIO $ quickQuery conn preparedSelectStmt [eid] +persist :: forall a. (Entity a) => Conn -> a -> IO () +persist conn entity = do + eid <- idValue conn entity + resultRows <- quickQuery conn preparedSelectStmt [eid] case resultRows of - [] -> insert entity - [_singleRow] -> update entity + [] -> insert conn entity + [_singleRow] -> update conn entity _ -> error $ "More than one entity found for id " ++ show eid where - ti = typeInfo entity - eid = idValue entity - preparedSelectStmt = selectStmtFor ti + preparedSelectStmt = selectStmtFor @a -- | A function that explicitely inserts an entity into a database. -insert :: (Entity a) => a -> GP () -insert entity = do - conn <- askConnection - row <- toRow entity - _rowcount <- liftIO $ run conn (insertStmtFor entity) row - liftIO $ commit conn - --- | A function that explicitely updates an entity in a database. -update :: (Entity a) => a -> GP () -update entity = do - conn <- askConnection - row <- toRow entity - _rowcount <- liftIO $ run conn (updateStmtFor entity) (row ++ [idValue entity]) - liftIO $ commit conn - -delete :: (Entity a) => a -> GP () -delete entity = do - conn <- askConnection - _rowCount <- liftIO $ run conn (deleteStmtFor entity) [idValue entity] - liftIO $ commit conn - --- | set up a table for a given entity type. The table is dropped and recreated. -setupTableFor :: forall a. (Entity a) => GP a -setupTableFor = do - conn <- askConnection - _ <- liftIO $ runRaw conn (dropTableStmtFor ti) - _ <- liftIO $ runRaw conn (createTableStmtFor ti) - liftIO $ commit conn - return x - where - ti = typeInfoFromContext :: TypeInfo a - x = evidenceFrom ti :: a +insert :: forall a. (Entity a) => Conn -> a -> IO () +insert conn entity = do + row <- toRow conn entity + _rowcount <- run conn (insertStmtFor @a) row + when (implicitCommit conn) $ commit conn +-- | A function that inserts a list of entities into a database. +-- The function takes an HDBC connection and a list of entities as parameters. +-- The insert-statement is compiled only once and then executed for each entity. +insertMany :: forall a. (Entity a) => Conn -> [a] -> IO () +insertMany conn entities = do + rows <- mapM (toRow conn) entities + stmt <- prepare conn (insertStmtFor @a) + executeMany stmt rows + when (implicitCommit conn) $ commit conn + --- | Lookup an entity in the cache, or retrieve it from the database. --- The Entity is identified by its EntityId, which is a (typeRep, idValue) tuple. -getElseRetrieve :: forall a . (Entity a) => EntityId -> GP (Maybe a) -getElseRetrieve eid@(_tr,pk) = do - rc <- askCache - case lookup eid rc of - Just dyn -> case fromDynamic dyn :: Maybe a of - Just e -> pure (Just e) - Nothing -> error "should not be possible" - Nothing -> retrieveById pk :: GP (Maybe a) +-- | A function that explicitely updates an entity in a database. +update :: forall a. (Entity a) => Conn -> a -> IO () +update conn entity = do + eid <- idValue conn entity + row <- toRow conn entity + _rowcount <- run conn (updateStmtFor @a) (row ++ [eid]) + when (implicitCommit conn) $ commit conn +-- | A function that updates a list of entities in a database. +-- The function takes an HDBC connection and a list of entities as parameters. +-- The update-statement is compiled only once and then executed for each entity. +updateMany :: forall a. (Entity a) => Conn -> [a] -> IO () +updateMany conn entities = do + eids <- mapM (idValue conn) entities + rows <- mapM (toRow conn) entities + stmt <- prepare conn (updateStmtFor @a) + -- the update statement has one more parameter than the row: the id value for the where clause + executeMany stmt (zipWith (\l x -> l ++ [x]) rows eids) + when (implicitCommit conn) $ commit conn -extendCtxCache :: Entity a => a -> Ctx -> Ctx -extendCtxCache x (Ctx conn rc) = Ctx conn (cacheEntry : rc) - where - cacheEntry = (entityId x, toDyn x) +delete :: forall a. (Entity a) => Conn -> a -> IO () +delete conn entity = do + eid <- idValue conn entity + _rowCount <- run conn (deleteStmtFor @a) [eid] + when (implicitCommit conn) $ commit conn +-- | set up a table for a given entity type. The table is dropped and recreated. +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 -- | Computes the EntityId of an entity. -- The EntityId of an entity is a (typeRep, idValue) tuple. -entityId :: (Entity a) => a -> EntityId -entityId x = (typeOf x, idValue x) +entityId :: forall a. (Entity a) => Conn -> a -> IO EntityId +entityId conn x = do + eid <- idValue conn x + return (tyName, eid) + where + tyName = constructorName (typeInfo @a) -- | A function that returns the primary key value of an entity as a SqlValue. -idValue :: forall a. (Entity a) => a -> SqlValue -idValue x = fieldValue x (idField x) - -askConnection :: GP ConnWrapper -askConnection = connection <$> ask +idValue :: forall a. (Entity a) => Conn -> a -> IO SqlValue +idValue conn x = do + sqlValues <- toRow conn x + return (sqlValues !! idFieldIndex) + where + idFieldIndex = fieldIndex @a (idField @a) -askCache :: GP ResolutionCache -askCache = cache <$> ask +-- | returns the index of a field of an entity. +-- The index is the position of the field in the list of fields of the entity. +-- If no such field exists, an error is thrown. +fieldIndex :: forall a. (Entity a) => String -> Int +fieldIndex fieldName = + expectJust + ("Field " ++ fieldName ++ " is not present in type " ++ constructorName ti) + (elemIndex fieldName fieldList) + where + ti = typeInfo @a + fieldList = fieldNames ti -runGP :: (MonadIO m, IConnection conn) => conn -> RIO Ctx a -> m a -runGP conn = runRIO (Ctx (ConnWrapper conn) mempty) +expectJust :: String -> Maybe a -> a +expectJust _ (Just x) = x +expectJust err Nothing = error ("expectJust " ++ err) -- These instances are needed to make the Convertible type class work with Enum types out of the box. -instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible SqlValue a where +instance {-# OVERLAPS #-} forall a. (Enum a) => Convertible SqlValue a where safeConvert :: SqlValue -> ConvertResult a safeConvert = Right . toEnum . fromSql -instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible a SqlValue where +instance {-# OVERLAPS #-} forall a. (Enum a) => Convertible a SqlValue where safeConvert :: a -> ConvertResult SqlValue - safeConvert = Right . toSql . fromEnum + safeConvert = Right . toSql . fromEnum diff --git a/src/Database/GP/RecordtypeReflection.hs b/src/Database/GP/RecordtypeReflection.hs deleted file mode 100644 --- a/src/Database/GP/RecordtypeReflection.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - - -module Database.GP.RecordtypeReflection - ( - fieldValue, - gFromRow, - gToRow, - ) -where - -import Control.Monad (zipWithM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy (StateT (..)) -import qualified Data.ByteString as B -import Data.Data hiding (typeRep) -import Data.Dynamic (Dynamic, fromDynamic, toDyn) -import Data.Int (Int32, Int64) -import Data.List (elemIndex, uncons) -import Data.Ratio (Ratio) -import qualified Data.Text as TS -import qualified Data.Text.Lazy as TL -import Data.Time (Day, LocalTime, - NominalDiffTime, TimeOfDay, - UTCTime, ZonedTime) -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word32, Word64) -import Database.HDBC (SqlValue, fromSql, toSql) -import GHC.Data.Maybe (expectJust) -import Type.Reflection (SomeTypeRep (..), eqTypeRep, - typeRep) -import Database.GP.TypeInfo - --- | A function that takes an entity and a field name as input parameters and returns the value of the field as a String. --- Example: fieldValue (Person "John" 42) "name" = SqlString "John" --- Example: fieldValue (Person "John" 42) "age" = SqlInt64 42 --- if the field is not present in the entity, an error is thrown. -fieldValue :: Data a => a -> String -> SqlValue -fieldValue x field = - convertToSqlValue fieldType (valueList !! index) - where - ti = typeInfo x - fieldList = fieldNames ti - valueList = fieldValues x - index = - expectJust - ("Field " ++ field ++ " is not present in type " ++ typeName ti) - (elemIndex field fieldList) - fieldType = fieldTypes ti !! index - -fieldValues :: (Data a) => a -> [Dynamic] -fieldValues = gmapQ toDyn - -gFromRow :: forall a. (Data a) => [SqlValue] -> a -gFromRow row = expectJust errMsg (buildFromRecord ti row) - where - ti = typeInfoFromContext - tName = typeName ti - errMsg = "can't construct an " ++ tName ++ " instance from " ++ show row - -gToRow :: (Data a) => a -> [SqlValue] -gToRow x = zipWith convertToSqlValue types values - where - ti = typeInfo x - types = fieldTypes ti - values = fieldValues x - --- | This function takes a `TypeInfo a`and a List of HDBC `SqlValue`s and returns a `Maybe a`. --- If the conversion fails, Nothing is returned, otherwise Just a. -buildFromRecord :: (Data a) => TypeInfo a -> [SqlValue] -> Maybe a -buildFromRecord ti record = applyConstr ctor dynamicsArgs - where - ctor = typeConstructor ti - types = fieldTypes ti - dynamicsArgs = - expectJust - ("buildFromRecord: error in converting record " ++ show record) - (zipWithM convertToDynamic types record) - --- | This function takes a `Constr` and a list of `Dynamic` values and returns a `Maybe a`. --- If an `a`entity could be constructed, Just a is returned, otherwise Nothing. --- See also https://stackoverflow.com/questions/47606189/fromconstrb-or-something-other-useful --- for Info on how to use fromConstrM -applyConstr :: Data a => Constr -> [Dynamic] -> Maybe a -applyConstr ctor args = - let nextField :: forall d. Data d => StateT [Dynamic] Maybe d - nextField = StateT uncons >>= lift . fromDynamic - in case runStateT (fromConstrM nextField ctor) args of - Just (x, []) -> Just x - _ -> Nothing -- runtime type error or too few / too many arguments - --- | convert a SqlValue into a Dynamic value that is backed by a value of the type represented by the SomeTypeRep parameter. --- If conversion fails, return Nothing. --- conversion to Dynamic is required to allow the use of fromDynamic in applyConstr --- see also https://stackoverflow.com/questions/46992740/how-to-specify-type-of-value-via-typerep -convertToDynamic :: SomeTypeRep -> SqlValue -> Maybe Dynamic -convertToDynamic (SomeTypeRep rep) val - | Just HRefl <- eqTypeRep rep (typeRep @Int) = Just $ toDyn (fromSql val :: Int) - | Just HRefl <- eqTypeRep rep (typeRep @Double) = Just $ toDyn (fromSql val :: Double) - | Just HRefl <- eqTypeRep rep (typeRep @String) = Just $ toDyn (fromSql val :: String) - | Just HRefl <- eqTypeRep rep (typeRep @Char) = Just $ toDyn (fromSql val :: Char) - | Just HRefl <- eqTypeRep rep (typeRep @B.ByteString) = Just $ toDyn (fromSql val :: B.ByteString) - | Just HRefl <- eqTypeRep rep (typeRep @Word32) = Just $ toDyn (fromSql val :: Word32) - | Just HRefl <- eqTypeRep rep (typeRep @Word64) = Just $ toDyn (fromSql val :: Word64) - | Just HRefl <- eqTypeRep rep (typeRep @Int32) = Just $ toDyn (fromSql val :: Int32) - | Just HRefl <- eqTypeRep rep (typeRep @Int64) = Just $ toDyn (fromSql val :: Int64) - | Just HRefl <- eqTypeRep rep (typeRep @Integer) = Just $ toDyn (fromSql val :: Integer) - | Just HRefl <- eqTypeRep rep (typeRep @Bool) = Just $ toDyn (fromSql val :: Bool) - | Just HRefl <- eqTypeRep rep (typeRep @UTCTime) = Just $ toDyn (fromSql val :: UTCTime) - | Just HRefl <- eqTypeRep rep (typeRep @POSIXTime) = Just $ toDyn (fromSql val :: POSIXTime) - | Just HRefl <- eqTypeRep rep (typeRep @LocalTime) = Just $ toDyn (fromSql val :: LocalTime) - | Just HRefl <- eqTypeRep rep (typeRep @ZonedTime) = Just $ toDyn (fromSql val :: ZonedTime) - | Just HRefl <- eqTypeRep rep (typeRep @TimeOfDay) = Just $ toDyn (fromSql val :: TimeOfDay) - | Just HRefl <- eqTypeRep rep (typeRep @Day) = Just $ toDyn (fromSql val :: Day) - | Just HRefl <- eqTypeRep rep (typeRep @NominalDiffTime) = Just $ toDyn (fromSql val :: NominalDiffTime) - | Just HRefl <- eqTypeRep rep (typeRep @Ratio) = Just $ toDyn (fromSql val :: Ratio Integer) - | Just HRefl <- eqTypeRep rep (typeRep @TL.Text) = Just $ toDyn (fromSql val :: TL.Text) - | Just HRefl <- eqTypeRep rep (typeRep @TS.Text) = Just $ toDyn (fromSql val :: TS.Text) - | otherwise = Nothing - -convertToSqlValue :: SomeTypeRep -> Dynamic -> SqlValue -convertToSqlValue (SomeTypeRep rep) dyn - | Just HRefl <- eqTypeRep rep (typeRep @Int) = toSql (expectJust ("Not an Int: " ++ show dyn) (fromDynamic dyn) :: Int) - | Just HRefl <- eqTypeRep rep (typeRep @Double) = toSql (expectJust ("Not a Double: " ++ show dyn) (fromDynamic dyn) :: Double) - | Just HRefl <- eqTypeRep rep (typeRep @String) = toSql (expectJust ("Not a String: " ++ show dyn) (fromDynamic dyn) :: String) - | Just HRefl <- eqTypeRep rep (typeRep @Char) = toSql (expectJust ("Not a Char: " ++ show dyn) (fromDynamic dyn) :: Char) - | Just HRefl <- eqTypeRep rep (typeRep @B.ByteString) = toSql (expectJust ("Not a ByteString: " ++ show dyn) (fromDynamic dyn) :: B.ByteString) - | Just HRefl <- eqTypeRep rep (typeRep @Word32) = toSql (expectJust ("Not a Word32: " ++ show dyn) (fromDynamic dyn) :: Word32) - | Just HRefl <- eqTypeRep rep (typeRep @Word64) = toSql (expectJust ("Not a Word64: " ++ show dyn) (fromDynamic dyn) :: Word64) - | Just HRefl <- eqTypeRep rep (typeRep @Int32) = toSql (expectJust ("Not an Int32: " ++ show dyn) (fromDynamic dyn) :: Int32) - | Just HRefl <- eqTypeRep rep (typeRep @Int64) = toSql (expectJust ("Not an Int64: " ++ show dyn) (fromDynamic dyn) :: Int64) - | Just HRefl <- eqTypeRep rep (typeRep @Integer) = toSql (expectJust ("Not an Integer: " ++ show dyn) (fromDynamic dyn) :: Integer) - | Just HRefl <- eqTypeRep rep (typeRep @Bool) = toSql (expectJust ("Not a Bool: " ++ show dyn) (fromDynamic dyn) :: Bool) - | Just HRefl <- eqTypeRep rep (typeRep @UTCTime) = toSql (expectJust ("Not a UTCTime: " ++ show dyn) (fromDynamic dyn) :: UTCTime) - | Just HRefl <- eqTypeRep rep (typeRep @POSIXTime) = toSql (expectJust ("Not a PosixTime: " ++ show dyn) (fromDynamic dyn) :: POSIXTime) - | Just HRefl <- eqTypeRep rep (typeRep @LocalTime) = toSql (expectJust ("Not a LocalTime: " ++ show dyn) (fromDynamic dyn) :: LocalTime) - | Just HRefl <- eqTypeRep rep (typeRep @ZonedTime) = toSql (expectJust ("Not a ZonedTime: " ++ show dyn) (fromDynamic dyn) :: ZonedTime) - | Just HRefl <- eqTypeRep rep (typeRep @TimeOfDay) = toSql (expectJust ("Not a TimeOfDay: " ++ show dyn) (fromDynamic dyn) :: TimeOfDay) - | Just HRefl <- eqTypeRep rep (typeRep @Day) = toSql (expectJust ("Not a Day: " ++ show dyn) (fromDynamic dyn) :: Day) - | Just HRefl <- eqTypeRep rep (typeRep @NominalDiffTime) = toSql (expectJust ("Not a NominalTimeDiff: " ++ show dyn) (fromDynamic dyn) :: NominalDiffTime) - | Just HRefl <- eqTypeRep rep (typeRep @Ratio) = toSql (expectJust ("Not a Ratio: " ++ show dyn) (fromDynamic dyn) :: Ratio Integer) - | Just HRefl <- eqTypeRep rep (typeRep @TL.Text) = toSql (expectJust ("Not a TL.Text: " ++ show dyn) (fromDynamic dyn) :: TL.Text) - | Just HRefl <- eqTypeRep rep (typeRep @TS.Text) = toSql (expectJust ("Not a TS.Text: " ++ show dyn) (fromDynamic dyn) :: TS.Text) - | otherwise = error $ "convertToSqlValue: " ++ show rep ++ " not supported" 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,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + module Database.GP.SqlGenerator ( insertStmtFor, updateStmtFor, @@ -10,128 +12,118 @@ ) where -import Data.List (intercalate) +import Data.List (intercalate) import Database.GP.Entity -import Database.GP.TypeInfo -- | A function that returns an SQL insert statement for an entity. Type 'a' must be an instance of Data. -- The function will use the field names of the data type to generate the column names in the insert statement. -- The values of the fields will be used as the values in the insert statement. -- Output example: INSERT INTO Person (id, name, age, address) VALUES (123456, "Alice", 25, "123 Main St"); -insertStmtFor :: Entity a => a -> String -insertStmtFor x = +insertStmtFor :: forall a. Entity a => String +insertStmtFor = "INSERT INTO " - ++ tableName x + ++ tableName @a ++ " (" ++ intercalate ", " columns ++ ") VALUES (" ++ intercalate ", " (params (length columns)) ++ ");" where - columns = columnNamesFor x - + columns = columnNamesFor @a -columnNamesFor :: Entity a => a -> [String] -columnNamesFor x = map snd fieldColumnPairs +columnNamesFor :: forall a. Entity a => [String] +columnNamesFor = map snd fieldColumnPairs where - fieldColumnPairs = fieldsToColumns x - + fieldColumnPairs = fieldsToColumns @a params :: Int -> [String] params n = replicate n "?" -- | A function that returns an SQL update statement for an entity. Type 'a' must be an instance of Entity. -updateStmtFor :: Entity a => a -> String -updateStmtFor x = +updateStmtFor :: forall a. (Entity a) => String +updateStmtFor = "UPDATE " - ++ tableName x + ++ tableName @a ++ " SET " ++ intercalate ", " updatePairs ++ " WHERE " - ++ idColumn x + ++ idColumn @a ++ " = ?" ++ ";" where - updatePairs = map (++ " = ?") (columnNamesFor x) + updatePairs = map (++ " = ?") (columnNamesFor @a) -idColumn :: Entity a => a -> String -idColumn x = columnNameFor x (idField x) +idColumn :: forall a. (Entity a) => String +idColumn = columnNameFor @a (idField @a) -- | A function that returns an SQL select statement for entity type `a` with primary key `id`. -selectStmtFor :: forall a. (Entity a) => TypeInfo a -> String -selectStmtFor ti = +selectStmtFor :: forall a. (Entity a) => String +selectStmtFor = "SELECT " - ++ intercalate ", " (columnNamesFor x) + ++ intercalate ", " (columnNamesFor @a) ++ " FROM " - ++ tableName x + ++ tableName @a ++ " WHERE " - ++ idColumn x + ++ idColumn @a ++ " = ?;" - where - x = evidenceFrom ti :: a -selectAllStmtFor :: forall a. (Entity a) => TypeInfo a -> String -selectAllStmtFor ti = +selectAllStmtFor :: forall a. (Entity a) => String +selectAllStmtFor = "SELECT " - ++ intercalate ", " (columnNamesFor x) + ++ intercalate ", " (columnNamesFor @a) ++ " FROM " - ++ tableName x + ++ tableName @a ++ ";" - where - x = evidenceFrom ti :: a -selectAllWhereStmtFor :: forall a. (Entity a) => TypeInfo a -> String -> String -selectAllWhereStmtFor ti field = +selectAllWhereStmtFor :: forall a. (Entity a) => String -> String +selectAllWhereStmtFor field = "SELECT " - ++ intercalate ", " (columnNamesFor x) + ++ intercalate ", " (columnNamesFor @a) ++ " FROM " - ++ tableName x + ++ tableName @a ++ " WHERE " ++ column ++ " = ?;" where - x = evidenceFrom ti :: a - column = columnNameFor x field + column = columnNameFor @a field -deleteStmtFor :: Entity a => a -> String -deleteStmtFor x = +deleteStmtFor :: forall a. (Entity a) => String +deleteStmtFor = "DELETE FROM " - ++ tableName x + ++ tableName @a ++ " WHERE " - ++ idColumn x + ++ idColumn @a ++ " = ?;" -createTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String -createTableStmtFor ti = +createTableStmtFor :: forall a. (Entity a) => Database -> String +createTableStmtFor dbServer = "CREATE TABLE " - ++ tableName x + ++ tableName @a ++ " (" - ++ intercalate ", " (map (\(f,c) -> c ++ " " ++ columnTypeFor x f ++ optionalPK f) (fieldsToColumns x)) + ++ intercalate ", " (map (\(f, c) -> c ++ " " ++ columnTypeFor @a dbServer f ++ optionalPK f) (fieldsToColumns @a)) ++ ");" where - x = evidenceFrom ti :: a - isIdField f = f == idField x + isIdField f = f == idField @a optionalPK f = if isIdField f then " PRIMARY KEY" else "" - - -columnTypeFor :: forall a. (Entity a) => a -> String -> String -columnTypeFor x field = + +-- | A function that returns the column type for a field of an entity. +-- TODO: Support other databases than just SQLite. +columnTypeFor :: forall a. (Entity a) => Database -> String -> String +columnTypeFor SQLite field = case fType of - "Int" -> "INTEGER" + "Int" -> "INTEGER" "String" -> "TEXT" "Double" -> "REAL" - "Float" -> "REAL" - "Bool" -> "INT" - _ -> "TEXT" - where - maybeFType = maybeFieldTypeFor x field - fType = maybe "OTHER" show maybeFType - + "Float" -> "REAL" + "Bool" -> "INT" + _ -> "TEXT" + where + maybeFType = maybeFieldTypeFor @a field + fType = maybe "OTHER" show maybeFType +columnTypeFor other _ = error $ "Schema creation for " ++ show other ++ " not implemented yet" -dropTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String -dropTableStmtFor ti = +dropTableStmtFor :: forall a. (Entity a) => String +dropTableStmtFor = "DROP TABLE IF EXISTS " - ++ tableName x + ++ tableName @a ++ ";" - where - x = evidenceFrom ti :: a 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 @@ -1,25 +1,27 @@ ---{-# LANGUAGE RankNTypes #-} ---{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + module Database.GP.TypeInfo ( TypeInfo, - typeConstructor, fieldNames, fieldTypes, - typeName, + constructorName, typeInfo, - typeInfoFromContext, + HasConstructor (..), + HasSelectors (..), ) where -import Data.Data +import Data.Kind (Type) +import GHC.Generics +import Type.Reflection (SomeTypeRep (..), Typeable, typeRep) --- | A data type holding meta-data about a type. +-- | A data type holding meta-data about a type. -- The Phantom type parameter `a` ensures type safety for reflective functions -- that use this type to create type instances (See module RecordtypeReflection). data TypeInfo a = TypeInfo - { typeConstructor :: Constr, + { constructorName :: String, fieldNames :: [String], - fieldTypes :: [TypeRep] + fieldTypes :: [SomeTypeRep] } deriving (Show) @@ -27,45 +29,54 @@ -- It takes a value of type `a` and returns a `TypeInfo a` object. -- If the type has no named fields, an error is thrown. -- If the type has more than one constructor, an error is thrown. -typeInfo :: Data a => a -> TypeInfo a -typeInfo x = +typeInfo :: forall a. (HasConstructor (Rep a), HasSelectors (Rep a), Generic a) => TypeInfo a +typeInfo = TypeInfo - { typeConstructor = ensureSingleConstructor (dataTypeOf x), - fieldNames = fieldNamesOf x, - fieldTypes = gmapQ typeOf x + { constructorName = gConstrName x, + fieldNames = map fst (gSelectors x), + fieldTypes = map snd (gSelectors x) } + where + x = undefined :: a --- | This function ensures that the type of `a` has exactly one constructor. --- If the type has exactly one constructor, the constructor is returned. --- otherwise, an error is thrown. -ensureSingleConstructor :: DataType -> Constr -ensureSingleConstructor dt = - case dataTypeConstrs dt of - [cnstr] -> cnstr - _ -> error $ "ensureSingleConstructor: Only types with one constructor are supported (" ++ show dt ++ ")" +-- Generic implementations --- | This function creates a TypeInfo object from the context of a function call. --- The Phantom Type parameter `a` is used to convince the compiler that the `TypeInfo a` object really describes type `a`. --- See also https://stackoverflow.com/questions/75171829/how-to-obtain-a-data-data-constr-etc-from-a-type-representation -typeInfoFromContext :: forall a. Data a => TypeInfo a -typeInfoFromContext = - let dt = dataTypeOf (undefined :: a) -- This is the trick to get the type a from the context. - constr = ensureSingleConstructor dt - evidence = fromConstr constr :: a -- this is evidence for the compiler that we have a value of type a - in typeInfo evidence +gConstrName :: (HasConstructor (Rep a), Generic a) => a -> String +gConstrName = genericConstrName . from --- | This function returns the (unqualified) type name of `a` from a `TypeInfo a` object. -typeName :: TypeInfo a -> String -typeName = dataTypeName . constrType . typeConstructor +class HasConstructor (f :: Type -> Type) where + genericConstrName :: f x -> String --- | This function returns the list of field names of an entity of type `a`. -fieldNamesOf :: (Data a) => a -> [String] -fieldNamesOf x = names - where - constructor = toConstr x - candidates = constrFields constructor - constrs = gmapQ toConstr x - names = - if length candidates == length constrs - then candidates - else error $ "fieldNamesOf: Type " ++ show (typeOf x) ++ " does not have named fields" +instance HasConstructor f => HasConstructor (D1 c f) where + genericConstrName (M1 x) = genericConstrName x + +instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where + genericConstrName (L1 l) = genericConstrName l + genericConstrName (R1 r) = genericConstrName r + +instance Constructor c => HasConstructor (C1 c f) where + genericConstrName = conName + +-- field names & types + +gSelectors :: forall a. (HasSelectors (Rep a)) => a -> [(String, SomeTypeRep)] +gSelectors _x = selectors @(Rep a) + +class HasSelectors rep where + selectors :: [(String, SomeTypeRep)] + +instance HasSelectors f => HasSelectors (M1 D x f) where + selectors = selectors @f + +instance HasSelectors f => HasSelectors (M1 C x f) where + selectors = selectors @f + +instance (Selector s, Typeable t) => HasSelectors (M1 S s (K1 R t)) where + selectors = + [(selName (undefined :: M1 S s (K1 R t) ()), SomeTypeRep (typeRep @t))] + +instance (HasSelectors a, HasSelectors b) => HasSelectors (a :*: b) where + selectors = selectors @a ++ selectors @b + +instance HasSelectors U1 where + selectors = [] diff --git a/test/EmbeddedSpec.hs b/test/EmbeddedSpec.hs --- a/test/EmbeddedSpec.hs +++ b/test/EmbeddedSpec.hs @@ -1,26 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} + module EmbeddedSpec - ( test - , spec - ) where + ( test, + spec, + ) +where -import Test.Hspec -import Data.Data -import Database.HDBC -import Database.HDBC.Sqlite3 -import Database.GP.GenericPersistence -import RIO +import Database.GP.GenericPersistence +import Database.HDBC +import Database.HDBC.Sqlite3 +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. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a -withDatabase action = do - conn <- connectSqlite3 ":memory:" - runGP conn $ do - _ <- setupTableFor :: GP Article - action +prepareDB :: IO Conn +prepareDB = do + conn <- connect SQLite <$> connectSqlite3 ":memory:" + setupTableFor @Article conn + return conn data Article = Article { articleID :: Int, @@ -28,56 +29,61 @@ author :: Author, year :: Int } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) data Author = Author { authorID :: Int, name :: String, address :: String } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) instance Entity Article where - - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), - ("title", "title"), - ("authorID", "authorID"), - ("authorName", "authorName"), - ("authorAddress", "authorAddress"), - ("year", "year") - ] + fieldsToColumns = + [ ("articleID", "articleID"), + ("title", "title"), + ("authorID", "authorID"), + ("authorName", "authorName"), + ("authorAddress", "authorAddress"), + ("year", "year") + ] - fromRow row = return $ Article (col 0) (col 1) author (col 5) + fromRow :: Conn -> [SqlValue] -> IO Article + fromRow _ r = return $ fromRowWoCtx r where - col i = fromSql (row !! i) - author = Author (col 2) (col 3) (col 4) + fromRowWoCtx row = Article (col 0) (col 1) author (col 5) + where + col i = fromSql (row !! i) + author = Author (col 2) (col 3) (col 4) - toRow a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)] - where - authID = authorID (author a) - authorName = name (author a) - authorAddress = address (author a) + toRow _ art = return $ toRowWoCtx art + where + toRowWoCtx a = [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)] + authID = authorID (author art) + authorName = name (author art) + authorAddress = address (author art) article :: Article -article = Article - { articleID = 1, - title = "Persistence without Boilerplate", - author = Author - {authorID = 1, - name = "Arthur Dent", - address = "Boston"}, - year = 2018} +article = + Article + { articleID = 1, + title = "Persistence without Boilerplate", + author = + Author + { authorID = 1, + name = "Arthur Dent", + address = "Boston" + }, + year = 2018 + } spec :: Spec spec = do describe "Handling of Embedded Objects" $ do - it "works like a charm" $ - withDatabase $ do - insert article - article' <- retrieveById "1" :: GP (Maybe Article) - liftIO $ article' `shouldBe` Just article - allArticles <- retrieveAll :: GP [Article] - liftIO $ allArticles `shouldBe` [article] - - + it "works like a charm" $ do + conn <- prepareDB + insert conn article + article' <- retrieveById conn "1" :: IO (Maybe Article) + article' `shouldBe` Just article + allArticles <- retrieveAll conn :: IO [Article] + allArticles `shouldBe` [article] diff --git a/test/EnumSpec.hs b/test/EnumSpec.hs --- a/test/EnumSpec.hs +++ b/test/EnumSpec.hs @@ -1,60 +1,53 @@ +{-# LANGUAGE DeriveAnyClass #-} + module EnumSpec - ( test - , spec - ) where + ( test, + spec, + ) +where -import Test.Hspec -import Data.Data -import Database.HDBC -import Database.HDBC.Sqlite3 -import Database.GP.GenericPersistence -import RIO +import Data.Convertible +import Database.GP.GenericPersistence +import Database.HDBC +import Database.HDBC.Sqlite3 +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. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a -withDatabase action = do - conn <- connectSqlite3 ":memory:" - runGP conn $ do - _ <- setupTableFor :: GP Book - action +prepareDB :: IO Conn +prepareDB = do + conn <- connect SQLite <$> connectSqlite3 ":memory:" + setupTableFor @Book conn + return conn data Book = Book - { bookID :: Int, - title :: String, - author :: String, - year :: Int, + { bookID :: Int, + title :: String, + author :: String, + year :: Int, category :: BookCategory } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq, Entity) data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other - deriving (Data, Show, Read, Eq, Enum) - -instance Entity Book where - fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) (col 4) - where - col i = fromSql (row !! i) + deriving (Generic, Show, Read, Eq) - toRow b = return [toSql (bookID b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)] +instance Convertible BookCategory SqlValue where + safeConvert = Right . toSql . show --- instance Convertible BookCategory SqlValue where --- safeConvert = Right . toSql . show - --- instance Convertible SqlValue BookCategory where --- safeConvert = Right . read . fromSql +instance Convertible SqlValue BookCategory where + safeConvert = Right . read . fromSql spec :: Spec spec = do describe "Handling of Enum Fields" $ do - it "works like a charm" $ - withDatabase $ do - let book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction - insert book - allBooks <- retrieveAll :: GP [Book] - liftIO $ allBooks `shouldBe` [book] - - + it "works like a charm" $ do + conn <- prepareDB + let book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction + insert conn book + allBooks <- retrieveAll conn :: IO [Book] + allBooks `shouldBe` [book] diff --git a/test/GenericPersistenceSpec.hs b/test/GenericPersistenceSpec.hs --- a/test/GenericPersistenceSpec.hs +++ b/test/GenericPersistenceSpec.hs @@ -1,33 +1,29 @@ -{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class -module GenericPersistenceSpec - ( test - , spec - , withDatabase - ) where +-- allows automatic derivation from Entity type class +{-# LANGUAGE DeriveAnyClass #-} +module GenericPersistenceSpec + ( test, + spec, + ) +where -import Test.Hspec -import Data.Data -import Database.HDBC -import Database.HDBC.Sqlite3 import Database.GP.GenericPersistence -import RIO - - +import Database.HDBC +import Database.HDBC.Sqlite3 +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. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a -withDatabase action = do - conn <- connectSqlite3 ":memory:" - let ctx = Ctx (ConnWrapper conn) mempty - runRIO ctx $ do - _ <- setupTableFor :: GP Person - _ <- setupTableFor :: GP Book - action +prepareDB :: IO Conn +prepareDB = do + conn <- connect SQLite <$> connectSqlite3 ":memory:" + setupTableFor @Person conn + setupTableFor @Book conn + return conn -- | A data type with several fields, using record syntax. data Person = Person @@ -36,149 +32,171 @@ age :: Int, address :: String } - deriving (Data, Entity, Show, Eq) + deriving (Generic, Entity, Show, Eq) data Book = Book - { book_id :: Int, - title :: String, - author :: String, - year :: Int, + { book_id :: Int, + title :: String, + author :: String, + year :: Int, category :: BookCategory } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other - deriving (Data, Read, Show, Eq, Enum) + deriving (Generic, Read, Show, Eq, Enum) - instance Entity Book where - idField _ = "book_id" - fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear"), ("category", "bookCategory")] - tableName _ = "BOOK_TBL" - fromRow row = pure $ Book (col 0) (col 1) (col 2) (col 3) (col 4) + idField = "book_id" + 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 col i = fromSql (row !! i) - toRow b = pure [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)] - + toRow _c b = pure [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)] person :: Person person = Person 123456 "Alice" 25 "123 Main St" +manyPersons :: [Person] +manyPersons = + [ Person 1 "Alice" 25 "123 Main St", + Person 2 "Bob" 30 "456 Elm St", + Person 3 "Charlie" 35 "789 Pine St", + Person 4 "Dave" 40 "1011 Oak St", + Person 5 "Eve" 45 "1213 Maple St", + Person 6 "Frank" 50 "1415 Walnut St" + ] + + book :: Book book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction - spec :: Spec spec = do describe "GenericPersistence" $ do - it "retrieves Entities using Generics" $ - withDatabase $ do - let bob = Person 1 "Bob" 36 "7 West Street" - Ctx conn _ <- ask - liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (1, \"Bob\", 36, \"7 West Street\");" - liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (2, \"Alice\", 25, \"7 West Street\");" - liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (3, \"Frank\", 56, \"7 West Street\");" - allPersons <- retrieveAll :: GP [Person] - liftIO $ length allPersons `shouldBe` 3 - liftIO $ head allPersons `shouldBe` bob - person' <- retrieveById (1 :: Int) :: GP (Maybe Person) - liftIO $ person' `shouldBe` Just bob - it "retrieves Entities using user implementation" $ - withDatabase $ do + it "retrieves Entities using Generics" $ do + conn <- prepareDB + let bob = Person 1 "Bob" 36 "7 West Street" + runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (1, \"Bob\", 36, \"7 West Street\");" + runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (2, \"Alice\", 25, \"7 West Street\");" + runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (3, \"Frank\", 56, \"7 West Street\");" + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 3 + head allPersons `shouldBe` bob + person' <- retrieveById conn (1 :: Int) :: IO (Maybe Person) + person' `shouldBe` Just bob + it "retrieves Entities using user implementation" $ do + conn <- prepareDB let hobbit = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction - Ctx conn _ <- ask - liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (1, \"The Hobbit\", \"J.R.R. Tolkien\", 1937, 0);" - liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (2, \"The Lord of the Rings\", \"J.R.R. Tolkien\", 1955, 0);" - liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (3, \"Smith of Wootton Major\", \"J.R.R. Tolkien\", 1967, 0);" - allBooks <- retrieveAll :: GP [Book] - liftIO $ length allBooks `shouldBe` 3 - liftIO $ head allBooks `shouldBe` hobbit - book' <- retrieveById(1 :: Int) :: GP (Maybe Book) - liftIO $ book' `shouldBe` Just hobbit - - it "persists new Entities using Generics" $ - withDatabase $ do - allPersons <- retrieveAll :: GP [Person] - liftIO $ length allPersons `shouldBe` 0 - persist person - allPersons' <- retrieveAll :: GP [Person] - liftIO $ length allPersons' `shouldBe` 1 - person' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ person' `shouldBe` Just person - it "persists new Entities using user implementation" $ - withDatabase $ do - allbooks <- retrieveAll :: GP [Book] - liftIO $ length allbooks `shouldBe` 0 - persist book - allbooks' <- retrieveAll :: GP [Book] - liftIO $ length allbooks' `shouldBe` 1 - book' <- retrieveById (1 :: Int) :: GP (Maybe Book) - liftIO $ book' `shouldBe` Just book - it "persists existing Entities using Generics" $ - withDatabase $ do - allPersons <- retrieveAll :: GP [Person] - liftIO $ length allPersons `shouldBe` 0 - persist person - allPersons' <- retrieveAll :: GP [Person] - liftIO $ length allPersons' `shouldBe` 1 - persist person {age = 26} - person' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ person' `shouldBe` Just person {age = 26} - it "persists existing Entities using user implementation" $ - withDatabase $ do - allbooks <- retrieveAll :: GP [Book] - liftIO $ length allbooks `shouldBe` 0 - persist book - allbooks' <- retrieveAll :: GP [Book] - liftIO $ length allbooks' `shouldBe` 1 - persist book {year = 1938} - book' <- retrieveById (1 :: Int) :: GP (Maybe Book) - liftIO $ book' `shouldBe` Just book {year = 1938} - it "inserts Entities using Generics" $ - withDatabase $ do - allPersons <- retrieveAll :: GP [Person] - liftIO $ length allPersons `shouldBe` 0 - insert person - allPersons' <- retrieveAll :: GP [Person] - liftIO $ length allPersons' `shouldBe` 1 - person' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ person' `shouldBe` Just person - it "inserts Entities using user implementation" $ - withDatabase $ do - allbooks <- retrieveAll :: GP [Book] - liftIO $ length allbooks `shouldBe` 0 - insert book - allbooks' <- retrieveAll :: GP [Book] - liftIO $ length allbooks' `shouldBe` 1 - book' <- retrieveById (1 :: Int) :: GP (Maybe Book) - liftIO $ book' `shouldBe` Just book - it "updates Entities using Generics" $ - withDatabase $ do - insert person - update person {name = "Bob"} - person' <- retrieveById (123456 :: Int) :: GP (Maybe Person) - liftIO $ person' `shouldBe` Just person {name = "Bob"} - it "updates Entities using user implementation" $ - withDatabase $ do - insert book - update book {title = "The Lord of the Rings"} - book' <- retrieveById (1 :: Int) :: GP (Maybe Book) - liftIO $ book' `shouldBe` Just book {title = "The Lord of the Rings"} - it "deletes Entities using Generics" $ - withDatabase $ do - insert person - allPersons <- retrieveAll :: GP [Person] - liftIO $ length allPersons `shouldBe` 1 - delete person - allPersons' <- retrieveAll :: GP [Person] - liftIO $ length allPersons' `shouldBe` 0 - it "deletes Entities using user implementation" $ - withDatabase $ do - insert book - allBooks <- retrieveAll :: GP [Book] - liftIO $ length allBooks `shouldBe` 1 - delete book - allBooks' <- retrieveAll :: GP [Book] - liftIO $ length allBooks' `shouldBe` 0 - + runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (1, \"The Hobbit\", \"J.R.R. Tolkien\", 1937, 0);" + runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (2, \"The Lord of the Rings\", \"J.R.R. Tolkien\", 1955, 0);" + runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (3, \"Smith of Wootton Major\", \"J.R.R. Tolkien\", 1967, 0);" + allBooks <- retrieveAll conn :: IO [Book] + length allBooks `shouldBe` 3 + head allBooks `shouldBe` hobbit + book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book) + book' `shouldBe` Just hobbit + it "persists new Entities using Generics" $ do + conn <- prepareDB + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 0 + persist conn person + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 1 + person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person) + person' `shouldBe` Just person + it "persists new Entities using user implementation" $ do + conn <- prepareDB + allbooks <- retrieveAll conn :: IO [Book] + length allbooks `shouldBe` 0 + persist conn book + allbooks' <- retrieveAll conn :: IO [Book] + length allbooks' `shouldBe` 1 + book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book) + book' `shouldBe` Just book + it "persists existing Entities using Generics" $ do + conn <- prepareDB + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 0 + persist conn person + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 1 + persist conn person {age = 26} + person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person) + person' `shouldBe` Just person {age = 26} + it "persists existing Entities using user implementation" $ do + conn <- prepareDB + allbooks <- retrieveAll conn :: IO [Book] + length allbooks `shouldBe` 0 + persist conn book + allbooks' <- retrieveAll conn :: IO [Book] + length allbooks' `shouldBe` 1 + persist conn book {year = 1938} + book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book) + book' `shouldBe` Just book {year = 1938} + it "inserts Entities using Generics" $ do + conn <- prepareDB + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 0 + insert conn person + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 1 + person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person) + person' `shouldBe` Just person + it "inserts many Entities re-using a single prepared stmt" $ do + conn <- prepareDB + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 0 + insertMany conn manyPersons + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 6 + it "updates many Entities re-using a single prepared stmt" $ do + conn <- prepareDB + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 0 + insertMany conn manyPersons + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 6 + let manyPersons' = map (\p -> p {name = "Bob"}) manyPersons + updateMany conn manyPersons' + allPersons'' <- retrieveAll conn :: IO [Person] + all (\p -> name p == "Bob") allPersons'' `shouldBe` True + it "inserts Entities using user implementation" $ do + conn <- prepareDB + allbooks <- retrieveAll conn :: IO [Book] + length allbooks `shouldBe` 0 + insert conn book + allbooks' <- retrieveAll conn :: IO [Book] + length allbooks' `shouldBe` 1 + book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book) + book' `shouldBe` Just book + it "updates Entities using Generics" $ do + conn <- prepareDB + insert conn person + update conn person {name = "Bob"} + person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person) + person' `shouldBe` Just person {name = "Bob"} + it "updates Entities using user implementation" $ do + conn <- prepareDB + insert conn book + update conn book {title = "The Lord of the Rings"} + book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book) + book' `shouldBe` Just book {title = "The Lord of the Rings"} + it "deletes Entities using Generics" $ do + conn <- prepareDB + insert conn person + allPersons <- retrieveAll conn :: IO [Person] + length allPersons `shouldBe` 1 + delete conn person + allPersons' <- retrieveAll conn :: IO [Person] + length allPersons' `shouldBe` 0 + it "deletes Entities using user implementation" $ do + conn <- prepareDB + insert conn book + allBooks <- retrieveAll conn :: IO [Book] + length allBooks `shouldBe` 1 + delete conn book + allBooks' <- retrieveAll conn :: IO [Book] + length allBooks' `shouldBe` 0 diff --git a/test/OneToManySpec.hs b/test/OneToManySpec.hs --- a/test/OneToManySpec.hs +++ b/test/OneToManySpec.hs @@ -1,37 +1,38 @@ -{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class +-- allows automatic derivation from Entity type class +{-# LANGUAGE DeriveAnyClass #-} + module OneToManySpec - ( test - , spec - ) where + ( test, + spec, + ) +where -import Test.Hspec -import Data.Data -import Database.HDBC -import Database.HDBC.Sqlite3 -import Database.GP.GenericPersistence -import RIO -import Data.Maybe (fromJust) +import Data.Maybe (fromJust) +import Database.GP.GenericPersistence +import Database.HDBC +import Database.HDBC.Sqlite3 +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. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a -withDatabase action = do - conn <- connectSqlite3 ":memory:" - runGP conn $ do - _ <- setupTableFor :: GP Article - _ <- setupTableFor :: GP Author - action +prepareDB :: IO Conn +prepareDB = do + conn <- connect SQLite <$> connectSqlite3 ":memory:" + setupTableFor @Article conn + setupTableFor @Author conn + return conn data Article = Article { articleID :: Int, title :: String, - author :: Author, + authorId :: Int, year :: Int } - deriving (Data, Show, Eq) + deriving (Generic, Entity, Show, Eq) -- automatically derives Entity data Author = Author { authorID :: Int, @@ -39,102 +40,83 @@ address :: String, articles :: [Article] } - deriving (Data, Show, Eq) - -instance Entity Article where - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), - ("title", "title"), - ("authorID", "authorID"), - ("year", "year") - ] - - fromRow :: [SqlValue] -> GP Article - fromRow row = local (extendCtxCache rawArticle) $ do - maybeAuthor <- getElseRetrieve (entityId rawAuthor) - let author = fromJust maybeAuthor - pure $ Article (col 0) (col 1) author (col 3) - where - col i = fromSql (row !! i) - rawAuthor = (evidence :: Author) {authorID = col 2} - rawArticle = Article (col 0) (col 1) rawAuthor (col 3) - - toRow a = do - persist (author a) - return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)] - + deriving (Generic, Show, Eq) instance Entity Author where - fieldsToColumns :: Author -> [(String, String)] - fieldsToColumns _ = [("authorID", "authorID"), - ("name", "name"), - ("address", "address") - ] + fieldsToColumns :: [(String, String)] -- ommitting the articles field, + fieldsToColumns = -- as this can not be mapped to a single column + [ ("authorID", "authorID"), + ("name", "name"), + ("address", "address") + ] - fromRow :: [SqlValue] -> GP Author - fromRow row = local (extendCtxCache rawAuthor) $ do - articlesByAuth <- retrieveAllWhere (idField rawAuthor) (idValue rawAuthor) :: GP [Article] - pure $ rawAuthor {articles= articlesByAuth} + fromRow :: Conn -> [SqlValue] -> IO Author + fromRow conn row = do + let authID = head row -- authorID is the first column + articlesBy <- retrieveAllWhere conn "authorId" authID -- retrieve all articles by this author + return rawAuthor {articles = articlesBy} -- add the articles to the author where - col i = fromSql (row !! i) - rawAuthor = Author (col 0) (col 1) (col 2) [] + 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 :: Author -> GP [SqlValue] - toRow a = do - return [toSql (authorID a), toSql (name a), toSql (address a)] + 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)] + article1 :: Article -article1 = Article - { articleID = 1, - title = "Persistence without Boilerplate", - author = Author - {authorID = 1, - name = "Max Millian", - address = "Boston", - articles = []}, - year = 2018} +article1 = + Article + { articleID = 1, + title = "Persistence without Boilerplate", + authorId = 1, + year = 2018 + } article2 :: Article -article2 = Article - { articleID = 2, - title = "Boilerplate for Dummies", - author = arthur, - year = 2020} +article2 = + Article + { articleID = 2, + title = "Boilerplate for Dummies", + authorId = 2, + year = 2020 + } article3 :: Article -article3 = Article - { articleID = 3, - title = "The return of the boilerplate", - author = arthur, - year = 2022} +article3 = + Article + { articleID = 3, + title = "The return of the boilerplate", + authorId = 2, + year = 2022 + } arthur :: Author -arthur = Author - {authorID = 2, - name = "Arthur Miller", - address = "Denver", - articles = [article2, article3]} +arthur = + Author + { authorID = 2, + name = "Arthur Miller", + address = "Denver", + articles = [article2, article3] + } spec :: Spec spec = do describe "Handling of 1:N References" $ do - it "works like a charm" $ - withDatabase $ do - insert article1 - insert article2 - insert article3 + it "works like a charm" $ do + conn <- prepareDB - authors <- retrieveAll :: GP [Author] - liftIO $ length authors `shouldBe` 2 - --liftIO $ print authors - articles <- retrieveAll :: GP [Article] - liftIO $ length articles `shouldBe` 3 - - article' <- retrieveById "3" :: GP (Maybe Article) - let art = fromJust article' - liftIO $ (name (author art)) `shouldBe` "Arthur Miller" - - + insert conn arthur + insert conn article1 + authors <- retrieveAll conn :: IO [Author] + length authors `shouldBe` 1 + articles' <- retrieveAll conn :: IO [Article] + length articles' `shouldBe` 3 + author2 <- retrieveById conn "2" :: IO (Maybe Author) + fromJust author2 `shouldBe` arthur + length (articles $ fromJust author2) `shouldBe` 2 diff --git a/test/ReferenceSpec.hs b/test/ReferenceSpec.hs --- a/test/ReferenceSpec.hs +++ b/test/ReferenceSpec.hs @@ -1,28 +1,30 @@ -{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class +-- allows automatic derivation from Entity type class +{-# LANGUAGE DeriveAnyClass #-} + module ReferenceSpec - ( test - , spec - ) where + ( test, + spec, + ) +where -import Test.Hspec -import Data.Data -import Database.HDBC -import Database.HDBC.Sqlite3 -import Database.GP.GenericPersistence -import RIO +import Data.Maybe +import Database.GP.GenericPersistence +import Database.HDBC +import Database.HDBC.Sqlite3 +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. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a -withDatabase action = do - conn <- connectSqlite3 ":memory:" - runGP conn $ do - _ <- setupTableFor :: GP Article - _ <- setupTableFor :: GP Author - action +prepareDB :: IO Conn +prepareDB = do + conn <- connect SQLite <$> connectSqlite3 ":memory:" + setupTableFor @Article conn + setupTableFor @Author conn + return conn data Article = Article { articleID :: Int, @@ -30,60 +32,68 @@ author :: Author, year :: Int } - deriving (Data, Show, Eq) + deriving (Generic, Show, Eq) data Author = Author { authorID :: Int, name :: String, address :: String } - deriving (Data, Entity, Show, Eq) + deriving (Generic, Entity, Show, Eq) instance Entity Article where - fieldsToColumns :: Article -> [(String, String)] - fieldsToColumns _ = [("articleID", "articleID"), - ("title", "title"), - ("authorID", "authorID"), - ("year", "year") - ] + 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 row = do - maybeAuthor <- retrieveById (row !! 2) :: GP (Maybe Author) - let author = fromMaybe (error "Author not found") maybeAuthor - pure $ Article (col 0) (col 1) author (col 3) + fromRow :: Conn -> [SqlValue] -> IO Article + fromRow conn row = do + authorById <- fromJust <$> retrieveById conn (row !! 2) -- load author by foreign key + return $ rawArticle {author = authorById} -- add author to article where - col i = fromSql (row !! i) - - toRow a = do - persist (author a) - return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)] + 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 + + + article :: Article -article = Article - { articleID = 1, - title = "Persistence without Boilerplate", - author = arthur, - year = 2018} - +article = + Article + { articleID = 1, + title = "Persistence without Boilerplate", + author = arthur, + year = 2018 + } + arthur :: Author -arthur = Author - {authorID = 2, - name = "Arthur Miller", - address = "Denver"} +arthur = + Author + { authorID = 2, + name = "Arthur Miller", + address = "Denver" + } spec :: Spec spec = do describe "Handling of 1:1 References" $ do - it "works like a charm" $ - withDatabase $ do - insert article - - author' <- retrieveById "2" :: GP (Maybe Author) - liftIO $ author' `shouldBe` Just arthur - - article' <- retrieveById "1" :: GP (Maybe Article) - liftIO $ article' `shouldBe` Just article - - + it "works like a charm" $ do + conn <- prepareDB + insert conn article + author' <- retrieveById conn "2" :: IO (Maybe Author) + author' `shouldBe` Just arthur + article' <- retrieveById conn "1" :: IO (Maybe Article) + article' `shouldBe` Just article diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,4 @@ -{-# OPTIONS_GHC -Wno-missing-export-lists #-} -- Avoid warning for missing export list in test/Spec.hs -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -- this compiler pragma allows GHC to automatically discover all Hspec Test Specs. +-- this compiler pragma allows GHC to automatically discover all Hspec Test Specs. +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +-- Avoid warning for missing export list in test/Spec.hs +{-# OPTIONS_GHC -Wno-missing-export-lists #-}