hpqtypes-extras 1.11.0.0 → 1.12.0.0

raw patch · 6 files changed

+78/−106 lines, 6 filesdep ~base16-bytestringdep ~bytestringdep ~monad-controlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base16-bytestring, bytestring, monad-control

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• hpqtypes-extras.cabal +6/−6
• src/Database/PostgreSQL/PQTypes/Checks.hs +14/−3
• src/Database/PostgreSQL/PQTypes/Model/Index.hs +4/−0
• src/Database/PostgreSQL/PQTypes/Model/Migration.hs +12/−0
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +39/−97

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 {