diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,372 @@ +# GenericPersistence - A Haskell persistence layer using Generics and Reflection + +![GP Logo](gp-logo-300.png) + +## 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`). + +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*). + +That is, it provides means for inserting, updating, deleting and quering such enties to/from relational databases. + +The main *design goal* is to minimize the *boilerplate* code required: + +- no manual instantiation of type classes +- no implementation of encoders/decoders +- no special naming convention for types and their attributes +- no special types to define entities and attributes +- no Template Haskell scaffolding of glue code + +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: + +- A query language +- Handling of nested transactions +- Handling auto-incrementing primary keys +- ... + + +## 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 #-} + +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) + + +-- | An Entity data type with several fields, using record syntax. +data Person = Person + { personID :: Int, + name :: String, + age :: Int, + address :: String + } + deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence + +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" + + -- 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" + + -- 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 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)] + +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"} + + -- select a Person from a database + alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person) + liftIO $ print alice' + + -- select all Persons from the database + allPersons <- retrieveAll :: GP [Person] + liftIO $ print allPersons + + -- delete a Person + delete alice + + -- select all Persons from a database. The deleted Person is not in the result. + allPersons' <- retrieveAll :: GP [Person] + liftIO $ 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 book + insert book2 + allBooks <- retrieveAll :: GP [Book] + liftIO $ print allBooks + + -- explicitly updating a Book + update book2 {title = "The Lord of the Rings"} + delete book + + allBooks' <- retrieveAll :: GP [Book] + liftIO $ print allBooks' +``` + +## Handling enumeration fields + +Say we have a data type `Book` with an enumeration field of type `BookCategory`: + +```haskell +data Book = Book + { bookID :: Int, + title :: String, + author :: String, + year :: Int, + category :: BookCategory + } + deriving (Data, 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)] +``` + +`toSql` and `fromSql` expect `Convertible` instances as arguments. This works for `BookCatagory` as GenericPersistence provides `Convertible` instances for all `Enum` types. + +If you do not want to use `Enum` types for your enumeration fields, you can implement `Convertible` instances for your own types: + +```haskell +data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other + deriving (Data, Show, Read) + +instance Convertible BookCategory SqlValue where + safeConvert = Right . toSql . show + +instance Convertible SqlValue BookCategory where + safeConvert = Right . read . fromSql +``` + +## Handling embedded Objects + +Say we have a data type `Article` with an field of type `Author`: + +```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 + } + deriving (Data, 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: + +```haskell +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"), + ("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) + 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)] + where + authID = authorID (author a) + authorName = name (author a) + authorAddress = address (author a) +``` + +## Handling 1:1 references + +If we have the same data types as in the previous example, but we want to store the `Author` in a separate table, we can use the following approach: + +```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 + } + deriving (Data, Entity, Show, Eq) -- we derive Entity for Author + +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") + ] + + -- 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) + 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)] + +``` +## Handling 1:n references + +Now let's extend the previous example by also having a list of Àrticle`s 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. + +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. + +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. + +We can handle this situation by using the following approach: + +```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") + ] + + -- 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) + 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)] + + +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") + ] + + -- 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) [] + + -- 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)] +``` + +## Todo + +- coding free support for 1:1 and 1:n relationships +- coding free support for Enums +- resolution cache with proper Map + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,133 @@ +-- allows automatic derivation from Entity type class +{-# LANGUAGE DeriveAnyClass #-} + +module Main (main, main1) 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) + +-- | An Entity data type with several fields, using record syntax. +data Person = Person + { personID :: Int, + name :: String, + age :: Int, + address :: String + } + deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence + +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" + + -- 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" + + -- 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 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)] + +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"} + + -- select a Person from a database + alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person) + liftIO $ print alice' + + -- select all Persons from the database + allPersons <- retrieveAll :: GP [Person] + liftIO $ print allPersons + + -- delete a Person + delete alice + + -- select all Persons from a database. The deleted Person is not in the result. + allPersons' <- retrieveAll :: GP [Person] + liftIO $ 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 book + insert book2 + allBooks <- retrieveAll :: GP [Book] + liftIO $ print allBooks + + -- explicitly updating a Book + update book2 {title = "The Lord of the Rings"} + delete book + + allBooks' <- retrieveAll :: GP [Book] + liftIO $ print allBooks' + + -- close connection + disconnect conn + +main1 :: IO () +main1 = do + -- connect to a database + conn <- connectSqlite3 "sqlite.db" + runGP conn $ do + -- initialize Person table + _ <- setupTableFor :: GP Person + + -- create a Person entity + let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} + + -- insert a Person into a database + persist alice + + -- update a Person + persist alice {address = "Main Street 200"} + + -- 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' + + alice'' <- retrieveById "123456" :: GP (Maybe Person) + + liftIO $ print alice'' + + -- delete a Person from a database + delete alice + + -- close connection + disconnect conn diff --git a/generic-persistence.cabal b/generic-persistence.cabal new file mode 100644 --- /dev/null +++ b/generic-persistence.cabal @@ -0,0 +1,119 @@ +cabal-version: 1.12 +name: generic-persistence +version: 0.2.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 +homepage: https://github.com/githubuser/generic-persistence#readme +bug-reports: https://github.com/githubuser/generic-persistence/issues +synopsis: Database persistence using generics +description: + Please see the README on GitHub at + +category: Database +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/githubuser/generic-persistence + +library + exposed-modules: + Database.GP + Database.GP.Entity + Database.GP.GenericPersistence + Database.GP.RecordtypeReflection + Database.GP.SqlGenerator + Database.GP.TypeInfo + + hs-source-dirs: src + other-modules: Paths_generic_persistence + default-language: GHC2021 + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + + 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 + +executable generic-persistence-demo + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_generic_persistence + default-language: GHC2021 + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N + + build-depends: + 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 + +test-suite generic-persistence-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + EmbeddedSpec + EnumSpec + GenericPersistenceSpec + OneToManySpec + ReferenceSpec + Paths_generic_persistence + + default-language: GHC2021 + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N + + build-depends: + HDBC <2.5, + HDBC-sqlite3 <2.4, + QuickCheck <2.15, + base >=4.7 && <5, + bytestring <0.12, + convertible <1.2, + exceptions <0.11, + 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 diff --git a/src/Database/GP.hs b/src/Database/GP.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP.hs @@ -0,0 +1,37 @@ +module Database.GP ( retrieveById, + retrieveAll, + retrieveAllWhere, + persist, + insert, + update, + delete, + setupTableFor, + idValue, + Entity (..), + columnNameFor, + fieldTypeFor, + maybeFieldTypeFor, + toString, + evidence, + evidenceFrom, + ResolutionCache, + EntityId, + entityId, + getElseRetrieve, + TypeInfo (..), + typeInfoFromContext, + typeInfo, + Ctx (..), + GP, + extendCtxCache, + runGP, + liftIO, + local, + ask, + ) +where + +-- We are just re-exporting the functions from the GenericPersistence module. +import Database.GP.GenericPersistence + + diff --git a/src/Database/GP/Entity.hs b/src/Database/GP/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP/Entity.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DefaultSignatures #-} + +module Database.GP.Entity + ( Entity (..), + columnNameFor, + fieldTypeFor, + maybeFieldTypeFor, + toString, + evidence, + evidenceFrom, + ResolutionCache, + EntityId, + Ctx (..), + GP, + ) +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 + +{-- +This is the Entity class. It is a type class that is used to define the mapping +between a Haskell product type in record notation and a database table. +The class has a default implementation for all methods. +The default implementation uses the type information to determine a simple 1:1 mapping. + +That means that +- the type name is used as the table name and the +- field names are used as the column names. +- A field named 'ID' is used as the primary key field. + +The default implementation can be overridden by defining a custom instance for a type. + +Please note the following constraints, which apply to all valid Entity type, +but that are not explicitely encoded in the type class definition: + +- The type must be a product type in record notation. +- The type must have exactly one constructor. +- There must be single primary key field, compund primary keys are not supported. + +--} + +class (Data a) => Entity a where + -- | Converts a database row to a value of type 'a'. + fromRow :: [SqlValue] -> GP a + + -- | Converts a value of type 'a' to a database row. + toRow :: a -> GP [SqlValue] + + -- | Returns the name of the primary key field for a type 'a'. + idField :: a -> String + + -- | Returns a list of tuples that map field names to column names for a type 'a'. + fieldsToColumns :: a -> [(String, String)] + + -- | Returns the name of the table for a type 'a'. + tableName :: a -> String + + -- | generic default implementation + default fromRow :: [SqlValue] -> GP a + fromRow = pure . gFromRow + + -- | generic default implementation + default toRow :: a -> GP [SqlValue] + toRow = pure . gToRow + + -- | 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 + 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 + } + +type GP = RIO Ctx + +-- | 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) + +-- | 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)] + +-- | 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 + Just columnName -> columnName + Nothing -> error ("columnNameFor: " ++ toString x ++ + " 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) + +maybeFieldTypeFor :: Entity a => a -> String -> Maybe TypeRep +maybeFieldTypeFor a 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 + where + mappedRow = map fromSql (gToRow x) + +-- | 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 + + +evidenceFrom :: forall a. (Entity a) => TypeInfo a -> a +evidenceFrom = fromConstr . typeConstructor diff --git a/src/Database/GP/GenericPersistence.hs b/src/Database/GP/GenericPersistence.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP/GenericPersistence.hs @@ -0,0 +1,193 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Database.GP.GenericPersistence + ( retrieveById, + retrieveAll, + retrieveAllWhere, + persist, + insert, + update, + delete, + setupTableFor, + idValue, + Entity (..), + 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 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 + +{-- + This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'. + I call instances of such a data type Entities. + + The Persistence operations are using Haskell generics to provide compile time reflection capabilities. + HDBC is used to access the RDBMS. +--} + + + + +-- | 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] + case resultRowsSqlValues of + [] -> pure Nothing + [singleRow] -> Just <$> fromRow singleRow + _ -> error $ "More than one" ++ show (typeConstructor ti) ++ " found for id " ++ show eid + where + ti = typeInfoFromContext :: TypeInfo a + stmt = selectStmtFor ti + 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 + where + ti = typeInfoFromContext :: TypeInfo a + stmt = selectAllStmtFor ti + +retrieveAllWhere :: forall a. (Entity a) => String -> SqlValue -> GP [a] +retrieveAllWhere field val = do + conn <- askConnection + resultRows <- liftIO $ quickQuery conn stmt [val] + mapM fromRow resultRows + where + ti = typeInfoFromContext :: TypeInfo a + stmt = selectAllWhereStmtFor ti field + +-- | 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] + case resultRows of + [] -> insert entity + [_singleRow] -> update entity + _ -> error $ "More than one entity found for id " ++ show eid + where + ti = typeInfo entity + eid = idValue entity + preparedSelectStmt = selectStmtFor ti + +-- | 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 + + +-- | 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) + + +extendCtxCache :: Entity a => a -> Ctx -> Ctx +extendCtxCache x (Ctx conn rc) = Ctx conn (cacheEntry : rc) + where + cacheEntry = (entityId x, toDyn x) + + +-- | 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) + +-- | 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 + +askCache :: GP ResolutionCache +askCache = cache <$> ask + +runGP :: (MonadIO m, IConnection conn) => conn -> RIO Ctx a -> m a +runGP conn = runRIO (Ctx (ConnWrapper conn) mempty) + +-- 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 + safeConvert :: SqlValue -> ConvertResult a + safeConvert = Right . toEnum . fromSql + +instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible a SqlValue where + safeConvert :: a -> ConvertResult SqlValue + safeConvert = Right . toSql . fromEnum diff --git a/src/Database/GP/RecordtypeReflection.hs b/src/Database/GP/RecordtypeReflection.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP/RecordtypeReflection.hs @@ -0,0 +1,146 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Database/GP/SqlGenerator.hs @@ -0,0 +1,137 @@ +module Database.GP.SqlGenerator + ( insertStmtFor, + updateStmtFor, + selectStmtFor, + deleteStmtFor, + selectAllStmtFor, + selectAllWhereStmtFor, + createTableStmtFor, + dropTableStmtFor, + ) +where + +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 = + "INSERT INTO " + ++ tableName x + ++ " (" + ++ intercalate ", " columns + ++ ") VALUES (" + ++ intercalate ", " (params (length columns)) + ++ ");" + where + columns = columnNamesFor x + + +columnNamesFor :: Entity a => a -> [String] +columnNamesFor x = map snd fieldColumnPairs + where + fieldColumnPairs = fieldsToColumns x + + +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 = + "UPDATE " + ++ tableName x + ++ " SET " + ++ intercalate ", " updatePairs + ++ " WHERE " + ++ idColumn x + ++ " = ?" + ++ ";" + where + updatePairs = map (++ " = ?") (columnNamesFor x) + +idColumn :: Entity a => a -> String +idColumn x = columnNameFor x (idField x) + +-- | 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 = + "SELECT " + ++ intercalate ", " (columnNamesFor x) + ++ " FROM " + ++ tableName x + ++ " WHERE " + ++ idColumn x + ++ " = ?;" + where + x = evidenceFrom ti :: a + +selectAllStmtFor :: forall a. (Entity a) => TypeInfo a -> String +selectAllStmtFor ti = + "SELECT " + ++ intercalate ", " (columnNamesFor x) + ++ " FROM " + ++ tableName x + ++ ";" + where + x = evidenceFrom ti :: a + +selectAllWhereStmtFor :: forall a. (Entity a) => TypeInfo a -> String -> String +selectAllWhereStmtFor ti field = + "SELECT " + ++ intercalate ", " (columnNamesFor x) + ++ " FROM " + ++ tableName x + ++ " WHERE " + ++ column + ++ " = ?;" + where + x = evidenceFrom ti :: a + column = columnNameFor x field + +deleteStmtFor :: Entity a => a -> String +deleteStmtFor x = + "DELETE FROM " + ++ tableName x + ++ " WHERE " + ++ idColumn x + ++ " = ?;" + +createTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String +createTableStmtFor ti = + "CREATE TABLE " + ++ tableName x + ++ " (" + ++ intercalate ", " (map (\(f,c) -> c ++ " " ++ columnTypeFor x f ++ optionalPK f) (fieldsToColumns x)) + ++ ");" + where + x = evidenceFrom ti :: a + isIdField f = f == idField x + optionalPK f = if isIdField f then " PRIMARY KEY" else "" + + +columnTypeFor :: forall a. (Entity a) => a -> String -> String +columnTypeFor x field = + case fType of + "Int" -> "INTEGER" + "String" -> "TEXT" + "Double" -> "REAL" + "Float" -> "REAL" + "Bool" -> "INT" + _ -> "TEXT" + where + maybeFType = maybeFieldTypeFor x field + fType = maybe "OTHER" show maybeFType + + +dropTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String +dropTableStmtFor ti = + "DROP TABLE IF EXISTS " + ++ tableName x + ++ ";" + where + x = evidenceFrom ti :: a diff --git a/src/Database/GP/TypeInfo.hs b/src/Database/GP/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Database/GP/TypeInfo.hs @@ -0,0 +1,71 @@ +--{-# LANGUAGE RankNTypes #-} +--{-# LANGUAGE ScopedTypeVariables #-} +module Database.GP.TypeInfo + ( TypeInfo, + typeConstructor, + fieldNames, + fieldTypes, + typeName, + typeInfo, + typeInfoFromContext, + ) +where + +import Data.Data + +-- | 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, + fieldNames :: [String], + fieldTypes :: [TypeRep] + } + deriving (Show) + +-- | this function is a smart constructor for TypeInfo objects. +-- 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 + { typeConstructor = ensureSingleConstructor (dataTypeOf x), + fieldNames = fieldNamesOf x, + fieldTypes = gmapQ typeOf x + } + +-- | 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 ++ ")" + +-- | 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 + +-- | This function returns the (unqualified) type name of `a` from a `TypeInfo a` object. +typeName :: TypeInfo a -> String +typeName = dataTypeName . constrType . typeConstructor + +-- | 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" diff --git a/test/EmbeddedSpec.hs b/test/EmbeddedSpec.hs new file mode 100644 --- /dev/null +++ b/test/EmbeddedSpec.hs @@ -0,0 +1,83 @@ +module EmbeddedSpec + ( test + , spec + ) where + +import Test.Hspec +import Data.Data +import Database.HDBC +import Database.HDBC.Sqlite3 +import Database.GP.GenericPersistence +import RIO + +-- `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 + +data Article = Article + { articleID :: Int, + title :: String, + author :: Author, + year :: Int + } + deriving (Data, Show, Eq) + +data Author = Author + { authorID :: Int, + name :: String, + address :: String + } + deriving (Data, Show, Eq) + +instance Entity Article where + + fieldsToColumns :: Article -> [(String, String)] + fieldsToColumns _ = [("articleID", "articleID"), + ("title", "title"), + ("authorID", "authorID"), + ("authorName", "authorName"), + ("authorAddress", "authorAddress"), + ("year", "year") + ] + + fromRow row = return $ 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) + +article :: Article +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] + + diff --git a/test/EnumSpec.hs b/test/EnumSpec.hs new file mode 100644 --- /dev/null +++ b/test/EnumSpec.hs @@ -0,0 +1,60 @@ +module EnumSpec + ( test + , spec + ) where + +import Test.Hspec +import Data.Data +import Database.HDBC +import Database.HDBC.Sqlite3 +import Database.GP.GenericPersistence +import RIO + +-- `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 + +data Book = Book + { bookID :: Int, + title :: String, + author :: String, + year :: Int, + category :: BookCategory + } + deriving (Data, Show, Eq) + +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) + + 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 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] + + diff --git a/test/GenericPersistenceSpec.hs b/test/GenericPersistenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/GenericPersistenceSpec.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class +module GenericPersistenceSpec + ( test + , spec + , withDatabase + ) where + + +import Test.Hspec +import Data.Data +import Database.HDBC +import Database.HDBC.Sqlite3 +import Database.GP.GenericPersistence +import RIO + + + +-- `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 + +-- | A data type with several fields, using record syntax. +data Person = Person + { personID :: Int, + name :: String, + age :: Int, + address :: String + } + deriving (Data, Entity, Show, Eq) + +data Book = Book + { book_id :: Int, + title :: String, + author :: String, + year :: Int, + category :: BookCategory + } + deriving (Data, Show, Eq) + +data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other + deriving (Data, 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) + 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)] + + +person :: Person +person = Person 123456 "Alice" 25 "123 Main 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 + 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 + diff --git a/test/OneToManySpec.hs b/test/OneToManySpec.hs new file mode 100644 --- /dev/null +++ b/test/OneToManySpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class +module OneToManySpec + ( 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) + +-- `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 + +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) + +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)] + + +instance Entity Author where + fieldsToColumns :: Author -> [(String, String)] + fieldsToColumns _ = [("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} + where + col i = fromSql (row !! i) + rawAuthor = Author (col 0) (col 1) (col 2) [] + + toRow :: Author -> GP [SqlValue] + toRow a = do + return [toSql (authorID a), 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} + +article2 :: Article +article2 = Article + { articleID = 2, + title = "Boilerplate for Dummies", + author = arthur, + year = 2020} + +article3 :: Article +article3 = Article + { articleID = 3, + title = "The return of the boilerplate", + author = arthur, + year = 2022} + +arthur :: Author +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 + + 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" + + + + + diff --git a/test/ReferenceSpec.hs b/test/ReferenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReferenceSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class +module ReferenceSpec + ( test + , spec + ) where + +import Test.Hspec +import Data.Data +import Database.HDBC +import Database.HDBC.Sqlite3 +import Database.GP.GenericPersistence +import RIO + +-- `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 + +data Article = Article + { articleID :: Int, + title :: String, + author :: Author, + year :: Int + } + deriving (Data, Show, Eq) + +data Author = Author + { authorID :: Int, + name :: String, + address :: String + } + deriving (Data, Entity, Show, Eq) + +instance Entity Article where + fieldsToColumns :: Article -> [(String, String)] + fieldsToColumns _ = [("articleID", "articleID"), + ("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) + 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)] + +article :: Article +article = Article + { articleID = 1, + title = "Persistence without Boilerplate", + author = arthur, + year = 2018} + +arthur :: Author +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 + + + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# 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.