diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +# hpqtypes-extras-1.12.0.0 (2021-10-??) +* Use plain exceptions instead of DBExtraException + # hpqtypes-extras-1.11.0.0 (2021-03-29) * Support running with higher table versions in the database than in the code 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.11.0.0 +version: 1.12.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -74,8 +74,8 @@ build-depends: base >= 4.9 && < 5 , hpqtypes >= 1.8.0.0 && < 2.0.0.0 - , base16-bytestring >= 0.1 && < 1.0.1.0 - , bytestring >= 0.10 && < 0.11 + , base16-bytestring >= 0.1 && < 1.0.2.0 + , bytestring >= 0.10 && < 0.12 , containers >= 0.5 && < 0.7 , cryptohash >= 0.11 && < 0.12 , exceptions >= 0.10 && < 0.11 @@ -84,10 +84,10 @@ , fields-json >= 0.4 && < 0.5 , text >= 1.2 && < 1.3 , lifted-base >= 0.2 && < 0.3 - , monad-control >= 1.0 && < 1.1 + , monad-control >= 1.0.3.1 && < 1.1 , semigroups >= 0.16 && < 0.20 - , text-show >= 3.7 && < 3.9 - , log-base >= 0.7 && < 0.10 + , text-show >= 3.7 && < 4 + , log-base >= 0.7 && < 0.11 , safe >= 0.3 && < 0.4 default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -778,19 +778,30 @@ CreateIndexConcurrentlyMigration tname idx -> do logMigration + -- We're in auto transaction mode (as ensured at the beginning of + -- 'checkDBConsistency'), so we need to issue explicit SQL commit, + -- because using 'commit' function automatically starts another + -- transaction. We don't want that as concurrent creation of index + -- won't run inside a transaction. + runSQL_ "COMMIT" -- If migration was run before but creation of an index failed, index -- will be left in the database in an inactive state, so when we -- rerun, we need to remove it first (see -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more -- information). - runQuery_ $ "DROP INDEX IF EXISTS" <+> indexName tname idx + runQuery_ $ "DROP INDEX CONCURRENTLY IF EXISTS" <+> indexName tname idx + runQuery_ (sqlCreateIndexConcurrently tname idx) `finally` begin + updateTableVersion + + DropIndexConcurrentlyMigration tname idx -> do + logMigration -- We're in auto transaction mode (as ensured at the beginning of -- 'checkDBConsistency'), so we need to issue explicit SQL commit, -- because using 'commit' function automatically starts another - -- transaction. We don't want that as concurrent creation of index + -- transaction. We don't want that as concurrent dropping of index -- won't run inside a transaction. runSQL_ "COMMIT" - runQuery_ (sqlCreateIndexConcurrently tname idx) `finally` begin + runQuery_ (sqlDropIndexConcurrently tname idx) `finally` begin updateTableVersion where logMigration = do diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -14,6 +14,7 @@ , sqlCreateIndexSequentially , sqlCreateIndexConcurrently , sqlDropIndex + , sqlDropIndexConcurrently ) where import Crypto.Hash.RIPEMD160 @@ -164,3 +165,6 @@ sqlDropIndex :: RawSQL () -> TableIndex -> RawSQL () sqlDropIndex tname idx = "DROP INDEX" <+> indexName tname idx + +sqlDropIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL () +sqlDropIndexConcurrently tname idx = "DROP INDEX CONCURRENTLY" <+> indexName tname idx diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -57,6 +57,16 @@ TableIndex #endif + -- | Migration for dropping an index concurrently. + | DropIndexConcurrentlyMigration +#if __GLASGOW_HASKELL__ >= 806 + (RawSQL ()) -- ^ Table name + TableIndex -- ^ Index +#else + (RawSQL ()) + TableIndex +#endif + -- | Migration object. data Migration m = Migration { @@ -77,6 +87,7 @@ StandardMigration{} -> True DropTableMigration{} -> False CreateIndexConcurrentlyMigration{} -> False + DropIndexConcurrentlyMigration{} -> False isDropTableMigration :: Migration m -> Bool isDropTableMigration Migration{..} = @@ -84,3 +95,4 @@ StandardMigration{} -> False DropTableMigration{} -> True CreateIndexConcurrentlyMigration{} -> False + DropIndexConcurrentlyMigration{} -> False 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 @@ -215,19 +215,16 @@ , sqlGetWhereConditions , SqlWhyNot(..) + , DBBaseLineConditionIsFalse(..) , kWhyNot1 + , kWhyNot1Ex --, DBExceptionCouldNotParseValues(..) , kRun1OrThrowWhyNot , kRun1OrThrowWhyNotAllowIgnore , kRunManyOrThrowWhyNot , kRunAndFetch1OrThrowWhyNot - , DBExtraException(..) - , SomeDBExtraException(..) - , catchDBExtraException - , DBBaseLineConditionIsFalse(..) - , Sqlable(..) , sqlOR , sqlConcatComma @@ -303,7 +300,7 @@ -- 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, DBExtraException e) => + forall e row. (FromRow row, Exception e) => SqlWhyNot Bool (row -> e) [SQL] {- @@ -646,7 +643,7 @@ -- | 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, DBExtraException e) => e -> SQL -> m () +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 @@ -659,28 +656,28 @@ -- 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, DBExtraException e, FromSQL a) => (a -> e, SQL) -> SQL -> m () +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, DBExtraException e, FromSQL a, FromSQL b) => (a -> b -> e, SQL, SQL) -> SQL -> m () +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, DBExtraException e, FromSQL a, FromSQL b, FromSQL c) => (a -> b -> c -> e, SQL, SQL, SQL) -> SQL -> m () +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, DBExtraException e, FromSQL a, FromSQL b, FromSQL c, FromSQL d) => (a -> b -> c -> d -> e, SQL, SQL, SQL, SQL) -> SQL -> m () +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 @@ -688,7 +685,7 @@ 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) +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 @@ -698,21 +695,21 @@ 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) +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, DBExtraException e, Show a, ToSQL a, FromSQL a) +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, DBExtraException e, Show a, ToSQL a, FromSQL a) +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 @@ -726,7 +723,7 @@ 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) +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 @@ -741,7 +738,7 @@ 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) +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 @@ -762,7 +759,7 @@ 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) +sqlWhereIsNULLE :: (MonadState v m, SqlWhere v, Exception e, FromSQL a) => (a -> e) -> SQL -> m () sqlWhereIsNULLE exc col = sqlWhereEV (exc, col) $ col <+> "IS NULL" @@ -773,7 +770,7 @@ -- | Add a condition just like 'sqlWhereAny' but throw the given exception if -- none of the given conditions hold. -sqlWhereAnyE :: (DBExtraException e, MonadState v m, SqlWhere v) +sqlWhereAnyE :: (Exception e, MonadState v m, SqlWhere v) => e -> [State SqlAll ()] -> m () sqlWhereAnyE e = sqlWhereE e . sqlWhereAnyImpl @@ -1123,30 +1120,7 @@ , sqlSelectLimit = sqlInsertSelectLimit s , sqlSelectWith = sqlInsertSelectWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE } -{- -data DBExceptionCouldNotParseValues = DBExceptionCouldNotParseValues TypeRep ConvertError [SqlValue] - deriving (Eq, Show, Typeable) -instance DBExtraException DBExceptionCouldNotParseValues - -instance JSON.ToJSValue DBExceptionCouldNotParseValues where - toJSValue _ = JSON.runJSONGen $ do - JSON.value "message" "DBExceptionCouldNotParseValues" - JSON.value "http_status" (500::Int) - -} -data DBBaseLineConditionIsFalse = DBBaseLineConditionIsFalse SQL - deriving (Show, Typeable) - -instance DBExtraException DBBaseLineConditionIsFalse - --- --- It it quite tempting to put the offending SQL as text in the JSON --- that we produce. This would aid debugging greatly, but could --- possibly also reveal too much information to a potential attacker. -instance JSON.ToJSValue DBBaseLineConditionIsFalse where - toJSValue _sql = JSON.runJSONGen $ do - JSON.value "message" ("DBBaseLineConditionIsFalse"::String) - {- 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 @@ -1165,7 +1139,7 @@ -- @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 [[SomeDBExtraException]] +kWhyNot :: (SqlTurnIntoSelect s, MonadDB m) => s -> m [[SomeException]] kWhyNot cmd = do let newSelect = sqlTurnIntoWhyNotSelect cmd if null (sqlSelectResult newSelect) @@ -1176,58 +1150,15 @@ -} --- | 'DBExtraException' and 'SomeDBExtraException' mimic 'Exception' and --- 'SomeException', but we need our own class and data type to limit its --- use to only those which describe semantic exceptions. --- --- Our data types also feature conversion to JSON type so that --- external representation is known in place where exception is --- defined. -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' - ] - -{- -instance Show SomeDBExtraException where - show (SomeDBExtraException e) = show e --} - -data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeDBExtraException) +data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeException) -data DBKwhyNotInternalError = DBKwhyNotInternalError String +newtype DBKwhyNotInternalError = DBKwhyNotInternalError String deriving (Show, Typeable) -instance DBExtraException DBKwhyNotInternalError - -instance JSON.ToJSValue DBKwhyNotInternalError where - toJSValue (DBKwhyNotInternalError msg) = JSON.runJSONGen $ - JSON.value "message" - ("Internal error in Database.PostgreSQL.PQTypes.SQL.Builder.kWhyNot1Ex: " - ++ msg) +instance Exception DBKwhyNotInternalError kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) - => s -> m (Bool, SomeDBExtraException) + => s -> m (Bool, SomeException) kWhyNot1Ex cmd = do let newSelect = sqlTurnIntoSelect cmd newWhyNotSelect = sqlTurnIntoWhyNotSelect newSelect @@ -1242,7 +1173,7 @@ case mcondition of Nothing -> return - (True, toDBExtraException . DBKwhyNotInternalError $ + (True, toException . DBKwhyNotInternalError $ "list of failed conditions is empty") Just (important, ExceptionMaker exception, _from, []) -> return (important, exception $ error "this argument should've been ignored") @@ -1263,7 +1194,7 @@ -- 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 SomeDBExtraException + => s -> m SomeException kWhyNot1 cmd = snd `fmap` kWhyNot1Ex cmd enumerateWhyNotExceptions :: (SQL, [SqlCondition]) @@ -1276,7 +1207,7 @@ 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)] + [(b, ExceptionMaker (SomeException . f), (from, condsUpTillNow ++ condsUpTillNow2), s)] worker (SqlExistsCondition s, condsUpTillNow2) = enumerateWhyNotExceptions (newFrom, condsUpTillNow ++ condsUpTillNow2) (sqlGetWhereConditions s) @@ -1287,13 +1218,24 @@ 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 - exception <- kWhyNot1 sqlable + SomeException exception <- kWhyNot1 sqlable throwDB exception @@ -1302,7 +1244,7 @@ kRun1OrThrowWhyNot sqlable = do success <- runQuery01 $ toSQLCommand sqlable when (not success) $ do - exception <- kWhyNot1 sqlable + SomeException exception <- kWhyNot1 sqlable throwDB exception @@ -1311,7 +1253,7 @@ kRun1OrThrowWhyNotAllowIgnore sqlable = do success <- runQuery01 $ toSQLCommand sqlable when (not success) $ do - (important, exception) <- kWhyNot1Ex sqlable + (important, SomeException exception) <- kWhyNot1Ex sqlable when (important) $ throwDB exception @@ -1322,7 +1264,7 @@ results <- fetchMany decoder case results of [] -> do - exception <- kWhyNot1 sqlcommand + SomeException exception <- kWhyNot1 sqlcommand throwDB exception [r] -> return r _ -> throwDB AffectedRowsMismatch {