diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,14 @@ # Revision history for Selda +## 0.1.12 -- 2018-01-11 + +* Allow recursive and optional foreign keys. +* Allow arbitrary enums in tables, represented as text. +* Fix RowID issues for PostgreSQL. +* Fix auto-incrementing primary keys for generic tables. + + ## 0.1.11.2 -- 2017-12-14 * Fix treatment of booleans in PostgreSQL backend. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ Selda ===== + +[![Join the chat at https://gitter.im/selda-hs/Lobby](https://badges.gitter.im/selda-hs/Lobby.svg)](https://gitter.im/selda-hs/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Hackage](https://img.shields.io/hackage/v/selda.svg?style=flat)](http://hackage.haskell.org/package/selda) [![IRC channel](https://img.shields.io/badge/IRC-%23selda-1e72ff.svg?style=flat)](https://www.irccloud.com/invite?channel=%23selda&hostname=irc.freenode.net&port=6697&ssl=1) ![MIT License](http://img.shields.io/badge/license-MIT-brightgreen.svg) diff --git a/selda.cabal b/selda.cabal --- a/selda.cabal +++ b/selda.cabal @@ -1,6 +1,6 @@ name: selda -version: 0.1.11.2 -synopsis: Type-safe, high-level EDSL for interacting with relational databases. +version: 0.1.12 +synopsis: Multi-backend, high-level EDSL for interacting with SQL databases. description: This package provides an EDSL for writing portable, type-safe, high-level database code. Its feature set includes querying and modifying databases, automatic, in-process caching with consistency guarantees, and transaction diff --git a/src/Database/Selda.hs b/src/Database/Selda.hs --- a/src/Database/Selda.hs +++ b/src/Database/Selda.hs @@ -69,7 +69,7 @@ , query, transaction, setLocalCache -- * Constructing queries , Selector, (!), Assignment(..), with - , SqlType (..) + , SqlType (..), SqlEnum (..) , Cols, Columns , Order (..) , (:*:)(..) @@ -107,10 +107,10 @@ , table, tableWithSelectors, selectors , required, optional , primary, autoPrimary - , fk, unique + , fk, optFk, unique -- * Creating and dropping tables , createTable, tryCreateTable - , dropTable, tryDropTable + , validateTable, dropTable, tryDropTable -- * Compiling and inspecting queries , OnError (..) , compile @@ -153,6 +153,13 @@ instance SqlOrd UTCTime instance SqlOrd TimeOfDay instance SqlOrd a => SqlOrd (Maybe a) + +-- | Validate a table schema. +-- Throws a 'ValidationError' if the schema does not validate. +-- Currently does not check the schema against what's actually in the +-- current database. +validateTable :: MonadSelda m => Table a -> m () +validateTable t = validate (tableName t) (tableCols t) `seq` return () -- | Convenient shorthand for @fmap (! sel) q@. -- The following two queries are quivalent: diff --git a/src/Database/Selda/SQL/Print.hs b/src/Database/Selda/SQL/Print.hs --- a/src/Database/Selda/SQL/Print.hs +++ b/src/Database/Selda/SQL/Print.hs @@ -210,6 +210,11 @@ c <- ppConfig <$> get pure $ Cfg.ppType c t +ppTypePK :: SqlTypeRep -> PP Text +ppTypePK t = do + c <- ppConfig <$> get + pure $ Cfg.ppTypePK c t + ppCol :: Exp SQL a -> PP Text ppCol (TblCol xs) = error $ "compiler bug: ppCol saw TblCol: " ++ show xs ppCol (Col name) = pure (fromColName name) diff --git a/src/Database/Selda/SQL/Print/Config.hs b/src/Database/Selda/SQL/Print/Config.hs --- a/src/Database/Selda/SQL/Print/Config.hs +++ b/src/Database/Selda/SQL/Print/Config.hs @@ -8,8 +8,16 @@ -- | Backend-specific configuration for the SQL pretty-printer. data PPConfig = PPConfig { -- | The SQL type name of the given type. + -- + -- This function should be used everywhere a type is needed to be printed but in primary + -- keys position. This is due to the fact that some backends might have a special + -- representation of primary keys (using sequences are such). If you have such a need, + -- please use the 'ppTypePK' record instead. ppType :: SqlTypeRep -> Text + -- | The SQL type name of the given type for primary keys uses. + , ppTypePK :: SqlTypeRep -> Text + -- | Parameter placeholder for the @n@th parameter. , ppPlaceholder :: Int -> Text @@ -31,9 +39,13 @@ -- | Default settings for pretty-printing. -- Geared towards SQLite. +-- +-- The default definition of 'ppTypePK' is 'defType, so that you don’t have to do anything +-- special if you don’t use special types for primary keys. defPPConfig :: PPConfig defPPConfig = PPConfig { ppType = defType + , ppTypePK = defType , ppPlaceholder = T.cons '$' . T.pack . show , ppColAttrs = T.unwords . map defColAttr , ppAutoIncInsert = "NULL" diff --git a/src/Database/Selda/SqlType.hs b/src/Database/Selda/SqlType.hs --- a/src/Database/Selda/SqlType.hs +++ b/src/Database/Selda/SqlType.hs @@ -1,10 +1,11 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- | Types representable in Selda's subset of SQL. module Database.Selda.SqlType - ( Lit (..), RowID, SqlValue (..), SqlType, SqlTypeRep (..) + ( SqlType (..), SqlEnum (..) + , Lit (..), RowID, SqlValue (..), SqlTypeRep (..) , invalidRowId, isInvalidRowId, unsafeRowId, fromRowId - , mkLit, sqlType, litType, fromSql, defaultValue - , compLit + , compLit, litType , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat ) where import Data.ByteString (ByteString, empty) @@ -57,6 +58,23 @@ -- | Default value when using 'def' at this type. defaultValue :: Lit a +-- | Any type that's bounded, enumerable and has a text representation, and +-- thus representable as a Selda enumerable. +-- +-- While it would be more efficient to store enumerables as integers, this +-- makes hand-rolled SQL touching the values inscrutable, and will break if +-- the user a) derives Enum and b) changes the order of their constructors. +-- Long-term, this should be implemented in PostgreSQL as a proper enum +-- anyway, which mostly renders the performance argument moot. +class (Typeable a, Bounded a, Enum a) => SqlEnum a where + toText :: a -> Text + fromText :: Text -> a + +instance {-# OVERLAPPABLE #-} + (Typeable a, Bounded a, Enum a, Show a, Read a) => SqlEnum a where + toText = pack . show + fromText = read . unpack + -- | An SQL literal. data Lit a where LText :: !Text -> Lit Text @@ -267,3 +285,9 @@ fromSql (SqlNull) = Nothing fromSql x = Just $ fromSql x defaultValue = LNull + +instance {-# OVERLAPPABLE #-} (Typeable a, SqlEnum a) => SqlType a where + mkLit = LCustom . LText . toText + sqlType _ = sqlType (Proxy :: Proxy Text) + fromSql = fromText . fromSql + defaultValue = LCustom $ mkLit (toText (minBound :: a)) diff --git a/src/Database/Selda/Table.hs b/src/Database/Selda/Table.hs --- a/src/Database/Selda/Table.hs +++ b/src/Database/Selda/Table.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} -- | Selda table definition language. module Database.Selda.Table where import Database.Selda.Types @@ -34,20 +34,20 @@ -- non-empty. Column names must be unique per table. data Table a = Table { -- | Name of the table. NOT guaranteed to be a valid SQL name. - tableName :: !TableName + tableName :: TableName -- | All table columns. -- Invariant: the 'colAttrs' list of each column is sorted and contains -- no duplicates. - , tableCols :: ![ColInfo] + , tableCols :: [ColInfo] -- | Does the given table have an auto-incrementing primary key? - , tableHasAutoPK :: !Bool + , tableHasAutoPK :: Bool } data ColInfo = ColInfo - { colName :: !ColName - , colType :: !SqlTypeRep - , colAttrs :: ![ColAttr] - , colFKs :: ![(Table (), ColName)] + { colName :: ColName + , colType :: SqlTypeRep + , colAttrs :: [ColAttr] + , colFKs :: [(Table (), ColName)] } newCol :: forall a. SqlType a => ColName -> ColSpec a @@ -135,7 +135,7 @@ , tableHasAutoPK = Prelude.any ((AutoIncrement `elem`) . colAttrs) tcs } where - tcs = validate name $ map tidy $ mergeSpecs (Proxy :: Proxy a) cs + tcs = map tidy $ mergeSpecs (Proxy :: Proxy a) cs -- | Remove duplicate attributes. tidy :: ColInfo -> ColInfo diff --git a/src/Database/Selda/Table/Compile.hs b/src/Database/Selda/Table/Compile.hs --- a/src/Database/Selda/Table/Compile.hs +++ b/src/Database/Selda/Table/Compile.hs @@ -2,12 +2,13 @@ -- | Generating SQL for creating and deleting tables. module Database.Selda.Table.Compile where import Database.Selda.Table -import Data.List (foldl') +import Data.List ((\\), foldl') import Data.Monoid import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text import Database.Selda.SQL hiding (params, param) import Database.Selda.SQL.Print.Config +import Database.Selda.SqlType (SqlTypeRep(..)) import Database.Selda.Types data OnError = Fail | Ignore @@ -15,7 +16,7 @@ -- | Compile a @CREATE TABLE@ query from a table definition. compileCreateTable :: PPConfig -> OnError -> Table a -> Text -compileCreateTable customColType ifex tbl = mconcat +compileCreateTable customColType ifex tbl = ensureValid `seq` mconcat [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "(" , intercalate ", " (map (compileTableCol customColType) (tableCols tbl)) , case allFKs of @@ -28,6 +29,7 @@ ifNotExists Ignore = "IF NOT EXISTS " allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci] compFKs = zipWith (uncurry compileFK) allFKs [0..] + ensureValid = validate (tableName tbl) (tableCols tbl) -- | Compile a foreign key constraint. compileFK :: ColName -> (Table (), ColName) -> Int -> Text @@ -41,9 +43,16 @@ -- | Compile a table column. compileTableCol :: PPConfig -> ColInfo -> Text compileTableCol cfg ci = Text.unwords - [ fromColName (colName ci) - , ppType cfg (colType ci) <> " " <> ppColAttrs cfg (colAttrs ci) - ] + [ fromColName (colName ci) + , ppType' cfg cty <> " " <> ppColAttrs cfg (colAttrs ci) + ] + where + cty = colType ci + attrs = colAttrs ci + ppType' + | cty == TRowID && [Primary, AutoIncrement] `areIn` attrs = ppTypePK + | otherwise = ppType + areIn x y = null (x \\ y) -- | Compile a @DROP TABLE@ query. compileDropTable :: OnError -> Table a -> Text diff --git a/src/Database/Selda/Table/Foreign.hs b/src/Database/Selda/Table/Foreign.hs --- a/src/Database/Selda/Table/Foreign.hs +++ b/src/Database/Selda/Table/Foreign.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} -- | Foreign key support. module Database.Selda.Table.Foreign where import Database.Selda.Selectors import Database.Selda.Table +import Unsafe.Coerce -- | Add a foreign key constraint to the given column, referencing -- the column indicated by the given table and selector. @@ -9,10 +11,20 @@ -- uniqueness constraint, a 'ValidationError' will be thrown -- during validation. fk :: ColSpec a -> (Table t, Selector t a) -> ColSpec a -fk (ColSpec [c]) (Table tn tcs tapk, Selector i) = +fk (ColSpec [c]) (tbl, Selector i) = ColSpec [c {colFKs = thefk : colFKs c}] where - thefk = (Table tn tcs tapk, colName (tcs !! i)) + Table _ tcs _ = tbl + thefk = (unsafeCoerce tbl, colName (tcs !! i)) fk _ _ = error "impossible: ColSpec with several columns" +-- | Like 'fk', but for nullable foreign keys. +optFk :: ColSpec (Maybe a) -> (Table t, Selector t a) -> ColSpec (Maybe a) +optFk (ColSpec [c]) (tbl, Selector i) = + ColSpec [c {colFKs = thefk : colFKs c}] + where + Table _ tcs _ = tbl + thefk = (unsafeCoerce tbl, colName (tcs !! i)) +optFk _ _ = + error "impossible: ColSpec with several columns"