From 83c960bf4295bcd5f715ddea639b5f1530626601 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 2 Jul 2024 14:42:42 +0200 Subject: [PATCH 1/2] Implement `Database.Table` --- lib/delta-table/delta-table.cabal | 14 +- lib/delta-table/src/Database/Table.hs | 19 ++ .../src/Database/Table/SQL/Column.hs | 72 ++++ .../src/Database/Table/SQL/Table.hs | 88 +++++ lib/delta-table/src/Database/Table/Schema.hs | 153 +++++++++ lib/delta-table/src/Demo/Database.hs | 37 +++ lib/delta-table/src/Demo/TableOld.hs | 309 ------------------ 7 files changed, 377 insertions(+), 315 deletions(-) create mode 100644 lib/delta-table/src/Database/Table.hs create mode 100644 lib/delta-table/src/Database/Table/SQL/Column.hs create mode 100644 lib/delta-table/src/Database/Table/SQL/Table.hs create mode 100644 lib/delta-table/src/Database/Table/Schema.hs create mode 100644 lib/delta-table/src/Demo/Database.hs delete mode 100644 lib/delta-table/src/Demo/TableOld.hs diff --git a/lib/delta-table/delta-table.cabal b/lib/delta-table/delta-table.cabal index d3040ed4e12..1795f3d95d6 100644 --- a/lib/delta-table/delta-table.cabal +++ b/lib/delta-table/delta-table.cabal @@ -44,23 +44,25 @@ library hs-source-dirs: src build-depends: base + , bytestring , containers , delta-store , delta-types , exceptions - , generic-lens - , io-classes - , monad-logger - , persistent - , stm + , Only == 0.1 + , sqlite-simple , text , transformers hs-source-dirs: src exposed-modules: Data.Table + Database.Table + Demo.Database other-modules: - Demo.TableOld + Database.Table.Schema + Database.Table.SQL.Column + Database.Table.SQL.Table test-suite unit import: language, opts-exe diff --git a/lib/delta-table/src/Database/Table.hs b/lib/delta-table/src/Database/Table.hs new file mode 100644 index 00000000000..48e5ce5923c --- /dev/null +++ b/lib/delta-table/src/Database/Table.hs @@ -0,0 +1,19 @@ +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +The 'Table' data type represents a database table +in a relational database. +This type + +* tracks table and column names on the type level, and +* tracks Haskell types for table columns. + +However, this type is /not/ yet specific to +SQL or a particular database backend. +-} +module Database.Table + ( module Database.Table.Schema + ) where + +import Database.Table.Schema diff --git a/lib/delta-table/src/Database/Table/SQL/Column.hs b/lib/delta-table/src/Database/Table/SQL/Column.hs new file mode 100644 index 00000000000..50849a3b2e0 --- /dev/null +++ b/lib/delta-table/src/Database/Table/SQL/Column.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +SQL column types. +-} +module Database.Table.SQL.Column + ( + -- * SQL column types + SqlType + , escapeSqlType + + -- * Haskell types to SQL column types + , IsColumn (..) + ) where + +import Prelude + +import Data.ByteString + ( ByteString + ) +import Data.Text + ( Text + ) + +import qualified Database.SQLite.Simple.FromField as Sqlite +import qualified Database.SQLite.Simple.ToField as Sqlite + +{------------------------------------------------------------------------------- + Types for database columns +-------------------------------------------------------------------------------} +-- | SQL column types, including constraints. +-- Example values: +-- +-- > INTEGER PRIMARY KEY NOT NULL +-- > TEXT NOT NULL +newtype SqlType = SqlType Text + deriving (Eq,Ord,Show) + +escapeSqlType :: SqlType -> Text +escapeSqlType (SqlType x) = x + +-- | Class that maps a Haskell type to a column type of an SQL database. +-- Includes marshalling (via the `sqlite-simple` package). +class (Sqlite.ToField a, Sqlite.FromField a) => IsColumn a where + getSqlType :: proxy a -> SqlType + +instance IsColumn Int where + getSqlType _ = SqlType "INTEGER NOT NULL" + +instance IsColumn (Maybe Int) where + getSqlType _ = SqlType "INTEGER" + +instance IsColumn Text where + getSqlType _ = SqlType "TEXT NOT NULL" + +instance IsColumn (Maybe Text) where + getSqlType _ = SqlType "TEXT" + +instance IsColumn String where + getSqlType _ = SqlType "TEXT NOT NULL" + +instance IsColumn (Maybe String) where + getSqlType _ = SqlType "TEXT" + +instance IsColumn ByteString where + getSqlType _ = SqlType "BLOB NOT NULL" + +instance IsColumn (Maybe ByteString) where + getSqlType _ = SqlType "BLOB" diff --git a/lib/delta-table/src/Database/Table/SQL/Table.hs b/lib/delta-table/src/Database/Table/SQL/Table.hs new file mode 100644 index 00000000000..1ef09c5349d --- /dev/null +++ b/lib/delta-table/src/Database/Table/SQL/Table.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +'Table' types that can be mapped to SQL tables. +-} +module Database.Table.SQL.Table + ( -- * SQL tables + IsTableSql + , getColumnTypes + , HasColumns + ) where + +import Prelude + +import Data.Foldable + ( toList + ) +import Data.Proxy + ( Proxy (..) + ) +import Data.Sequence + ( Seq + , empty + , (|>) + ) +import Database.Table + ( Col + , IsTable + , Row + , Table + , (:.) + ) +import Database.Table.SQL.Column + ( IsColumn (getSqlType) + , SqlType + ) + +import qualified Database.SQLite.Simple as Sqlite + +{------------------------------------------------------------------------------- + Types for database tables +-------------------------------------------------------------------------------} + +{- | Constaint for types that represent tables with columns that can be +mapped to SQL tables. + +Note: Usage sites of this constraint synonym must +use the @FlexibleContexts@ extension. + +Typical instances of this constraint constructed from "Database.Table", +where the column types can be mapped from Haskell to SQL and vice-versa. +Example: + +@ +type ExampleTable = + Table "person" + :. Col "name" Text + :. Col "birthyear" Int +@ +-} +type IsTableSql t = + ( IsTable t + , HasColumns t + , Sqlite.ToRow (Row t) + , Sqlite.FromRow (Row t) + ) + +getColumnTypes :: IsTableSql t => proxy t -> [SqlType] +getColumnTypes = toList . getColumnTypesD + +-- | Class for types that correspond to a list of SQL types. +class HasColumns t where + getColumnTypesD :: proxy t -> Seq SqlType + +instance HasColumns (Table name) where + getColumnTypesD _ = empty + +instance (HasColumns t, IsColumn a) => HasColumns (t :. Col name a) where + getColumnTypesD _ = + getColumnTypesD (Proxy :: Proxy t) + |> getSqlType (Proxy :: Proxy a) diff --git a/lib/delta-table/src/Database/Table/Schema.hs b/lib/delta-table/src/Database/Table/Schema.hs new file mode 100644 index 00000000000..f826c0ddd70 --- /dev/null +++ b/lib/delta-table/src/Database/Table/Schema.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +'Table' represents the schema for a database table. + +-} +module Database.Table.Schema + ( + -- * Table types + IsTable (..) + , getColNames + , ExampleTable + , Table (..) + , Col (..) + , (:.) (..) + + -- * Rows + , Row + , Only (..) + , exampleRow + ) where + +import Prelude + +import Data.Foldable + ( toList + ) +import Data.Proxy + ( Proxy (..) + ) +import Data.Sequence + ( Seq + , empty + , (|>) + ) +import Data.Text + ( Text + ) +import Data.Tuple.Only + ( Only (..) + ) +import GHC.TypeLits + ( KnownSymbol + , Symbol + , symbolVal + ) + +import qualified Data.Text as T + +{------------------------------------------------------------------------------- + Class +-------------------------------------------------------------------------------} +-- | Class of named tables with named columns. +-- +-- The data contained in the table is essentially a list of rows +-- with the given column names. +class IsTable t where + getTableName :: proxy t -> Text + getColNamesSeq :: proxy t -> Seq Text + +getColNames :: IsTable t => proxy t -> [Text] +getColNames = toList . getColNamesSeq + +{------------------------------------------------------------------------------- + Type +-------------------------------------------------------------------------------} +-- | Infix notation for a pair of types. +data a :. b = a :. b + deriving (Eq,Ord,Show,Read) +infixl 3 :. + +-- | Named database column. +data Col (name :: Symbol) a = Col + deriving (Eq,Ord,Show) + +-- | Named database table. +data Table (name :: Symbol) = Table + deriving (Eq,Ord,Show) + +instance KnownSymbol name => IsTable (Table name) where + getTableName _ = T.pack $ symbolVal (Proxy :: Proxy name) + getColNamesSeq _ = empty + +instance (IsTable t, KnownSymbol name) => IsTable (t :. Col name a) where + getTableName _ = getTableName (Proxy :: Proxy t) + getColNamesSeq _ = + getColNamesSeq (Proxy :: Proxy t) + |> T.pack (symbolVal (Proxy :: Proxy name)) + +-- | Example 'Table' type. +type ExampleTable = + Table "person" + :. Col "name" Text + :. Col "birthyear" Int + +-- | > exampleRow = ("Ada Lovelace", 1815) +exampleRow :: Row ExampleTable +exampleRow = ("Ada Lovelace", 1815) + +{------------------------------------------------------------------------------- + Columns +-------------------------------------------------------------------------------} +-- | Type family +-- that maps a table schema @t@ (which ideally satisfies @IsTable t@) +-- to a type representing rows of that table. +type family Row t + +type instance Row (Table n0 :. Col n1 a1) = + Only a1 + +type instance Row (Table n0 :. Col n1 a1 :. Col n2 a2) = + (a1, a2) + +type instance Row (Table n0 :. Col n1 a1 :. Col n2 a2 :. Col n3 a3) = + (a1, a2, a3) + +type instance + Row (Table n0 + :. Col n1 a1 + :. Col n2 a2 + :. Col n3 a3 + :. Col n4 a4 + ) = + (a1, a2, a3, a4) + +type instance + Row (Table n0 + :. Col n1 a1 + :. Col n2 a2 + :. Col n3 a3 + :. Col n4 a4 + :. Col n5 a5 + ) = + (a1, a2, a3, a4, a5) + +type instance + Row (Table n0 + :. Col n1 a1 + :. Col n2 a2 + :. Col n3 a3 + :. Col n4 a4 + :. Col n5 a5 + :. Col n6 a6 + ) = + (a1, a2, a3, a4, a5, a6) diff --git a/lib/delta-table/src/Demo/Database.hs b/lib/delta-table/src/Demo/Database.hs new file mode 100644 index 00000000000..82da7a846b1 --- /dev/null +++ b/lib/delta-table/src/Demo/Database.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +Demonstration for 'Table' type. + +-} +module Demo.Database where + +import Prelude + +import Data.Proxy + ( Proxy (..) + ) +import Data.Text + ( Text + ) +import Database.Table + ( Col + , Row + , Table + , (:.) + ) + +{----------------------------------------------------------------------------- + Test +------------------------------------------------------------------------------} +type TablePerson = + Table "person" + :. Col "name" Text + :. Col "birthyear" Int + +tablePerson :: Proxy TablePerson +tablePerson = Proxy diff --git a/lib/delta-table/src/Demo/TableOld.hs b/lib/delta-table/src/Demo/TableOld.hs deleted file mode 100644 index 8579dad7b35..00000000000 --- a/lib/delta-table/src/Demo/TableOld.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- TODO: https://cardanofoundation.atlassian.net/browse/ADP-2841 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module Demo.TableOld ( - -- * Synopsis - -- | Typed database tables and rows. - - -- * Database columns - IsCol (..), SqlColType (..) - , toColType - , Primary (..) - - -- * Database rows and tables - , Table (..), Col (..), (:.) (..) - , IsRow (..) - - -- * SQL Queries - , Query, callSql, runSql - , createTable, selectAll, insertOne, repsertOne, updateOne, deleteAll, deleteOne - - -- * Testing - , testPerson - ) where - -import Prelude - -import Control.Monad.IO.Class - ( MonadIO - ) -import Data.Proxy - ( Proxy (..) - ) -import Data.Text - ( Text - ) -import Database.Persist - ( PersistField (..) - , PersistValue - ) -import Database.Persist.Sql - ( PersistFieldSql (..) - , RawSql (..) - , SqlPersistT - , SqlType (..) - ) -import GHC.TypeLits - ( KnownSymbol - , Symbol - , symbolVal - ) - -import qualified Data.Text as T -import qualified Database.Persist.Sql as Persist - -{------------------------------------------------------------------------------- - Types for database columns --------------------------------------------------------------------------------} --- | Primary key. -newtype Primary = Primary { getPrimary :: Int } - deriving (Eq,Ord,Show) - --- | SQL column types, including constraints. --- Values of type 'SqlColType' represent SQL types such as --- --- > INTEGER PRIMARY KEY NOT NULL --- > TEXT NOT NULL -newtype SqlColType = SqlColType Text - deriving (Eq,Ord,Show) - --- | Helper for converting 'SqlType' into an SQL column type with constraints. -toColType :: Persist.SqlType -> SqlColType -toColType SqlString = SqlColType "TEXT" -toColType SqlInt32 = SqlColType "INTEGER" -toColType SqlInt64 = SqlColType "INTEGER" -toColType x = error $ "toColType: case not implemented: " <> show x - -escapeSqlType :: SqlColType -> Text -escapeSqlType (SqlColType x) = x - --- | Class of columns that can be stored in database tables. -class PersistField a => IsCol a where - getSqlType :: Proxy a -> SqlColType - -instance {-# OVERLAPPABLE #-} (PersistField a, PersistFieldSql a) => IsCol a where - getSqlType = toColType . sqlType - -instance PersistField Primary where - toPersistValue = toPersistValue . getPrimary - fromPersistValue = fmap Primary . fromPersistValue - -instance IsCol Primary where - getSqlType _ = SqlColType "INTEGER NOT NULL PRIMARY KEY" - -instance IsCol Int where - getSqlType _ = SqlColType "INTEGER NOT NULL" - -instance IsCol (Maybe Int) where - getSqlType _ = SqlColType "INTEGER" - -{------------------------------------------------------------------------------- - Types for database tables and rows --------------------------------------------------------------------------------} --- | Infix notation for a pair of types. -data a :. b = a :. b - deriving (Eq,Ord,Show,Read) -infixl 3 :. - --- | Named database column. -newtype Col (name :: Symbol) a = Col a - deriving (Eq,Ord,Show) - --- | Named database table. -data Table (name :: Symbol) = Table - deriving (Eq,Ord,Show) - --- | Class of row types that can be stored in database tables. --- Instances of this class are essentially lists of columns. --- Example: --- --- > type PersonRow = Table "person" :. Col "name" Text :. Col "age" Int -class IsRow row where - getTableName :: Proxy row -> Text - getColNames :: Proxy row -> [Text] - getSqlTypes :: Proxy row -> [SqlColType] - - toSqlValues :: row -> [PersistValue] - fromSqlValues :: [PersistValue] -> Either Text row - -instance KnownSymbol name => IsRow (Table name) where - getTableName _ = T.pack $ symbolVal (Proxy :: Proxy name) - getColNames _ = [] - getSqlTypes _ = [] - - toSqlValues _ = [] - fromSqlValues [] = Right Table - fromSqlValues _ = Left "Table should contain zero rows" - --- FIXME: O(n^2) when getting the values! -instance (IsRow row, KnownSymbol name, IsCol a) - => IsRow (row :. Col name a) - where - getTableName _ = getTableName (Proxy :: Proxy row) - getColNames _ = getColNames (Proxy :: Proxy row) - ++ [T.pack $ symbolVal (Proxy :: Proxy name)] - getSqlTypes _ = getSqlTypes (Proxy :: Proxy row) - ++ [getSqlType (Proxy :: Proxy a)] - - toSqlValues (cs :. Col a) = toSqlValues cs ++ [toPersistValue a] - - fromSqlValues xs = case xs of - [] -> Left $ "Expected column " <> colname - _ -> case fromSqlValues (init xs) of - Left e -> Left e - Right cs -> case fromPersistValue (last xs) of - Left e -> Left $ "Column " <> colname <> ": " <> e - Right c -> Right $ cs :. Col c - where - colname = T.pack $ symbolVal (Proxy :: Proxy name) - -{------------------------------------------------------------------------------- - Types test --------------------------------------------------------------------------------} -type PersonRow = Table "person" - :. Col "name" Text :. Col "birth" Int :. Col "id" Primary - -testPerson :: PersonRow -testPerson = Table :. Col "Ada Lovelace" :. Col 1815 :. Col (Primary 0) - -{------------------------------------------------------------------------------- - Connect with Persistent --------------------------------------------------------------------------------} -newtype Wrap a = Wrap { unWrap :: a } - -instance IsRow row => RawSql (Wrap row) where - rawSqlCols _ _ = (length n, []) - where n = getColNames (Proxy :: Proxy row) - rawSqlColCountReason _ = T.unpack $ - "Table " <> getTableName proxy <> " has columns " - <> mkTuple (getColNames proxy) - where proxy = Proxy :: Proxy row - rawSqlProcessRow = fmap Wrap . fromSqlValues - --- | Run an SQL query and return a list of rows as result. -callSql :: (MonadIO m, IsRow row) - => Query row - -> SqlPersistT m [row] -callSql Query{stmt,params} = map unWrap <$> Persist.rawSql stmt params - --- | Execute an SQL query, but do not return any results -runSql :: MonadIO m => Query () -> SqlPersistT m () -runSql Query{stmt,params} = Persist.rawExecute stmt params - -{------------------------------------------------------------------------------- - SQL queries --------------------------------------------------------------------------------} --- | An SQL query that returns a list of values of type @row@. -data Query row = Query - { stmt :: Text - -- ^ SQL statement containing placeholders \"?\" which are - -- replaced by the parameters - , params :: [PersistValue] - -- ^ Parameters to insert into the SQL statement. - } deriving (Eq, Show) - --- | Escape a column or table name. --- --- FIXME: Use a newtype for more type safety. --- 'Query' used to be this newtype, but that has changed --- due to the 'params' field. -escape :: Text -> Text -escape s = "\"" <> s <> "\"" - --- | Helper for making a syntactically correct SQL tuple. -mkTuple :: [Text] -> Text -mkTuple xs = "(" <> T.intercalate ", " xs <> ")" - --- | Create a database table that can store the given rows. -createTable :: IsRow row => Proxy row -> Query () -createTable proxy = Query - { stmt = - "CREATE TABLE IF NOT EXISTS " <> table - <> " " <> mkTuple cols <> ";" - , params = [] - } - where - table = escape $ getTableName proxy - cols = zipWith (\name typ -> escape name <> " " <> escapeSqlType typ) - (getColNames proxy) (getSqlTypes proxy) - --- | Select all rows from the table. -selectAll :: forall row. IsRow row => Query row -selectAll = Query - { stmt = "SELECT " <> T.intercalate "," cols <> " FROM " <> table <> ";" - , params = [] - } - where - proxy = Proxy :: Proxy row - table = escape $ getTableName proxy - cols = map escape $ getColNames proxy - --- | Insert a single row into the corresponding table. -insertOne :: forall row. IsRow row => row -> Query () -insertOne row = Query - { stmt = - "INSERT INTO " <> table <> " " <> mkTuple cols - <> " VALUES " <> mkTuple ("?" <$ cols) <> ";" - , params = toSqlValues row - } - where - proxy = Proxy :: Proxy row - table = escape $ getTableName proxy - cols = map escape $ getColNames proxy - --- | Replace or insert a single row with a primary key into a database. --- --- FIXME: It would be nicer if the "id" column was the first column --- instead of the last column in the table. -repsertOne :: forall row. IsRow row - => (row :. Col "id" Primary) -> Query () -repsertOne row = Query - { stmt = - "INSERT OR REPLACE INTO " <> table <> " " <> mkTuple cols - <> " VALUES " <> mkTuple ("?" <$ cols) <> ";" - , params = toSqlValues row - } - where - proxy = Proxy :: Proxy (row :. Col "id" Primary) - table = escape $ getTableName proxy - cols = map escape $ getColNames proxy - --- | Update one row with a given \"id\" column in a database table. -updateOne :: forall row. IsRow row - => (row :. Col "id" Primary) -> Query () -updateOne row= Query - { stmt = "UPDATE " <> table <> " SET " <> sets <> " WHERE \"id\"=?;" - , params = toSqlValues row - } - where - proxy = Proxy :: Proxy row - table = escape $ getTableName proxy - cols = map escape $ getColNames proxy - sets = T.intercalate ", " [col <> "=?" | col <- cols] - --- | Delete one row with a given \"id\" column in a database table. -deleteOne :: forall row. IsRow row => Proxy row -> Col "id" Primary -> Query () -deleteOne proxy (Col key) = Query - { stmt = "DELETE FROM " <> table <> " WHERE \"id\"=?;" - , params = [Persist.toPersistValue key] - } - where - table = escape $ getTableName proxy - --- | Delete all rows in a database table -deleteAll :: forall row. IsRow row => Proxy row -> Query () -deleteAll proxy = Query - { stmt = "DELETE FROM " <> table - , params = [] - } - where - table = escape $ getTableName proxy From 07ee1edb535b6118241fd5161e08dc556fe9610d Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Sat, 13 Jul 2024 12:53:04 +0200 Subject: [PATCH 2/2] Implement SQL statements without `WHERE` clause --- lib/delta-table/delta-table.cabal | 3 + .../src/Database/Table/SQL/Stmt.hs | 119 ++++++++++++++++++ .../src/Database/Table/SQLite/Simple.hs | 22 ++++ .../src/Database/Table/SQLite/Simple/Exec.hs | 99 +++++++++++++++ lib/delta-table/src/Demo/Database.hs | 20 +++ 5 files changed, 263 insertions(+) create mode 100644 lib/delta-table/src/Database/Table/SQL/Stmt.hs create mode 100644 lib/delta-table/src/Database/Table/SQLite/Simple.hs create mode 100644 lib/delta-table/src/Database/Table/SQLite/Simple/Exec.hs diff --git a/lib/delta-table/delta-table.cabal b/lib/delta-table/delta-table.cabal index 1795f3d95d6..214c03b3d5b 100644 --- a/lib/delta-table/delta-table.cabal +++ b/lib/delta-table/delta-table.cabal @@ -58,11 +58,14 @@ library exposed-modules: Data.Table Database.Table + Database.Table.SQLite.Simple Demo.Database other-modules: Database.Table.Schema Database.Table.SQL.Column + Database.Table.SQL.Stmt Database.Table.SQL.Table + Database.Table.SQLite.Simple.Exec test-suite unit import: language, opts-exe diff --git a/lib/delta-table/src/Database/Table/SQL/Stmt.hs b/lib/delta-table/src/Database/Table/SQL/Stmt.hs new file mode 100644 index 00000000000..5bdca8c5224 --- /dev/null +++ b/lib/delta-table/src/Database/Table/SQL/Stmt.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +SQL statements for typed database tables. +-} +module Database.Table.SQL.Stmt + ( + -- * SQL statements + Stmt + , renderStmt + + -- * Specific statements + , createTable + , selectAll + , insertOne + , deleteAll + ) where + +import Prelude + +import Data.Text + ( Text + ) +import Database.Table + ( IsTable (getTableName) + , getColNames + , getTableName + ) +import Database.Table.SQL.Column + ( SqlType + , escapeSqlType + ) +import Database.Table.SQL.Table + ( IsTableSql + , getColumnTypes + ) + +import qualified Data.Text as T + +{------------------------------------------------------------------------------- + SQL Statements +-------------------------------------------------------------------------------} +type TableName = Text +type ColumnName = Text + +-- | A subset of SQL statements. +data Stmt where + CreateTable :: TableName -> [(ColumnName, SqlType)] -> Stmt + Select :: [ColumnName] -> TableName -> Where -> Stmt + Insert :: TableName -> [ColumnName] -> Stmt + Delete :: TableName -> Where -> Stmt + +-- | An SQL @WHERE@ clause. +data Where where + All :: Where + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} +-- | Render an statement as SQL source code. +renderStmt :: Stmt -> Text +renderStmt (CreateTable table cols) = + "CREATE TABLE IF NOT EXISTS " + <> renderName table + <> " " <> renderTuple (map renderCol cols) + <> ";" + where + renderCol (col, typ)= renderName col <> " " <> escapeSqlType typ +renderStmt (Insert table cols) = + "INSERT INTO " + <> renderName table + <> " " <> renderTuple (map renderName cols) + <> " VALUES " <> renderTuple ("?" <$ cols) + <> ";" +renderStmt (Select cols table All) = + "SELECT " <> T.intercalate "," (map renderName cols) + <> " FROM " <> renderName table + <> ";" +renderStmt (Delete table All) = + "DELETE FROM " <> renderName table + +-- | Escape a column or table name. +renderName :: Text -> Text +renderName s = "\"" <> s <> "\"" + +-- | Render a tuple +renderTuple :: [Text] -> Text +renderTuple xs = "(" <> T.intercalate ", " xs <> ")" + +{------------------------------------------------------------------------------- + SQL queries +-------------------------------------------------------------------------------} + +-- | Create a database table. +createTable :: IsTableSql t => proxy t -> Stmt +createTable proxy = + CreateTable + (getTableName proxy) + (zip (getColNames proxy) (getColumnTypes proxy)) + +-- | Select all rows from the table. +selectAll :: IsTableSql t => proxy t -> Stmt +selectAll proxy = + Select (getColNames proxy) (getTableName proxy) All + +-- | Insert one row into the corresponding table. +insertOne :: IsTableSql t => proxy t -> Stmt +insertOne proxy = + Insert (getTableName proxy) (getColNames proxy) + +-- | Delete all rows from a database table +deleteAll :: IsTableSql t => proxy t -> Stmt +deleteAll proxy = + Delete (getTableName proxy) All diff --git a/lib/delta-table/src/Database/Table/SQLite/Simple.hs b/lib/delta-table/src/Database/Table/SQLite/Simple.hs new file mode 100644 index 00000000000..344a13b3042 --- /dev/null +++ b/lib/delta-table/src/Database/Table/SQLite/Simple.hs @@ -0,0 +1,22 @@ +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +Storing 'Table' in SQLite databases. + +This module is meant to be imported qualified, e.g. + +@ +import qualified Database.Table.SQLite.Simple as Sqlite +@ +-} +module Database.Table.SQLite.Simple + ( + module Database.Table.SQL.Table + , module Database.Table.SQLite.Simple.Exec + , module Database.Table.SQL.Column + ) where + +import Database.Table.SQL.Column +import Database.Table.SQL.Table +import Database.Table.SQLite.Simple.Exec diff --git a/lib/delta-table/src/Database/Table/SQLite/Simple/Exec.hs b/lib/delta-table/src/Database/Table/SQLite/Simple/Exec.hs new file mode 100644 index 00000000000..003b787f34c --- /dev/null +++ b/lib/delta-table/src/Database/Table/SQLite/Simple/Exec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +Execute SQL statements for typed database tables. +-} +module Database.Table.SQLite.Simple.Exec + ( + -- * SQL monad + SqlM + , runSqlM + + -- * SQL statements + , createTable + , selectAll + , insertOne + , insertMany + , deleteAll + ) where + +import Prelude + +import Control.Monad.Trans.Reader + ( ReaderT (..) + ) +import Data.Foldable + ( for_ + ) +import Database.Table + ( Row + ) +import Database.Table.SQL.Table + ( IsTableSql + ) + +import qualified Database.SQLite.Simple as Sqlite +import qualified Database.Table.SQL.Stmt as Stmt + +{------------------------------------------------------------------------------- + SQL monad +-------------------------------------------------------------------------------} +-- | Monad to run SQL queries in. +-- +-- This monad includes effects such as +-- +-- * mutable state +-- * exceptions +-- * concurrency +-- +-- This type makes no attempt at handling these, you have to do that yourself. +-- For example, in order to handle exception, consider using +-- 'Sqlite.withTransaction'. +-- +-- FIXME: No, we do have handle these types of things. +type SqlM = ReaderT Sqlite.Connection IO + +-- | Run a computation from the 'SqlM' monad. +runSqlM :: SqlM a -> Sqlite.Connection -> IO a +runSqlM = runReaderT + +{------------------------------------------------------------------------------- + Helpers +-------------------------------------------------------------------------------} +mkQuery :: Stmt.Stmt -> Sqlite.Query +mkQuery = Sqlite.Query . Stmt.renderStmt + +query_ :: Sqlite.FromRow row => Stmt.Stmt -> SqlM [row] +query_ stmt = + ReaderT $ \conn -> Sqlite.query_ conn (mkQuery stmt) + +executeOne :: Sqlite.ToRow row => Stmt.Stmt -> row -> SqlM () +executeOne stmt row = + ReaderT $ \conn -> Sqlite.execute conn (mkQuery stmt) row + +execute_ :: Stmt.Stmt -> SqlM () +execute_ stmt = + ReaderT $ \conn -> Sqlite.execute_ conn (mkQuery stmt) + +{------------------------------------------------------------------------------- + SQL statements +-------------------------------------------------------------------------------} +createTable :: IsTableSql t => proxy t -> SqlM () +createTable = execute_ . Stmt.createTable + +selectAll :: IsTableSql t => proxy t -> SqlM [Row t] +selectAll = query_ . Stmt.selectAll + +insertOne :: IsTableSql t => Row t -> proxy t -> SqlM () +insertOne row proxy = executeOne (Stmt.insertOne proxy) row + +insertMany :: IsTableSql t => [Row t] -> proxy t -> SqlM () +insertMany rows proxy = for_ rows (`insertOne` proxy) + +deleteAll :: IsTableSql t => proxy t -> SqlM () +deleteAll = execute_ . Stmt.deleteAll diff --git a/lib/delta-table/src/Demo/Database.hs b/lib/delta-table/src/Demo/Database.hs index 82da7a846b1..4c5e309f365 100644 --- a/lib/delta-table/src/Demo/Database.hs +++ b/lib/delta-table/src/Demo/Database.hs @@ -12,6 +12,9 @@ module Demo.Database where import Prelude +import Data.Foldable + ( for_ + ) import Data.Proxy ( Proxy (..) ) @@ -25,6 +28,9 @@ import Database.Table , (:.) ) +import qualified Database.SQLite.Simple as Sqlite +import qualified Database.Table.SQLite.Simple as Sql + {----------------------------------------------------------------------------- Test ------------------------------------------------------------------------------} @@ -35,3 +41,17 @@ type TablePerson = tablePerson :: Proxy TablePerson tablePerson = Proxy + +action :: Sql.SqlM [Row TablePerson] +action = do + Sql.createTable tablePerson + Sql.insertOne ("Neko", 1603) tablePerson + Sql.deleteAll tablePerson + Sql.insertOne ("William", 1805) tablePerson + Sql.insertOne ("Ada", 1815) tablePerson + Sql.selectAll tablePerson + +main :: IO () +main = do + rows <- Sqlite.withConnection ":memory:" $ Sql.runSqlM action + for_ rows print