diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# hpqtypes-extras-1.14.0.0 (2021-12-13) +* Add Support for ON CONFLICT to sqlInsertSelect. +* Remove upper bounds from library dependencies. +* Remove kRun* and kWhyNot functions. + # hpqtypes-extras-1.13.1.0 (2021-11-26) * Add support for including columns in indexes. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hpqtypes-extras -version: 1.13.1.0 +version: 1.14.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -73,23 +73,23 @@ , Database.PostgreSQL.PQTypes.Utils.NubList build-depends: base >= 4.9 && < 5 - , hpqtypes >= 1.8.0.0 && < 2.0.0.0 - , base16-bytestring >= 0.1 && < 1.1 - , bytestring >= 0.10 && < 0.12 - , containers >= 0.5 && < 0.7 - , cryptohash >= 0.11 && < 0.12 - , exceptions >= 0.10 && < 0.11 - , extra >= 1.6.17 && < 1.8.0 - , mtl >= 2.2 && < 2.3 - , fields-json >= 0.4 && < 0.5 - , text >= 1.2 && < 1.3 - , lifted-base >= 0.2 && < 0.3 - , monad-control >= 1.0.3.1 && < 1.1 - , semigroups >= 0.16 && < 0.20 - , text-show >= 3.7 && < 4 + , hpqtypes >= 1.8.0.0 + , base16-bytestring >= 0.1 + , bytestring >= 0.10 + , containers >= 0.5 + , cryptohash >= 0.11 + , exceptions >= 0.10 + , extra >= 1.6.17 + , mtl >= 2.2 + , fields-json >= 0.4 + , text >= 1.2 + , lifted-base >= 0.2 + , monad-control >= 1.0.3.1 + , semigroups >= 0.16 + , text-show >= 3.7 , transformers-base - , log-base >= 0.11 && < 0.12 - , safe >= 0.3 && < 0.4 + , log-base >= 0.11 + , safe >= 0.3 default-language: Haskell2010 default-extensions: diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs --- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -82,80 +82,26 @@ :} SQL " UPDATE document_tags SET value=<123> WHERE (name = 'abc') " -Exception returning and 'kWhyNot' are a subsystem for querying why a -query did not provide expected results. For example: - -> let query = sqlUpdate "documents" $ do -> sqlSet "deleted" True -> sqlWhereEq "documents.id" 12345 -> sqlWhereEqE DocumentDeleteFlagMustBe "documents.deleted" False -> sqlWhereILikeE DocumentTitleMustContain "documents.title" "%important%" -> result <- kRun query - -If the result is zero then no document was updated. We would like to -know what happened. In query we have three filtering clauses. One is a -baseline: the one mentioning @documents.id@. Baseline clauses define -what objects we are talking about. Other clauses are correctness -checks and may fail if status of on object is unexpected. Using -'kWhyNot' we can see what is wrong with an object: - -> problems <- kWhyNot query - -Now @problems@ should contain a list of issues with rows that could be -possibly be affected by weren't due to correctness clauses. For -example it may state: - -> problems = [[ DocumentDeleteFlagMustBe { documentDeleteFlagMustBe = False -> , documentDeleteFlagReallyIs = True -> } -> , DocumentTitleMustContain { documentTitleMustContain = "%important%" -> , documentTitleReallyIs = "Some contract v2" -> } -> ]] - -Note: problems is a nested array, for each object we get a list of -issues pertaining to that object. If that list is empty, then it means -that baseline conditions failed or there is no such object that -fullfills all conditions at the same time although there are some that -fullfill each one separatelly. - -Note: @kWhyNot@ is currently disabled. Use 'kWhyNot1' instead, which -returns a single exception. - -} -- TODO: clean this up, add more documentation. 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 @@ -182,10 +128,6 @@ , sqlWith , sqlUnion - , SqlTurnIntoSelect - , sqlTurnIntoSelect - , sqlTurnIntoWhyNotSelect - , sqlSelect , sqlSelect2 , SqlSelect(..) @@ -199,7 +141,6 @@ , SqlDelete(..) , sqlWhereAny - , sqlWhereAnyE , SqlResult , SqlSet @@ -210,21 +151,9 @@ , SqlOffsetLimit , SqlDistinct - , SqlCondition(..) , sqlGetWhereConditions - , SqlWhyNot(..) - , DBBaseLineConditionIsFalse(..) - - , kWhyNot1 - , kWhyNot1Ex - --, DBExceptionCouldNotParseValues(..) - , kRun1OrThrowWhyNot - , kRun1OrThrowWhyNotAllowIgnore - , kRunManyOrThrowWhyNot - , kRunAndFetch1OrThrowWhyNot - , Sqlable(..) , sqlOR , sqlConcatComma @@ -289,32 +218,12 @@ -- structure of a condition. For now it seems that the only -- interesting case is EXISTS (SELECT ...), because that internal -- SELECT can have explainable clauses. -data SqlCondition = SqlPlainCondition SQL SqlWhyNot +data SqlCondition = SqlPlainCondition SQL | SqlExistsCondition SqlSelect deriving (Typeable, Show) --- | 'SqlWhyNot' contains a recipe for how to query the database for --- some values we're interested in and construct a proper exception --- object using that information. For @SqlWhyNot mkException queries@ --- the @mkException@ should take as input a list of the same length --- list as there are queries. Each query will be run in a JOIN context --- with all referenced tables, so it can extract values from there. -data SqlWhyNot = - forall e row. (FromRow row, Exception e) => - SqlWhyNot Bool (row -> e) [SQL] - -{- -instance Eq SqlCondition where - (SqlPlainCondition a _) == (SqlPlainCondition b _) = a == b - (SqlExistsCondition a) == (SqlExistsCondition b) = a == b - _ == _ = False - -} - -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 (SqlPlainCondition a) = a toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")" data SqlSelect = SqlSelect @@ -349,18 +258,19 @@ } 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)] + { sqlInsertSelectWhat :: SQL + , sqlInsertSelectOnConflict :: Maybe (SQL, Maybe 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 @@ -459,20 +369,21 @@ orderByClause = emitClausesSepComma "ORDER BY" $ sqlSelectOrderBy cmd limitClause = unsafeSQL $ "LIMIT" <+> show (sqlSelectLimit cmd) +emitClauseOnConflictForInsert :: Maybe (SQL, Maybe SQL) -> SQL +emitClauseOnConflictForInsert = \case + Nothing -> "" + Just (condition, maction) -> emitClause "ON CONFLICT" $ + condition <+> "DO" <+> fromMaybe "NOTHING" maction + 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)))) <+> - emitClauseOnConflict (sqlInsertOnConflict cmd) <+> + emitClauseOnConflictForInsert (sqlInsertOnConflict cmd) <+> emitClausesSepComma "RETURNING" (sqlInsertResult cmd) where - emitClauseOnConflict = \case - Nothing -> "" - Just (condition, maction) -> emitClause "ON CONFLICT" $ - condition <+> "DO" <+> fromMaybe "NOTHING" maction - -- this is the longest list of values longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd))) lengthOfEither (Single _) = 1 @@ -500,6 +411,7 @@ , sqlSelectLimit = sqlInsertSelectLimit cmd , sqlSelectWith = [] } + , emitClauseOnConflictForInsert (sqlInsertSelectOnConflict cmd) , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd ] @@ -541,18 +453,19 @@ 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 = [] + { sqlInsertSelectWhat = table + , sqlInsertSelectOnConflict = Nothing + , sqlInsertSelectDistinct = False + , sqlInsertSelectSet = [] + , sqlInsertSelectResult = [] + , sqlInsertSelectFrom = from + , sqlInsertSelectWhere = [] + , sqlInsertSelectOrderBy = [] + , sqlInsertSelectGroupBy = [] + , sqlInsertSelectHaving = [] + , sqlInsertSelectOffset = 0 + , sqlInsertSelectLimit = -1 + , sqlInsertSelectWith = [] }) sqlUpdate :: SQL -> State SqlUpdate () -> SqlUpdate @@ -616,103 +529,26 @@ 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))) - -- | The @WHERE@ part of an SQL query. See above for a usage -- example. See also 'SqlCondition'. sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m () -sqlWhere sql = sqlWhereE (DBBaseLineConditionIsFalse sql) sql - --- | Like 'sqlWhere', but also takes an exception value that is thrown --- in case of error. See 'SqlCondition' and 'SqlWhyNot'. -sqlWhereE :: (MonadState v m, SqlWhere v, Exception e) => e -> SQL -> m () -sqlWhereE exc sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 []))) - where - exc2 (_::()) = exc - --- | Like 'sqlWhereE', but takes a one-argument function that --- constructs an exception value plus an SQL fragment for querying the --- database for the argument that is fed into the exception --- constructor function. See 'SqlCondition' and 'SqlWhyNot'. --- --- The SQL fragment should be of form @TABLENAME.COLUMNAME@, as it is --- executed as part of a @SELECT@ query involving all referenced --- tables. -sqlWhereEV :: (MonadState v m, SqlWhere v, Exception 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 - --- | Like 'sqlWhereEV', but the exception constructor function takes --- two arguments. -sqlWhereEVV :: (MonadState v m, SqlWhere v, Exception 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 - --- | Like 'sqlWhereEV', but the exception constructor function takes --- three arguments. -sqlWhereEVVV :: (MonadState v m, SqlWhere v, Exception 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 - --- | Like 'sqlWhereEV', but the exception constructor function takes --- four arguments. -sqlWhereEVVVV :: (MonadState v m, SqlWhere v, Exception 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 +sqlWhere sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql)) 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, Exception 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, Exception 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, Exception 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, Exception 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 @@ -723,13 +559,6 @@ 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, Exception 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 @@ -738,13 +567,6 @@ 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, Exception 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)) @@ -759,21 +581,11 @@ sqlWhereIsNotNULL :: (MonadState v m, SqlWhere v) => SQL -> m () sqlWhereIsNotNULL col = sqlWhere $ col <+> "IS NOT NULL" -sqlWhereIsNULLE :: (MonadState v m, SqlWhere v, Exception e, FromSQL a) - => (a -> e) -> SQL -> m () -sqlWhereIsNULLE exc col = sqlWhereEV (exc, col) $ col <+> "IS NULL" - -- | Add a condition in the WHERE statement that holds if any of the given -- condition holds. sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlAll ()] -> m () sqlWhereAny = sqlWhere . sqlWhereAnyImpl --- | Add a condition just like 'sqlWhereAny' but throw the given exception if --- none of the given conditions hold. -sqlWhereAnyE :: (Exception e, MonadState v m, SqlWhere v) - => e -> [State SqlAll ()] -> m () -sqlWhereAnyE e = sqlWhereE e . sqlWhereAnyImpl - sqlWhereAnyImpl :: [State SqlAll ()] -> SQL sqlWhereAnyImpl [] = "FALSE" sqlWhereAnyImpl l = @@ -837,22 +649,6 @@ instance SqlSet SqlInsertSelect where sqlSet1 cmd name v = cmd { sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)] } -sqlOnConflictDoNothing :: MonadState SqlInsert m => m () -sqlOnConflictDoNothing = modify $ \cmd -> cmd - { sqlInsertOnConflict = Just ("", Nothing) - } - -sqlOnConflictOnColumns - :: Sqlable sql => MonadState SqlInsert m => [SQL] -> sql -> m () -sqlOnConflictOnColumns columns sql = modify $ \cmd -> cmd - { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql) - } - -sqlOnConflictOnColumnsDoNothing :: MonadState SqlInsert m => [SQL] -> m () -sqlOnConflictOnColumnsDoNothing columns = modify $ \cmd -> cmd - { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing) - } - sqlSetCmd :: (MonadState v m, SqlSet v) => SQL -> SQL -> m () sqlSetCmd name sql = modify (\cmd -> sqlSet1 cmd name sql) @@ -874,6 +670,36 @@ sqlCopyColumn :: (MonadState v m, SqlSet v) => SQL -> m () sqlCopyColumn column = sqlSetCmd column column +class SqlOnConflict a where + sqlOnConflictDoNothing1 :: a -> a + sqlOnConflictOnColumnsDoNothing1 :: a -> [SQL] -> a + sqlOnConflictOnColumns1 :: Sqlable sql => a -> [SQL] -> sql -> a + +instance SqlOnConflict SqlInsert where + sqlOnConflictDoNothing1 cmd = + cmd { sqlInsertOnConflict = Just ("", Nothing) } + sqlOnConflictOnColumns1 cmd columns sql = + cmd { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql) } + sqlOnConflictOnColumnsDoNothing1 cmd columns = + cmd { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing) } + +instance SqlOnConflict SqlInsertSelect where + sqlOnConflictDoNothing1 cmd = + cmd { sqlInsertSelectOnConflict = Just ("", Nothing) } + sqlOnConflictOnColumns1 cmd columns sql = + cmd { sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql) } + sqlOnConflictOnColumnsDoNothing1 cmd columns = + cmd { sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing) } + +sqlOnConflictDoNothing :: (MonadState v m, SqlOnConflict v) => m () +sqlOnConflictDoNothing = modify sqlOnConflictDoNothing1 + +sqlOnConflictOnColumnsDoNothing :: (MonadState v m, SqlOnConflict v) => [SQL] -> m () +sqlOnConflictOnColumnsDoNothing columns = modify (\cmd -> sqlOnConflictOnColumnsDoNothing1 cmd columns) + +sqlOnConflictOnColumns :: (MonadState v m, SqlOnConflict v, Sqlable sql) => [SQL] -> sql -> m () +sqlOnConflictOnColumns columns sql = modify (\cmd -> sqlOnConflictOnColumns1 cmd columns sql) + class SqlResult a where sqlResult1 :: a -> SQL -> a @@ -889,8 +715,6 @@ 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) @@ -955,319 +779,3 @@ 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 - - --- | The 'sqlTurnIntoWhyNotSelect' turns a failed query into a --- why-not-query that can explain why query altered zero rows or --- returned zero results. --- --- Lets consider an example of explanation: --- --- > UPDATE t1 --- > SET a = 1 --- > WHERE cond1 --- > AND cond2 -- with value2 --- > AND EXISTS (SELECT TRUE --- > FROM t2 --- > WHERE cond3 -- with value3a and value3b --- > AND EXISTS (SELECT TRUE --- > FROM t3 --- > WHERE cond4)) --- --- 'sqlTurnIntoWhyNotSelect' will produce a @SELECT@ of the form: --- --- > SELECT --- > EXISTS (SELECT TRUE ... WHERE cond1), --- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2), --- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3), --- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3 AND cond4); --- --- Now, after this statement is executed we see which of these --- returned @FALSE@ as the first one. This is the condition that failed --- the whole query. --- --- We can get more information at this point. If failed condition was --- @cond2@, then @value2@ can be extracted by this statement: --- --- > SELECT value2 ... WHERE cond1; --- --- If failed condition was @cond3@, then statement executed can be: --- --- > SELECT value3a, value3b ... WHERE cond1 AND cond2; --- --- Rationale: @EXISTS@ clauses should pinpoint which @condX@ was the first --- one to produce zero rows. @SELECT@ clauses after @EXISTS@ should --- explain why condX filtered out all rows. --- --- 'DB.WhyNot.kWhyNot1' looks for first @EXISTS@ clause that is @FALSE@ --- and then tries to construct an @Exception@ object with values that come --- after. If values that comes after cannot be sensibly parsed --- (usually they are @NULL@ when a value is expected), this exception is --- skipped and next one is tried. --- --- If first @EXISTS@ clause is @TRUE@ but no other exception was properly --- generated then @DBExceptionCouldNotParseValues@ is thrown with pair --- of 'typeRef' of first exception that could not be parsed and with --- list of SqlValues that it could not parse. --- --- The 'DB.WhyNot.kRun1OrThrowWhyNot' throws first exception on the --- list. --- --- We have a theorem to use in this transformation: --- --- > EXISTS (SELECT t1 WHERE cond1 AND EXISTS (SELECT t2 WHERE cond2)) --- --- is equivalent to --- --- > EXISTS (SELECT t1, t2 WHERE cond1 AND cond2) --- --- and it can be used recursivelly. -sqlTurnIntoWhyNotSelect :: (SqlTurnIntoSelect a) => a -> SqlSelect -sqlTurnIntoWhyNotSelect command = - sqlSelect "" . sqlResult $ mconcat [ - "ARRAY[" - , mintercalate ", " $ map emitExists [0..(count-1)] - , "]::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 - , sqlSelectUnion = [] - , 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 -- this is a bit dangerous because it can contain nested DELETE/UPDATE - } - -instance SqlTurnIntoSelect SqlDelete where - sqlTurnIntoSelect s = SqlSelect - { sqlSelectFrom = sqlDeleteFrom s <> - if isSqlEmpty (sqlDeleteUsing s) - then "" - else "," <+> sqlDeleteUsing s - , sqlSelectUnion = [] - , 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 -- this is a bit dangerous because it can contain nested DELETE/UPDATE - } - -instance SqlTurnIntoSelect SqlInsertSelect where - sqlTurnIntoSelect s = SqlSelect - { sqlSelectFrom = sqlInsertSelectFrom s - , sqlSelectUnion = [] - , 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 -- this is a bit dangerous because it can contain nested DELETE/UPDATE - } - -{- Warning: use kWhyNot1 for now as kWhyNot does not work in expected way. - -kWhyNot should return a list of rows, where each row is a list of -exceptions. Right now we are not able to differentiate between rows -because we do not support a concept of a row identity. kWhyNot can -return rows in any order, returns empty rows for successful hits, does -not return a row if baseline conditions weren't met. This effectivelly -renders it useless. - -kWhyNot will be resurrected when we get a row identity concept. - --} - -{- --- | If 'kWhyNot1' returns an empty list of exceptions when none of --- @EXISTS@ clauses generated by 'sqlTurnIntoWhyNotSelect' was --- @FALSE@. Should not happen in real life, file a bug report if you see --- such a case. -kWhyNot :: (SqlTurnIntoSelect s, MonadDB m) => s -> m [[SomeException]] -kWhyNot cmd = do - let newSelect = sqlTurnIntoWhyNotSelect cmd - if null (sqlSelectResult newSelect) - then return [[]] - else do - kRun_ newSelect - kFold2 (decodeListOfExceptionsFromWhere (sqlGetWhereConditions cmd)) [] --} - - -data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeException) - -newtype DBKwhyNotInternalError = DBKwhyNotInternalError String - deriving (Show, Typeable) - -instance Exception DBKwhyNotInternalError - -kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) - => s -> m (Bool, SomeException) -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 mcondition = logics `atMay` indexOfFirstFailedCondition - - case mcondition of - Nothing -> return - (True, toException . DBKwhyNotInternalError $ - "list of failed conditions is empty") - Just (important, ExceptionMaker exception, _from, []) -> - return (important, exception $ error "this argument should've been ignored") - Just (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 } - --Log.debug $ "Explanation SQL:\n" ++ show statement - runQuery_ statement - result <- fetchOne exception - return (important, result) - --- | Function 'kWhyNot1' is a workhorse for explainable SQL --- failures. SQL fails if it did not affect any rows or did not return --- any rows. When that happens 'kWhyNot1' should be called. 'kWhyNot1' --- returns an exception describing why a row could not be --- returned or affected by a query. -kWhyNot1 :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) - => s -> m SomeException -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 (SomeException . 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 - --- | Implicit exception for `sqlWhere` combinator family. -newtype DBBaseLineConditionIsFalse = DBBaseLineConditionIsFalse SQL - deriving (Show, Typeable) - -instance Exception DBBaseLineConditionIsFalse where - fromException se@(SomeException e) = msum - [ cast e - , do - DBException {..} <- fromException se - fromException . toException $ dbeError - ] - -kRunManyOrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) - => s -> m () -kRunManyOrThrowWhyNot sqlable = do - success <- runQuery $ toSQLCommand sqlable - when (success == 0) $ do - SomeException 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 - SomeException 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, SomeException 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 - SomeException exception <- kWhyNot1 sqlcommand - throwDB exception - [r] -> return r - _ -> throwDB AffectedRowsMismatch { - rowsExpected = [(1, 1)] - , rowsDelivered = length results - } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -514,11 +514,61 @@ -- If NO CONFLICT is not specified, make sure we throw an exception. eres :: Either DBException () <- E.try . withSavepoint "testDBSchema" $ do - runQuery_ . sqlInsert "bank " $ do + runQuery_ . sqlInsert "bank" $ do sqlSet "id" bankId sqlSet "name" name sqlSet "location" location liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres) + + runQuery_ . sqlInsertSelect "bank" "bank" $ do + sqlSetCmd "id" "id" + sqlSetCmd "name" "name" + sqlSetCmd "location" "location" + sqlWhereEq "id" bankId + sqlOnConflictOnColumns ["id"] . sqlUpdate "" $ do + sqlSet "name" name + sqlSet "location" location + runQuery_ . sqlSelect "bank" $ do + sqlResult "name" + sqlResult "location" + sqlWhereEq "id" bankId + details5 <- fetchOne id + liftIO $ assertEqual "INSERT ON CONFLICT updates" (name, location) details5 + + runQuery_ . sqlInsertSelect "bank" "bank" $ do + sqlSetCmd "id" "id" + sqlSetCmd "name" "name" + sqlSetCmd "location" "location" + sqlWhereEq "id" bankId + sqlOnConflictDoNothing + runQuery_ . sqlSelect "bank" $ do + sqlResult "name" + sqlResult "location" + sqlWhereEq "id" bankId + details6 <- fetchOne id + liftIO $ assertEqual "INSERT ON CONFLICT does nothing (1)" (name, location) details6 + + runQuery_ . sqlInsertSelect "bank" "bank" $ do + sqlSetCmd "id" "id" + sqlSetCmd "name" "name" + sqlSetCmd "location" "location" + sqlWhereEq "id" bankId + sqlOnConflictOnColumnsDoNothing ["id"] + runQuery_ . sqlSelect "bank" $ do + sqlResult "name" + sqlResult "location" + sqlWhereEq "id" bankId + details7 <- fetchOne id + liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details7 + + -- If NO CONFLICT is not specified, make sure we throw an exception. + eres1 :: Either DBException () <- E.try . withSavepoint "testDBSchema" $ do + runQuery_ . sqlInsertSelect "bank" "bank" $ do + sqlSetCmd "id" "id" + sqlSetCmd "name" "name" + sqlSetCmd "location" "location" + sqlWhereEq "id" bankId + liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres1) -- Populate the 'bad_guy' table. runQuery_ . sqlInsert "bad_guy" $ do