module Database.PostgreSQL.PQTypes.SQL.Builder
( sqlWhere
, sqlWhereE
, sqlWhereEV
, sqlWhereEVV
, sqlWhereEVVV
, sqlWhereEVVVV
, sqlWhereEq
, sqlWhereEqE
, sqlWhereEqSql
, sqlWhereNotEq
, sqlWhereNotEqE
, sqlWhereIn
, sqlWhereInSql
, sqlWhereInE
, sqlWhereNotIn
, sqlWhereNotInSql
, sqlWhereNotInE
, sqlWhereExists
, sqlWhereNotExists
, sqlWhereLike
, sqlWhereLikeE
, sqlWhereILike
, sqlWhereILikeE
, sqlWhereIsNULL
, sqlWhereIsNotNULL
, sqlWhereIsNULLE
, sqlIgnore
, sqlFrom
, sqlJoin
, sqlJoinOn
, sqlLeftJoinOn
, sqlRightJoinOn
, sqlFullJoinOn
, sqlSet
, sqlSetInc
, sqlSetList
, sqlSetListWithDefaults
, sqlSetCmd
, sqlSetCmdList
, sqlCopyColumn
, sqlResult
, sqlOrderBy
, sqlGroupBy
, sqlHaving
, sqlOffset
, sqlLimit
, sqlDistinct
, sqlWith
, SqlTurnIntoSelect
, sqlTurnIntoSelect
, sqlTurnIntoWhyNotSelect
, sqlSelect
, sqlSelect2
, SqlSelect(..)
, sqlInsert
, SqlInsert(..)
, sqlInsertSelect
, SqlInsertSelect(..)
, sqlUpdate
, SqlUpdate(..)
, sqlDelete
, SqlDelete(..)
, sqlWhereAny
, SqlResult
, SqlSet
, SqlFrom
, SqlWhere
, SqlOrderBy
, SqlGroupByHaving
, SqlOffsetLimit
, SqlDistinct
, SqlCondition(..)
, sqlGetWhereConditions
, SqlWhyNot(..)
, kWhyNot1
, kRun1OrThrowWhyNot
, kRun1OrThrowWhyNotAllowIgnore
, kRunManyOrThrowWhyNot
, kRunAndFetch1OrThrowWhyNot
, DBExtraException(..)
, SomeDBExtraException(..)
, catchDBExtraException
, DBBaseLineConditionIsFalse(..)
, Sqlable(..)
, sqlOR
, sqlConcatComma
, sqlConcatAND
, sqlConcatOR
, parenthesize
, AscDesc(..)
)
where
import Control.Exception.Lifted as E
import Control.Monad.Catch
import Control.Monad.State
import Control.Monad.Trans.Control
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Monoid.Utils
import Data.String
import Data.Typeable
import Database.PostgreSQL.PQTypes
import Prelude
import qualified Text.JSON.Gen as JSON
class Sqlable a where
toSQLCommand :: a -> SQL
instance Sqlable SQL where
toSQLCommand = id
smintercalate :: (IsString m, Monoid m) => m -> [m] -> m
smintercalate m = mintercalate $ mconcat [mspace, m, mspace]
sqlOR :: SQL -> SQL -> SQL
sqlOR s1 s2 = sqlConcatOR [s1, s2]
sqlConcatComma :: [SQL] -> SQL
sqlConcatComma = mintercalate ", "
sqlConcatAND :: [SQL] -> SQL
sqlConcatAND = smintercalate "AND" . map parenthesize
sqlConcatOR :: [SQL] -> SQL
sqlConcatOR = smintercalate "OR" . map parenthesize
parenthesize :: SQL -> SQL
parenthesize s = "(" <> s <> ")"
data AscDesc a = Asc a | Desc a
deriving (Eq, Show)
data Multiplicity a = Single a | Many [a]
deriving (Eq, Ord, Show, Typeable)
data SqlCondition = SqlPlainCondition SQL SqlWhyNot
| SqlExistsCondition SqlSelect
deriving (Typeable, Show)
data SqlWhyNot = forall e row. (FromRow row, DBExtraException e) => SqlWhyNot Bool (row -> e) [SQL]
instance Show SqlWhyNot where
show (SqlWhyNot _important exc expr) = "SqlWhyNot " ++ show (typeOf (exc $undefined)) ++ " " ++ show expr
instance Sqlable SqlCondition where
toSQLCommand (SqlPlainCondition a _) = a
toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")"
data SqlSelect = SqlSelect
{ sqlSelectFrom :: SQL
, sqlSelectDistinct :: Bool
, sqlSelectResult :: [SQL]
, sqlSelectWhere :: [SqlCondition]
, sqlSelectOrderBy :: [SQL]
, sqlSelectGroupBy :: [SQL]
, sqlSelectHaving :: [SQL]
, sqlSelectOffset :: Integer
, sqlSelectLimit :: Integer
, sqlSelectWith :: [(SQL, SQL)]
}
data SqlUpdate = SqlUpdate
{ sqlUpdateWhat :: SQL
, sqlUpdateFrom :: SQL
, sqlUpdateWhere :: [SqlCondition]
, sqlUpdateSet :: [(SQL,SQL)]
, sqlUpdateResult :: [SQL]
, sqlUpdateWith :: [(SQL, SQL)]
}
data SqlInsert = SqlInsert
{ sqlInsertWhat :: SQL
, sqlInsertSet :: [(SQL, Multiplicity SQL)]
, sqlInsertResult :: [SQL]
, sqlInsertWith :: [(SQL, SQL)]
}
data SqlInsertSelect = SqlInsertSelect
{ sqlInsertSelectWhat :: SQL
, sqlInsertSelectDistinct :: Bool
, sqlInsertSelectSet :: [(SQL, SQL)]
, sqlInsertSelectResult :: [SQL]
, sqlInsertSelectFrom :: SQL
, sqlInsertSelectWhere :: [SqlCondition]
, sqlInsertSelectOrderBy :: [SQL]
, sqlInsertSelectGroupBy :: [SQL]
, sqlInsertSelectHaving :: [SQL]
, sqlInsertSelectOffset :: Integer
, sqlInsertSelectLimit :: Integer
, sqlInsertSelectWith :: [(SQL, SQL)]
}
data SqlDelete = SqlDelete
{ sqlDeleteFrom :: SQL
, sqlDeleteUsing :: SQL
, sqlDeleteWhere :: [SqlCondition]
, sqlDeleteResult :: [SQL]
, sqlDeleteWith :: [(SQL, SQL)]
}
data SqlAll = SqlAll
{ sqlAllWhere :: [SqlCondition]
}
instance Show SqlSelect where
show = show . toSQLCommand
instance Show SqlInsert where
show = show . toSQLCommand
instance Show SqlInsertSelect where
show = show . toSQLCommand
instance Show SqlUpdate where
show = show . toSQLCommand
instance Show SqlDelete where
show = show . toSQLCommand
instance Show SqlAll where
show = show . toSQLCommand
emitClause :: Sqlable sql => SQL -> sql -> SQL
emitClause name s = case toSQLCommand s of
sql
| isSqlEmpty sql -> ""
| otherwise -> name <+> sql
emitClausesSep :: SQL -> SQL -> [SQL] -> SQL
emitClausesSep _name _sep [] = mempty
emitClausesSep name sep sqls = name <+> smintercalate sep (filter (not . isSqlEmpty) $ map parenthesize sqls)
emitClausesSepComma :: SQL -> [SQL] -> SQL
emitClausesSepComma _name [] = mempty
emitClausesSepComma name sqls = name <+> sqlConcatComma (filter (not . isSqlEmpty) sqls)
instance IsSQL SqlSelect where
withSQL = withSQL . toSQLCommand
instance IsSQL SqlInsert where
withSQL = withSQL . toSQLCommand
instance IsSQL SqlInsertSelect where
withSQL = withSQL . toSQLCommand
instance IsSQL SqlUpdate where
withSQL = withSQL . toSQLCommand
instance IsSQL SqlDelete where
withSQL = withSQL . toSQLCommand
instance Sqlable SqlSelect where
toSQLCommand cmd =
emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlSelectWith cmd)) <+>
"SELECT" <+> (if sqlSelectDistinct cmd then "DISTINCT" else mempty) <+>
sqlConcatComma (sqlSelectResult cmd) <+>
emitClause "FROM" (sqlSelectFrom cmd) <+>
emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlSelectWhere cmd) <+>
emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd) <+>
emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd) <+>
emitClausesSepComma "ORDER BY" (sqlSelectOrderBy cmd) <+>
(if sqlSelectOffset cmd > 0
then unsafeSQL ("OFFSET " ++ show (sqlSelectOffset cmd))
else "") <+>
(if sqlSelectLimit cmd >= 0
then unsafeSQL ("LIMIT " ++ show (sqlSelectLimit cmd))
else "")
instance Sqlable SqlInsert where
toSQLCommand cmd =
emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertWith cmd)) <+>
"INSERT INTO" <+> sqlInsertWhat cmd <+>
parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) <+>
emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd)))) <+>
emitClausesSepComma "RETURNING" (sqlInsertResult cmd)
where
longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd)))
lengthOfEither (Single _) = 1
lengthOfEither (Many x) = length x
makeLongEnough (Single x) = take longest (repeat x)
makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT")
instance Sqlable SqlInsertSelect where
toSQLCommand cmd =
"INSERT INTO" <+> sqlInsertSelectWhat cmd <+>
parenthesize (sqlConcatComma (map fst (sqlInsertSelectSet cmd))) <+>
parenthesize (toSQLCommand (SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd
, sqlSelectDistinct = sqlInsertSelectDistinct cmd
, sqlSelectResult = fmap snd $ sqlInsertSelectSet cmd
, sqlSelectWhere = sqlInsertSelectWhere cmd
, sqlSelectOrderBy = sqlInsertSelectOrderBy cmd
, sqlSelectGroupBy = sqlInsertSelectGroupBy cmd
, sqlSelectHaving = sqlInsertSelectHaving cmd
, sqlSelectOffset = sqlInsertSelectOffset cmd
, sqlSelectLimit = sqlInsertSelectLimit cmd
, sqlSelectWith = sqlInsertSelectWith cmd
})) <+>
emitClausesSepComma "RETURNING" (sqlInsertSelectResult cmd)
instance Sqlable SqlUpdate where
toSQLCommand cmd =
emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlUpdateWith cmd)) <+>
"UPDATE" <+> sqlUpdateWhat cmd <+> "SET" <+>
sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd)) <+>
emitClause "FROM" (sqlUpdateFrom cmd) <+>
emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlUpdateWhere cmd) <+>
emitClausesSepComma "RETURNING" (sqlUpdateResult cmd)
instance Sqlable SqlDelete where
toSQLCommand cmd =
emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlDeleteWith cmd)) <+>
"DELETE FROM" <+> sqlDeleteFrom cmd <+>
emitClause "USING" (sqlDeleteUsing cmd) <+>
emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd) <+>
emitClausesSepComma "RETURNING" (sqlDeleteResult cmd)
instance Sqlable SqlAll where
toSQLCommand cmd | null (sqlAllWhere cmd) = "TRUE"
toSQLCommand cmd =
"(" <+> smintercalate "AND" (map (parenthesize . toSQLCommand) (sqlAllWhere cmd)) <+> ")"
sqlSelect :: SQL -> State SqlSelect () -> SqlSelect
sqlSelect table refine =
execState refine (SqlSelect table False [] [] [] [] [] 0 (1) [])
sqlSelect2 :: SQL -> State SqlSelect () -> SqlSelect
sqlSelect2 from refine =
execState refine (SqlSelect from False [] [] [] [] [] 0 (1) [])
sqlInsert :: SQL -> State SqlInsert () -> SqlInsert
sqlInsert table refine =
execState refine (SqlInsert table mempty [] [])
sqlInsertSelect :: SQL -> SQL -> State SqlInsertSelect () -> SqlInsertSelect
sqlInsertSelect table from refine =
execState refine (SqlInsertSelect
{ sqlInsertSelectWhat = table
, sqlInsertSelectDistinct = False
, sqlInsertSelectSet = []
, sqlInsertSelectResult = []
, sqlInsertSelectFrom = from
, sqlInsertSelectWhere = []
, sqlInsertSelectOrderBy = []
, sqlInsertSelectGroupBy = []
, sqlInsertSelectHaving = []
, sqlInsertSelectOffset = 0
, sqlInsertSelectLimit = 1
, sqlInsertSelectWith = []
})
sqlUpdate :: SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate table refine =
execState refine (SqlUpdate table mempty [] [] [] [])
sqlDelete :: SQL -> State SqlDelete () -> SqlDelete
sqlDelete table refine =
execState refine (SqlDelete { sqlDeleteFrom = table
, sqlDeleteUsing = mempty
, sqlDeleteWhere = []
, sqlDeleteResult = []
, sqlDeleteWith = []
})
class SqlWith a where
sqlWith1 :: a -> SQL -> SQL -> a
instance SqlWith SqlSelect where
sqlWith1 cmd name sql = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql)] }
instance SqlWith SqlInsertSelect where
sqlWith1 cmd name sql = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql)] }
instance SqlWith SqlUpdate where
sqlWith1 cmd name sql = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql)] }
instance SqlWith SqlDelete where
sqlWith1 cmd name sql = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql)] }
sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()
sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql))
class SqlWhere a where
sqlWhere1 :: a -> SqlCondition -> a
sqlGetWhereConditions :: a -> [SqlCondition]
instance SqlWhere SqlSelect where
sqlWhere1 cmd cond = cmd { sqlSelectWhere = sqlSelectWhere cmd ++ [cond] }
sqlGetWhereConditions = sqlSelectWhere
instance SqlWhere SqlInsertSelect where
sqlWhere1 cmd cond = cmd { sqlInsertSelectWhere = sqlInsertSelectWhere cmd ++ [cond] }
sqlGetWhereConditions = sqlInsertSelectWhere
instance SqlWhere SqlUpdate where
sqlWhere1 cmd cond = cmd { sqlUpdateWhere = sqlUpdateWhere cmd ++ [cond] }
sqlGetWhereConditions = sqlUpdateWhere
instance SqlWhere SqlDelete where
sqlWhere1 cmd cond = cmd { sqlDeleteWhere = sqlDeleteWhere cmd ++ [cond] }
sqlGetWhereConditions = sqlDeleteWhere
instance SqlWhere SqlAll where
sqlWhere1 cmd cond = cmd { sqlAllWhere = sqlAllWhere cmd ++ [cond] }
sqlGetWhereConditions = sqlAllWhere
newtype SqlWhereIgnore a = SqlWhereIgnore { unSqlWhereIgnore :: a }
ignoreWhereClause :: SqlCondition -> SqlCondition
ignoreWhereClause (SqlPlainCondition sql (SqlWhyNot _b f s)) =
SqlPlainCondition sql (SqlWhyNot False f s)
ignoreWhereClause (SqlExistsCondition sql) =
SqlExistsCondition (sql { sqlSelectWhere = map ignoreWhereClause (sqlSelectWhere sql)})
instance (SqlWhere a) => SqlWhere (SqlWhereIgnore a) where
sqlWhere1 (SqlWhereIgnore cmd) cond =
SqlWhereIgnore (sqlWhere1 cmd (ignoreWhereClause cond))
sqlGetWhereConditions (SqlWhereIgnore cmd) = sqlGetWhereConditions cmd
sqlIgnore :: (MonadState s m)
=> State (SqlWhereIgnore s) a
-> m ()
sqlIgnore clauses = modify (\cmd -> unSqlWhereIgnore (execState clauses (SqlWhereIgnore cmd)))
sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere sql = sqlWhereE (DBBaseLineConditionIsFalse sql) sql
sqlWhereE :: (MonadState v m, SqlWhere v, DBExtraException e) => e -> SQL -> m ()
sqlWhereE exc sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [])))
where
exc2 (_::()) = exc
sqlWhereEV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a) => (a -> e, SQL) -> SQL -> m ()
sqlWhereEV (exc, vsql) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql])))
where
exc2 (Identity v1) = exc v1
sqlWhereEVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b) => (a -> b -> e, SQL, SQL) -> SQL -> m ()
sqlWhereEVV (exc, vsql1, vsql2) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2])))
where
exc2 (v1, v2) = exc v1 v2
sqlWhereEVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c) => (a -> b -> c -> e, SQL, SQL, SQL) -> SQL -> m ()
sqlWhereEVVV (exc, vsql1, vsql2, vsql3) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3])))
where
exc2 (v1, v2, v3) = exc v1 v2 v3
sqlWhereEVVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c, FromSQL d) => (a -> b -> c -> d -> e, SQL, SQL, SQL, SQL) -> SQL -> m ()
sqlWhereEVVVV (exc, vsql1, vsql2, vsql3, vsql4) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3, vsql4])))
where
exc2 (v1, v2, v3, v4) = exc v1 v2 v3 v4
sqlWhereEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereEq name value = sqlWhere $ name <+> "=" <?> value
sqlWhereEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, FromSQL a, ToSQL a)
=> (a -> a -> e) -> SQL -> a -> m ()
sqlWhereEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "=" <?> value
sqlWhereEqSql :: (MonadState v m, SqlWhere v, Sqlable sql) => SQL -> sql -> m ()
sqlWhereEqSql name1 name2 = sqlWhere $ name1 <+> "=" <+> toSQLCommand name2
sqlWhereNotEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereNotEq name value = sqlWhere $ name <+> "<>" <?> value
sqlWhereNotEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
=> (a -> a -> e) -> SQL -> a -> m ()
sqlWhereNotEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "<>" <?> value
sqlWhereLike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereLike name value = sqlWhere $ name <+> "LIKE" <?> value
sqlWhereLikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
=> (a -> a -> e) -> SQL -> a -> m ()
sqlWhereLikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "LIKE" <?> value
sqlWhereILike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()
sqlWhereILike name value = sqlWhere $ name <+> "ILIKE" <?> value
sqlWhereILikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
=> (a -> a -> e) -> SQL -> a -> m ()
sqlWhereILikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "ILIKE" <?> value
sqlWhereIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlWhereIn _name [] = sqlWhere "FALSE"
sqlWhereIn name [value] = sqlWhereEq name value
sqlWhereIn name values = do
sqlWhere $ name <+> "IN (SELECT UNNEST(" <?> Array1 values <+> "))"
sqlWhereInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m ()
sqlWhereInSql name sql = sqlWhere $ name <+> "IN" <+> parenthesize (toSQLCommand sql)
sqlWhereInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
=> ([a] -> a -> e) -> SQL -> [a] -> m ()
sqlWhereInE exc name [] = sqlWhereEV (exc [], name) "FALSE"
sqlWhereInE exc name [value] = sqlWhereEqE (exc . (\x -> [x])) name value
sqlWhereInE exc name values =
sqlWhereEV (exc values, name) $ name <+> "IN (SELECT UNNEST(" <?> Array1 values <+> "))"
sqlWhereNotIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlWhereNotIn _name [] = sqlWhere "TRUE"
sqlWhereNotIn name [value] = sqlWhereNotEq name value
sqlWhereNotIn name values = sqlWhere $ name <+> "NOT IN (SELECT UNNEST(" <?> Array1 values <+> "))"
sqlWhereNotInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m ()
sqlWhereNotInSql name sql = sqlWhere $ name <+> "NOT IN" <+> parenthesize (toSQLCommand sql)
sqlWhereNotInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a)
=> ([a] -> a -> e) -> SQL -> [a] -> m ()
sqlWhereNotInE exc name [] = sqlWhereEV (exc [], name) "TRUE"
sqlWhereNotInE exc name [value] = sqlWhereNotEqE (exc . (\x -> [x])) name value
sqlWhereNotInE exc name values =
sqlWhereEV (exc values, name) $ name <+> "NOT IN (SELECT UNNEST(" <?> Array1 values <+> "))"
sqlWhereExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m ()
sqlWhereExists sql = do
modify (\cmd -> sqlWhere1 cmd (SqlExistsCondition sql))
sqlWhereNotExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m ()
sqlWhereNotExists sqlSelectD = do
sqlWhere ("NOT EXISTS (" <+> toSQLCommand (sqlSelectD { sqlSelectResult = ["TRUE"] }) <+> ")")
sqlWhereIsNULL :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNULL col = sqlWhere $ col <+> "IS NULL"
sqlWhereIsNotNULL :: (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNotNULL col = sqlWhere $ col <+> "IS NOT NULL"
sqlWhereIsNULLE :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a)
=> (a -> e) -> SQL -> m ()
sqlWhereIsNULLE exc col = sqlWhereEV (exc, col) $ col <+> "IS NULL"
sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlAll ()] -> m ()
sqlWhereAny [] = sqlWhere "FALSE"
sqlWhereAny l = sqlWhere $ "(" <+> smintercalate "OR" (map (parenthesize . toSQLCommand . flip execState (SqlAll [])) l) <+> ")"
class SqlFrom a where
sqlFrom1 :: a -> SQL -> a
instance SqlFrom SqlSelect where
sqlFrom1 cmd sql = cmd { sqlSelectFrom = sqlSelectFrom cmd <+> sql }
instance SqlFrom SqlInsertSelect where
sqlFrom1 cmd sql = cmd { sqlInsertSelectFrom = sqlInsertSelectFrom cmd <+> sql }
instance SqlFrom SqlUpdate where
sqlFrom1 cmd sql = cmd { sqlUpdateFrom = sqlUpdateFrom cmd <+> sql }
instance SqlFrom SqlDelete where
sqlFrom1 cmd sql = cmd { sqlDeleteUsing = sqlDeleteUsing cmd <+> sql }
sqlFrom :: (MonadState v m, SqlFrom v) => SQL -> m ()
sqlFrom sql = modify (\cmd -> sqlFrom1 cmd sql)
sqlJoin :: (MonadState v m, SqlFrom v) => SQL -> m ()
sqlJoin table = sqlFrom (", " <+> table)
sqlJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlJoinOn table condition = sqlFrom (" JOIN " <+>
table <+>
" ON " <+>
condition)
sqlLeftJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlLeftJoinOn table condition = sqlFrom (" LEFT JOIN " <+>
table <+>
" ON " <+>
condition)
sqlRightJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlRightJoinOn table condition = sqlFrom (" RIGHT JOIN " <+>
table <+>
" ON " <+>
condition)
sqlFullJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()
sqlFullJoinOn table condition = sqlFrom (" FULL JOIN " <+>
table <+>
" ON " <+>
condition)
class SqlSet a where
sqlSet1 :: a -> SQL -> SQL -> a
instance SqlSet SqlUpdate where
sqlSet1 cmd name v = cmd { sqlUpdateSet = sqlUpdateSet cmd ++ [(name, v)] }
instance SqlSet SqlInsert where
sqlSet1 cmd name v = cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Single v)] }
instance SqlSet SqlInsertSelect where
sqlSet1 cmd name v = cmd { sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)] }
sqlSetCmd :: (MonadState v m, SqlSet v) => SQL -> SQL -> m ()
sqlSetCmd name sql = modify (\cmd -> sqlSet1 cmd name sql)
sqlSetCmdList :: (MonadState SqlInsert m) => SQL -> [SQL] -> m ()
sqlSetCmdList name as = modify (\cmd -> cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Many as)] })
sqlSet :: (MonadState v m, SqlSet v, Show a, ToSQL a) => SQL -> a -> m ()
sqlSet name a = sqlSetCmd name (sqlParam a)
sqlSetInc :: (MonadState v m, SqlSet v) => SQL -> m ()
sqlSetInc name = sqlSetCmd name $ name <+> "+ 1"
sqlSetList :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [a] -> m ()
sqlSetList name as = sqlSetCmdList name (map sqlParam as)
sqlSetListWithDefaults :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [Maybe a] -> m ()
sqlSetListWithDefaults name as = sqlSetCmdList name (map (maybe "DEFAULT" sqlParam) as)
sqlCopyColumn :: (MonadState v m, SqlSet v) => SQL -> m ()
sqlCopyColumn column = sqlSetCmd column column
class SqlResult a where
sqlResult1 :: a -> SQL -> a
instance SqlResult SqlSelect where
sqlResult1 cmd sql = cmd { sqlSelectResult = sqlSelectResult cmd ++ [sql] }
instance SqlResult SqlInsert where
sqlResult1 cmd sql = cmd { sqlInsertResult = sqlInsertResult cmd ++ [sql] }
instance SqlResult SqlInsertSelect where
sqlResult1 cmd sql = cmd { sqlInsertSelectResult = sqlInsertSelectResult cmd ++ [sql] }
instance SqlResult SqlUpdate where
sqlResult1 cmd sql = cmd { sqlUpdateResult = sqlUpdateResult cmd ++ [sql] }
sqlResult :: (MonadState v m, SqlResult v) => SQL -> m ()
sqlResult sql = modify (\cmd -> sqlResult1 cmd sql)
class SqlOrderBy a where
sqlOrderBy1 :: a -> SQL -> a
instance SqlOrderBy SqlSelect where
sqlOrderBy1 cmd sql = cmd { sqlSelectOrderBy = sqlSelectOrderBy cmd ++ [sql] }
instance SqlOrderBy SqlInsertSelect where
sqlOrderBy1 cmd sql = cmd { sqlInsertSelectOrderBy = sqlInsertSelectOrderBy cmd ++ [sql] }
sqlOrderBy :: (MonadState v m, SqlOrderBy v) => SQL -> m ()
sqlOrderBy sql = modify (\cmd -> sqlOrderBy1 cmd sql)
class SqlGroupByHaving a where
sqlGroupBy1 :: a -> SQL -> a
sqlHaving1 :: a -> SQL -> a
instance SqlGroupByHaving SqlSelect where
sqlGroupBy1 cmd sql = cmd { sqlSelectGroupBy = sqlSelectGroupBy cmd ++ [sql] }
sqlHaving1 cmd sql = cmd { sqlSelectHaving = sqlSelectHaving cmd ++ [sql] }
instance SqlGroupByHaving SqlInsertSelect where
sqlGroupBy1 cmd sql = cmd { sqlInsertSelectGroupBy = sqlInsertSelectGroupBy cmd ++ [sql] }
sqlHaving1 cmd sql = cmd { sqlInsertSelectHaving = sqlInsertSelectHaving cmd ++ [sql] }
sqlGroupBy :: (MonadState v m, SqlGroupByHaving v) => SQL -> m ()
sqlGroupBy sql = modify (\cmd -> sqlGroupBy1 cmd sql)
sqlHaving :: (MonadState v m, SqlGroupByHaving v) => SQL -> m ()
sqlHaving sql = modify (\cmd -> sqlHaving1 cmd sql)
class SqlOffsetLimit a where
sqlOffset1 :: a -> Integer -> a
sqlLimit1 :: a -> Integer -> a
instance SqlOffsetLimit SqlSelect where
sqlOffset1 cmd num = cmd { sqlSelectOffset = num }
sqlLimit1 cmd num = cmd { sqlSelectLimit = num }
instance SqlOffsetLimit SqlInsertSelect where
sqlOffset1 cmd num = cmd { sqlInsertSelectOffset = num }
sqlLimit1 cmd num = cmd { sqlInsertSelectLimit = num }
sqlOffset :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m ()
sqlOffset val = modify (\cmd -> sqlOffset1 cmd $ toInteger val)
sqlLimit :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m ()
sqlLimit val = modify (\cmd -> sqlLimit1 cmd $ toInteger val)
class SqlDistinct a where
sqlDistinct1 :: a -> a
instance SqlDistinct SqlSelect where
sqlDistinct1 cmd = cmd { sqlSelectDistinct = True }
instance SqlDistinct SqlInsertSelect where
sqlDistinct1 cmd = cmd { sqlInsertSelectDistinct = True }
sqlDistinct :: (MonadState v m, SqlDistinct v) => m ()
sqlDistinct = modify (\cmd -> sqlDistinct1 cmd)
class (SqlWhere a, Sqlable a) => SqlTurnIntoSelect a where
sqlTurnIntoSelect :: a -> SqlSelect
instance SqlTurnIntoSelect SqlSelect where
sqlTurnIntoSelect = id
sqlTurnIntoWhyNotSelect :: (SqlTurnIntoSelect a) => a -> SqlSelect
sqlTurnIntoWhyNotSelect command =
sqlSelect "" . sqlResult $ mconcat [
"ARRAY["
, mintercalate ", " $ map emitExists [0..(count1)]
, "]::boolean[]"
]
where select = sqlTurnIntoSelect command
count :: Int
count = sum (map count' (sqlSelectWhere select))
count' (SqlPlainCondition {}) = 1
count' (SqlExistsCondition select') = sum (map count' (sqlSelectWhere select'))
emitExists :: Int -> SQL
emitExists current =
case runState (run current select) 0 of
(s, _) -> if null (sqlSelectWhere s)
then "TRUE"
else "EXISTS (" <> (toSQLCommand $ s { sqlSelectResult = [ "TRUE" ]}) <> ")"
run :: (MonadState Int m) => Int -> SqlSelect -> m SqlSelect
run current select' = do
new <- mapM (around current) (sqlSelectWhere select')
return (select' { sqlSelectWhere = concat new })
around :: (MonadState Int m) => Int -> SqlCondition -> m [SqlCondition]
around current cond@(SqlPlainCondition{}) = do
index <- get
modify (+1)
if current >= index
then return [cond]
else return []
around current (SqlExistsCondition subSelect) = do
subSelect' <- run current subSelect
return [SqlExistsCondition subSelect']
instance SqlTurnIntoSelect SqlUpdate where
sqlTurnIntoSelect s = SqlSelect
{ sqlSelectFrom = sqlUpdateWhat s <>
if isSqlEmpty (sqlUpdateFrom s)
then ""
else "," <+> sqlUpdateFrom s
, sqlSelectDistinct = False
, sqlSelectResult = if null (sqlUpdateResult s)
then ["TRUE"]
else sqlUpdateResult s
, sqlSelectWhere = sqlUpdateWhere s
, sqlSelectOrderBy = []
, sqlSelectGroupBy = []
, sqlSelectHaving = []
, sqlSelectOffset = 0
, sqlSelectLimit = 1
, sqlSelectWith = sqlUpdateWith s
}
instance SqlTurnIntoSelect SqlDelete where
sqlTurnIntoSelect s = SqlSelect
{ sqlSelectFrom = sqlDeleteFrom s <>
if isSqlEmpty (sqlDeleteUsing s)
then ""
else "," <+> sqlDeleteUsing s
, sqlSelectDistinct = False
, sqlSelectResult = if null (sqlDeleteResult s)
then ["TRUE"]
else sqlDeleteResult s
, sqlSelectWhere = sqlDeleteWhere s
, sqlSelectOrderBy = []
, sqlSelectGroupBy = []
, sqlSelectHaving = []
, sqlSelectOffset = 0
, sqlSelectLimit = 1
, sqlSelectWith = sqlDeleteWith s
}
instance SqlTurnIntoSelect SqlInsertSelect where
sqlTurnIntoSelect s = SqlSelect
{ sqlSelectFrom = sqlInsertSelectFrom s
, sqlSelectDistinct = False
, sqlSelectResult = sqlInsertSelectResult s
, sqlSelectWhere = sqlInsertSelectWhere s
, sqlSelectOrderBy = sqlInsertSelectOrderBy s
, sqlSelectGroupBy = sqlInsertSelectGroupBy s
, sqlSelectHaving = sqlInsertSelectHaving s
, sqlSelectOffset = sqlInsertSelectOffset s
, sqlSelectLimit = sqlInsertSelectLimit s
, sqlSelectWith = sqlInsertSelectWith s
}
data DBBaseLineConditionIsFalse = DBBaseLineConditionIsFalse SQL
deriving (Show, Typeable)
instance DBExtraException DBBaseLineConditionIsFalse
instance JSON.ToJSValue DBBaseLineConditionIsFalse where
toJSValue _sql = JSON.runJSONGen $ do
JSON.value "message" ("DBBaseLineConditionIsFalse"::String)
class (Show e, Typeable e, JSON.ToJSValue e) => DBExtraException e where
toDBExtraException :: e -> SomeDBExtraException
toDBExtraException = SomeDBExtraException
fromDBExtraException :: SomeDBExtraException -> Maybe e
fromDBExtraException (SomeDBExtraException e) = cast e
catchDBExtraException :: (MonadBaseControl IO m, DBExtraException e) => m a -> (e -> m a) -> m a
catchDBExtraException m f = m `E.catch` (\e -> case fromDBExtraException e of
Just ke -> f ke
Nothing -> throw e)
data SomeDBExtraException = forall e. (Show e, DBExtraException e) => SomeDBExtraException e
deriving Typeable
deriving instance Show SomeDBExtraException
instance Exception SomeDBExtraException where
toException = SomeException
fromException (SomeException e) = msum [ cast e
, do
DBException {dbeError = e'} <- cast e
cast e'
]
data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeDBExtraException)
kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
=> s -> m (Bool, SomeDBExtraException)
kWhyNot1Ex cmd = do
let newSelect = sqlTurnIntoSelect cmd
newWhyNotSelect = sqlTurnIntoWhyNotSelect newSelect
let findFirstFalse :: Identity (Array1 Bool) -> Int
findFirstFalse (Identity (Array1 row)) = fromMaybe 0 (findIndex (== False) row)
runQuery_ (newWhyNotSelect { sqlSelectLimit = 1 })
indexOfFirstFailedCondition <- fetchOne findFirstFalse
let logics = enumerateWhyNotExceptions ((sqlSelectFrom newSelect),[]) (sqlGetWhereConditions newSelect)
let condition = logics !! (indexOfFirstFailedCondition)
case condition of
(important, ExceptionMaker exception, _from, []) -> return (important, exception $ error "kWhyNot1Ex: this argument should've been ignored")
(important, ExceptionMaker exception, (from, conds), sqls) -> do
let statement' = sqlSelect2 from $ do
mapM_ sqlResult sqls
sqlLimit (1::Int)
sqlOffset (0::Int)
statement = statement' { sqlSelectWhere = conds }
runQuery_ statement
result <- fetchOne exception
return (important, result)
kWhyNot1 :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
=> s -> m SomeDBExtraException
kWhyNot1 cmd = snd `fmap` kWhyNot1Ex cmd
enumerateWhyNotExceptions :: (SQL, [SqlCondition])
-> [SqlCondition]
-> [( Bool
, ExceptionMaker
, (SQL, [SqlCondition])
, [SQL]
)]
enumerateWhyNotExceptions (from,condsUpTillNow) conds = concatMap worker (zip conds (inits conds))
where
worker (SqlPlainCondition _ (SqlWhyNot b f s), condsUpTillNow2) =
[(b, ExceptionMaker (SomeDBExtraException . f), (from, condsUpTillNow ++ condsUpTillNow2), s)]
worker (SqlExistsCondition s, condsUpTillNow2) =
enumerateWhyNotExceptions (newFrom, condsUpTillNow ++ condsUpTillNow2)
(sqlGetWhereConditions s)
where
newFrom = if isSqlEmpty from
then sqlSelectFrom s
else if isSqlEmpty (sqlSelectFrom s)
then from
else from <> ", " <> sqlSelectFrom s
kRunManyOrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
=> s -> m ()
kRunManyOrThrowWhyNot sqlable = do
success <- runQuery $ toSQLCommand sqlable
when (success == 0) $ do
exception <- kWhyNot1 sqlable
throwDB exception
kRun1OrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
=> s -> m ()
kRun1OrThrowWhyNot sqlable = do
success <- runQuery01 $ toSQLCommand sqlable
when (not success) $ do
exception <- kWhyNot1 sqlable
throwDB exception
kRun1OrThrowWhyNotAllowIgnore :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)
=> s -> m ()
kRun1OrThrowWhyNotAllowIgnore sqlable = do
success <- runQuery01 $ toSQLCommand sqlable
when (not success) $ do
(important, exception) <- kWhyNot1Ex sqlable
when (important) $
throwDB exception
kRunAndFetch1OrThrowWhyNot :: (IsSQL s, FromRow row, MonadDB m, MonadThrow m, SqlTurnIntoSelect s)
=> (row -> a) -> s -> m a
kRunAndFetch1OrThrowWhyNot decoder sqlcommand = do
runQuery_ sqlcommand
results <- fetchMany decoder
case results of
[] -> do
exception <- kWhyNot1 sqlcommand
throwDB exception
[r] -> return r
_ -> throwDB AffectedRowsMismatch {
rowsExpected = [(1, 1)]
, rowsDelivered = length results
}