diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,14 @@ # Revision history for Selda +## 0.5.1.0 -- 2020-01-20 + +* Support for raw SQL fragments. (#134) +* Expose tableName. +* Document performance drawbacks of withoutForeignKeyEnforcement. +* Fix several bugs validating auto-incrementing PKs. (#133) + + ## 0.5.0.0 -- 2019-09-21 * index and indexUsing now accept a Group instead of a Selector (#121) diff --git a/selda.cabal b/selda.cabal --- a/selda.cabal +++ b/selda.cabal @@ -1,5 +1,5 @@ name: selda -version: 0.5.0.0 +version: 0.5.1.0 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, diff --git a/src/Database/Selda.hs b/src/Database/Selda.hs --- a/src/Database/Selda.hs +++ b/src/Database/Selda.hs @@ -25,7 +25,7 @@ , SeldaError (..), ValidationError , SeldaT, SeldaM , Relational, Only (..), The (..) - , Table, Query, Row, Col, Res, Result + , Table (tableName), Query, Row, Col, Res, Result , query, queryInto , transaction, withoutForeignKeyEnforcement , newUuid diff --git a/src/Database/Selda/Backend/Internal.hs b/src/Database/Selda/Backend/Internal.hs --- a/src/Database/Selda/Backend/Internal.hs +++ b/src/Database/Selda/Backend/Internal.hs @@ -17,6 +17,7 @@ , newConnection, allStmts , runSeldaT, withBackend ) where +import Data.List (nub) import Database.Selda.SQL (Param (..)) import Database.Selda.SqlType import Database.Selda.Table hiding (colName, colType, colFKs) @@ -45,8 +46,10 @@ -- | Thrown by any function in 'SeldaT' if an error occurs. data SeldaError - = DbError String -- ^ Unable to open or connect to database. - | SqlError String -- ^ An error occurred while executing query. + = DbError String -- ^ Unable to open or connect to database. + | SqlError String -- ^ An error occurred while executing query. + | UnsafeError String -- ^ An error occurred due to improper use of an unsafe + -- function. deriving (Show, Eq, Typeable) instance Exception SeldaError @@ -166,16 +169,24 @@ tableInfo t = TableInfo { tableColumnInfos = map fromColInfo (tableCols t) , tableUniqueGroups = uniqueGroups - , tablePrimaryKey = pkGroups + , tablePrimaryKey = pkGroup } where uniqueGroups = [ map (Table.colName . ((tableCols t) !!)) ixs | (ixs, Unique) <- tableAttrs t ] - pkGroups = concat - [ map (Table.colName . ((tableCols t) !!)) ixs - | (ixs, Primary) <- tableAttrs t + pkGroup = nub $ concat + [ concat + [ map (Table.colName . ((tableCols t) !!)) ixs + | (ixs, attr) <- tableAttrs t + , isPrimary attr + ] + , [ Table.colName col + | col <- tableCols t + , attr <- Table.colAttrs col + , isPrimary attr + ] ] -- | A collection of functions making up a Selda backend. @@ -219,11 +230,6 @@ } -- | Some monad with Selda SQL capabilitites. --- --- Note that the default implementations of 'invalidateTable' and --- 'wrapTransaction' flush the entire cache and disable caching when --- invoked. If you want to use Selda's built-in caching mechanism, you will --- need to implement these operations yourself. class MonadIO m => MonadSelda m where {-# MINIMAL withConnection #-} diff --git a/src/Database/Selda/Exp.hs b/src/Database/Selda/Exp.hs --- a/src/Database/Selda/Exp.hs +++ b/src/Database/Selda/Exp.hs @@ -33,6 +33,7 @@ Fun2 :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c If :: !(Exp sql Bool) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql a Cast :: !SqlTypeRep -> !(Exp sql a) -> Exp sql b + Raw :: !Text -> Exp sql a AggrEx :: !Text -> !(Exp sql a) -> Exp sql b InList :: !(Exp sql a) -> ![Exp sql a] -> Exp sql Bool InQuery :: !(Exp sql a) -> !sql -> Exp sql Bool @@ -84,6 +85,7 @@ allNamesIn (AggrEx _ x) = allNamesIn x allNamesIn (InList x xs) = concatMap allNamesIn (x:xs) allNamesIn (InQuery x q) = allNamesIn x ++ allNamesIn q + allNamesIn (Raw _) = [] instance Names sql => Names (SomeCol sql) where allNamesIn (Some c) = allNamesIn c diff --git a/src/Database/Selda/Frontend.hs b/src/Database/Selda/Frontend.hs --- a/src/Database/Selda/Frontend.hs +++ b/src/Database/Selda/Frontend.hs @@ -247,6 +247,9 @@ -- Use with extreme caution, preferably only for migrations. -- -- On the PostgreSQL backend, at least PostgreSQL 9.6 is required. +-- +-- Using this should be avoided in favor of deferred foreign key +-- constraints. See SQL backend documentation for deferred constraints. withoutForeignKeyEnforcement :: (MonadSelda m, MonadMask m) => m a -> m a withoutForeignKeyEnforcement m = withBackend $ \b -> do bracket_ (liftIO $ disableForeignKeys b True) diff --git a/src/Database/Selda/SQL.hs b/src/Database/Selda/SQL.hs --- a/src/Database/Selda/SQL.hs +++ b/src/Database/Selda/SQL.hs @@ -1,21 +1,35 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeOperators, FlexibleInstances, UndecidableInstances #-} -{-# LANGUAGE RankNTypes, CPP #-} +{-# LANGUAGE RankNTypes, CPP, MultiParamTypeClasses #-} -- | SQL AST and parameters for prepared statements. module Database.Selda.SQL where +import Data.String +import Data.Text (Text) import Database.Selda.Exp import Database.Selda.SqlType import Database.Selda.Types #if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid hiding (Product) +import Data.Semigroup (Semigroup (..)) #endif +instance Semigroup QueryFragment where + (<>) = RawCat + +data QueryFragment where + RawText :: !Text -> QueryFragment + RawExp :: !(Exp SQL a) -> QueryFragment + RawCat :: !QueryFragment -> !QueryFragment -> QueryFragment + +instance IsString QueryFragment where + fromString = RawText . fromString + -- | A source for an SQL query. data SqlSource = TableName !TableName | Product ![SQL] | Join !JoinType !(Exp SQL Bool) !SQL !SQL | Values ![SomeCol SQL] ![[Param]] + | RawSql !QueryFragment | EmptyTable -- | Type of join to perform. @@ -32,11 +46,17 @@ , distinct :: !Bool } +instance Names QueryFragment where + allNamesIn (RawText _) = [] + allNamesIn (RawExp e) = allNamesIn e + allNamesIn (RawCat a b) = allNamesIn a ++ allNamesIn b + instance Names SqlSource where allNamesIn (Product qs) = concatMap allNamesIn qs allNamesIn (Join _ e l r) = allNamesIn e ++ concatMap allNamesIn [l, r] allNamesIn (Values vs _) = allNamesIn vs allNamesIn (TableName _) = [] + allNamesIn (RawSql r) = allNamesIn r allNamesIn (EmptyTable) = [] instance Names SQL where 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 @@ -46,6 +46,10 @@ compExp :: PPConfig -> Exp SQL a -> (Text, [Param]) compExp cfg = runPP cfg . ppCol +-- | Compile a raw SQL fragment. +compRaw :: PPConfig -> QueryFragment -> (Text, [Param]) +compRaw cfg = runPP cfg . ppRaw + -- | Compile an @UPATE@ statement. compUpdate :: PPConfig -> TableName @@ -125,6 +129,10 @@ ppSrc EmptyTable = do qn <- freshQueryName pure $ " FROM (SELECT NULL LIMIT 0) AS " <> qn + ppSrc (RawSql raw) = do + s <- ppRaw raw + qn <- freshQueryName + pure (" FROM (" <> s <> ") AS " <> qn) ppSrc (TableName n) = do pure $ " FROM " <> fromTableName n ppSrc (Product []) = do @@ -187,6 +195,11 @@ ppInt = Text.pack . show +ppRaw :: QueryFragment -> PP Text +ppRaw (RawText t) = pure t +ppRaw (RawExp e) = ppCol e +ppRaw (RawCat a b) = liftM2 (<>) (ppRaw a) (ppRaw b) + ppSomeCol :: SomeCol SQL -> PP Text ppSomeCol (Some c) = ppCol c ppSomeCol (Named n c) = do @@ -214,6 +227,7 @@ ppCol (BinOp op a b) = ppBinOp op a b ppCol (UnOp op a) = ppUnOp op a ppCol (NulOp a) = ppNulOp a +ppCol (Raw e) = pure e ppCol (Fun2 f a b) = do a' <- ppCol a b' <- ppCol b diff --git a/src/Database/Selda/Transform.hs b/src/Database/Selda/Transform.hs --- a/src/Database/Selda/Transform.hs +++ b/src/Database/Selda/Transform.hs @@ -13,6 +13,7 @@ EmptyTable -> sql' TableName _ -> sql' Values _ _ -> sql' + RawSql _ -> sql' Product qs -> sql' {source = Product $ map noDead qs} Join jt on l r -> sql' {source = Join jt on (noDead l) (noDead r)} where diff --git a/src/Database/Selda/Unsafe.hs b/src/Database/Selda/Unsafe.hs --- a/src/Database/Selda/Unsafe.hs +++ b/src/Database/Selda/Unsafe.hs @@ -6,11 +6,20 @@ , aggr , cast, castAggr, sink, sink2 , unsafeSelector + , QueryFragment, inj, injLit, rawName, rawExp, rawStm, rawQuery, rawQuery1 ) where +import Control.Exception (throw) +import Control.Monad.State.Strict +import Database.Selda.Backend.Internal import Database.Selda.Column +import Database.Selda.Exp (UntypedCol (..)) import Database.Selda.Inner (Inner, Aggr, aggr, liftAggr) import Database.Selda.Selectors (unsafeSelector) -import Database.Selda.SqlType +import Database.Selda.Query.Type (Query (..), sources, renameAll, rename) +import Database.Selda.SQL (QueryFragment (..), SqlSource (RawSql), sqlFrom) +import Database.Selda.SQL.Print (compRaw) +import Database.Selda.SqlRow (SqlRow (..)) +import Database.Selda.Types (ColName) import Data.Text (Text) import Data.Proxy import Unsafe.Coerce @@ -69,3 +78,57 @@ -- | Like 'fun', but with zero arguments. fun0 :: Text -> Col s a fun0 = One . NulOp . Fun0 + +-- | Create a raw SQL query fragment from the given column. +inj :: Col s a -> QueryFragment +inj (One x) = RawExp x + +-- | Create a raw SQL query fragment from the given value. +injLit :: SqlType a => a -> QueryFragment +injLit = RawExp . Lit . mkLit + +-- | Create a column referring to a name of your choice. +-- Use this to refer to variables not exposed by Selda. +rawName :: SqlType a => ColName -> Col s a +rawName = One . Col + +-- | Create an expression from the given text. +-- The expression will be inserted verbatim into your query, so you should +-- NEVER pass user-provided text to this function. +rawExp :: SqlType a => Text -> Col s a +rawExp = One . Raw + +-- | Execute a raw SQL statement. +rawStm :: MonadSelda m => QueryFragment -> m () +rawStm q = withBackend $ \b -> liftIO $ do + void $ uncurry (runStmt b) $ compRaw (ppConfig b) q + +-- | Execute a raw SQL statement, returning a row consisting of columns by the +-- given names. +-- Will fail if the number of names given does not match up with +-- the type of the returned row. +-- Will generate invalid SQL if the given names don't match up with the +-- column names in the given query. +rawQuery :: forall a s. SqlRow a => [ColName] -> QueryFragment -> Query s (Row s a) +rawQuery names q + | length names /= nestedCols (Proxy :: Proxy a) = do + let err = concat + [ "rawQuery: return type has ", show (nestedCols (Proxy :: Proxy a)) + , " columns, but only ", show (length names), " names were given" + ] + throw (UnsafeError err) + | otherwise = Query $ do + rns <- renameAll [Untyped (Col name) | name <- names] + st <- get + put $ st { sources = sqlFrom rns (RawSql q) : sources st } + return (Many (map hideRenaming rns)) + +-- | As 'rawQuery', but returns only a single column. Same warnings still apply. +rawQuery1 :: SqlType a => ColName -> QueryFragment -> Query s (Col s a) +rawQuery1 name q = Query $ do + name' <- head <$> rename (Untyped (Col name)) + st <- get + put $ st { sources = sqlFrom [name'] (RawSql q) : sources st } + case name' of + Named n _ -> return (One (Col n)) + _ -> error "BUG: renaming did not rename"