selda 0.1.3.3 → 0.1.4.0

raw patch · 9 files changed

+77/−12 lines, 9 files

Files

ChangeLog.md +5/−0
selda.cabal +2/−1
src/Database/Selda.hs +2/−0
src/Database/Selda/Generic.hs +2/−1
src/Database/Selda/Selectors.hs +3/−2
src/Database/Selda/Table.hs +25/−7
src/Database/Selda/Table/Compile.hs +15/−0
src/Database/Selda/Table/Foreign.hs +18/−0
src/Database/Selda/Types.hs +5/−1

ChangeLog.md view

@@ -1,5 +1,10 @@ # Revision history for selda +## 0.1.4.0 -- 2017-05-04++* Add uniqueness constraints and foreign keys.++ ## 0.1.3.3 -- 2017-05-04  * Fix cache invalidation race when using transactions.

selda.cabal view

@@ -1,5 +1,5 @@ name:                selda-version:             0.1.3.3+version:             0.1.4.0 synopsis:            Type-safe, high-level EDSL for interacting with relational databases. description:         This package provides an EDSL for writing portable, type-safe, high-level                      database code. Its feature set includes querying and modifying databases,@@ -62,6 +62,7 @@     Database.Selda.SqlType     Database.Selda.Table     Database.Selda.Table.Compile+    Database.Selda.Table.Foreign     Database.Selda.Transform     Database.Selda.Types   other-extensions:

src/Database/Selda.hs view

@@ -100,6 +100,7 @@   , table, tableWithSelectors, selectors   , required, optional   , primary, autoPrimary+  , fk, unique     -- * Creating and dropping tables   , createTable, tryCreateTable   , dropTable, tryDropTable@@ -125,6 +126,7 @@ import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile+import Database.Selda.Table.Foreign import Database.Selda.Types import Database.Selda.Unsafe import Control.Exception (throw)

src/Database/Selda/Generic.hs view

@@ -260,12 +260,13 @@         { colName = mkColName . pack $ selName ((M1 undefined) :: M1 S c a b)         , colType = colType ci         , colAttrs = colAttrs ci+        , colFKs = colFKs ci         }   gMkDummy = M1 <$> gMkDummy  instance (Traits a, SqlType a) => GRelation (K1 i a) where   gToRel (K1 x) = x-  gTblCols _    = [ColInfo "" (sqlType (Proxy :: Proxy a)) optReq]+  gTblCols _    = [ColInfo "" (sqlType (Proxy :: Proxy a)) optReq []]     where       optReq         | isMaybeType (Proxy :: Proxy a) = [Optional]

src/Database/Selda/Selectors.hs view

@@ -38,8 +38,9 @@ with = foldl' upd  -- | A column selector. Column selectors can be used together with the '!' and---   '!=' operators to get and set values on inductive tuples.-newtype Selector t a = Selector Int+--   'with' functions to get and set values on inductive tuples, or to indicate+--   foreign keys.+data Selector t a = Selector Int  -- | The inductive tuple of selectors for a table of type @a@. type family Selectors t a where

src/Database/Selda/Table.hs view

@@ -44,6 +44,7 @@   { colName  :: !ColName   , colType  :: !Text   , colAttrs :: ![ColAttr]+  , colFKs   :: ![(Table (), ColName)]   }  newCol :: forall a. SqlType a => ColName -> ColSpec a@@ -51,6 +52,7 @@   { colName  = name   , colType  = sqlType (Proxy :: Proxy a)   , colAttrs = []+  , colFKs   = []   }]  -- | A table column specification.@@ -75,7 +77,7 @@ --   When adding elements, make sure that they are added in the order --   required by SQL syntax, as this list is only sorted before being --   pretty-printed.-data ColAttr = Primary | AutoIncrement | Required | Optional+data ColAttr = Primary | AutoIncrement | Required | Optional | Unique   deriving (Show, Eq, Ord)  -- | A non-nullable column with the given name.@@ -83,25 +85,31 @@ required = addAttr Required . newCol  -- | A nullable column with the given name.-optional :: SqlType a => ColName -> ColSpec (Maybe a)+optional :: NonNull a => ColName -> ColSpec (Maybe a) optional = addAttr Optional . newCol  -- | Marks the given column as the table's primary key. --   A table may only have one primary key; marking more than one key as---   primary will result in a run-time error.+--   primary will result in 'ValidationError' during validation. primary :: NonNull a => ColName -> ColSpec a-primary = addAttr Primary . required+primary = addAttr Primary . unique . required  -- | Automatically increment the given attribute if not specified during insert.---   Also adds the @PRIMARY KEY@ attribute on the column.+--   Also adds the @PRIMARY KEY@ and @UNIQUE@ attributes on the column. autoPrimary :: ColName -> ColSpec Int-autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required]}]+autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required, Unique]}]   where ColSpec [c] = newCol n :: ColSpec Int +-- | Add a uniqueness constraint to the given column.+--   Adding a uniqueness constraint to a column that is already implied to be+--   unique, such as a primary key, is a no-op.+unique :: SqlType a => ColSpec a -> ColSpec a+unique = addAttr Unique+ -- | Add an attribute to a column. Not for public consumption. addAttr :: SqlType a => ColAttr -> ColSpec a -> ColSpec a addAttr attr (ColSpec [ci]) = ColSpec [ci {colAttrs = attr : colAttrs ci}]-addAttr _ _                 = error "impossible: SqlType ColSpec with several columns"+addAttr _ _                 = error "impossible: ColSpec with several columns"  -- | An inductive tuple where each element is a column specification. type family ColSpecs a where@@ -154,6 +162,7 @@       , nulIdents       , emptyIdents       , emptyTableName+      , nonPkFks       ]     emptyTableName       | fromTableName name == "\"\"" = ["table name is empty"]@@ -172,6 +181,15 @@       ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis]     pkDupes =       ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]+    nonPkFks =+      [ "column is used as a foreign key, but is not a primary key of its table: "+          <> fromTableName ftn <> "." <> fromColName fcn+      | ci <- cis+      , (Table ftn fcs, fcn) <- colFKs ci+      , fc <- fcs+      , colName fc == fcn+      , not (Unique `elem` colAttrs fc)+      ]      -- This should be impossible, but...     optionalRequiredMutex =

src/Database/Selda/Table/Compile.hs view

@@ -17,12 +17,26 @@ compileCreateTable customColType ifex tbl = mconcat   [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("   , intercalate ", " (map (compileTableCol customColType) (tableCols tbl))+  , case allFKs of+      [] -> ""+      _  -> ", " <> intercalate ", " compFKs   , ")"   ]   where     ifNotExists Fail   = ""     ifNotExists Ignore = "IF NOT EXISTS "+    allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci]+    compFKs = zipWith (uncurry compileFK) allFKs [0..] +-- | Compile a foreign key constraint.+compileFK :: ColName -> (Table (), ColName) -> Int -> Text+compileFK col (Table ftbl _, fcol) n = mconcat+  [ "CONSTRAINT ", fkName, " FOREIGN KEY (", fromColName col, ") "+  , "REFERENCES ", fromTableName ftbl, "(", fromColName fcol, ")"+  ]+  where+    fkName = fromColName $ addColPrefix col ("fk" <> pack (show n) <> "_")+ -- | Compile a table column. compileTableCol :: (Text -> [ColAttr] -> Maybe Text) -> ColInfo -> Text compileTableCol customColType ci = Text.unwords@@ -98,3 +112,4 @@ compileColAttr AutoIncrement = "AUTOINCREMENT" compileColAttr Required      = "NOT NULL" compileColAttr Optional      = "NULL"+compileColAttr Unique        = "UNIQUE"

+ src/Database/Selda/Table/Foreign.hs view

@@ -0,0 +1,18 @@+-- | Foreign key support.+module Database.Selda.Table.Foreign where+import Database.Selda.Selectors+import Database.Selda.Table++-- | Add a foreign key constraint to the given column, referencing+--   the column indicated by the given table and selector.+--   If the referenced column is not a primary key or has a+--   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, Selector i) =+    ColSpec [c {colFKs = thefk : colFKs c}]+  where+    thefk = (Table tn tcs, colName (tcs !! i))+fk _ _ =+  error "impossible: ColSpec with several columns"+

src/Database/Selda/Types.hs view

@@ -8,7 +8,7 @@   ( (:*:)(..), Head, Append (..), (:++:), ToDyn (..), Tup (..)   , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth   , ColName, TableName-  , mkColName, mkTableName, addColSuffix+  , mkColName, mkTableName, addColSuffix, addColPrefix   , fromColName, fromTableName   ) where import Data.Dynamic@@ -31,6 +31,10 @@ -- | Name of a database table. newtype TableName = TableName Text   deriving (Ord, Eq, Show, IsString)++-- | Add a prefix to a column name.+addColPrefix :: ColName -> Text -> ColName+addColPrefix (ColName cn) s = ColName $ Data.Text.append s cn  -- | Add a suffix to a column name. addColSuffix :: ColName -> Text -> ColName