From 0beec065596be3faee54cd7307ff3a7dcc171745 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sun, 30 Jul 2017 14:23:37 +0100 Subject: [PATCH 1/6] Added EsqueletoProblem for throwing internal esqueleto problems. Replaced all "error" calls to use throw instead. --- src/Database/Esqueleto/Internal/Sql.hs | 31 +++++++++++++++++++------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index ec4578e..c8a3c54 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -52,7 +52,7 @@ module Database.Esqueleto.Internal.Sql ) where import Control.Arrow ((***), first) -import Control.Exception (throw, throwIO) +import Control.Exception (Exception, throw, throwIO) import Control.Monad (ap, MonadPlus(..), void) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) @@ -76,6 +76,20 @@ import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Internal.Language +-- | Exception data type for @esqueleto@ internal problems +data EsqueletoProblem = + UnexpectedCompositeKeyError String -- | Unexpected composite key error + | UnexpectedCase String -- | Unexpected function case encountered + | EmptySqlExprValueList -- | EEmptyList found for value list + | UnsupportedSqlInsertIntoType -- | Default Exception for sqlInsertInto + deriving (Show) + +instance Exception EsqueletoProblem + + +---------------------------------------------------------------------- + + -- | SQL backend for @esqueleto@ using 'SqlPersistT'. newtype SqlQuery a = Q { unQ :: W.WriterT SideData (S.State IdentState) a } @@ -238,7 +252,7 @@ newIdentFor = Q . lift . try . unDBName s <- S.get let go (t:ts) | t `HS.member` inUse s = go ts | otherwise = use t - go [] = error "Esqueleto/Sql/newIdentFor: never here" + go [] = unexpectedCase "Esqueleto/Sql/newIdentFor: never here" go (possibilities orig) possibilities t = t : map addNum [2..] @@ -578,7 +592,7 @@ unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) - mapWhen [] _ = error "unsafeSqlCase: empty when list." + mapWhen [] _ = unexpectedCase "unsafeSqlCase: empty when list." mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) @@ -739,8 +753,7 @@ veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) veryUnsafeCoerceSqlExprValueList (EList v) = v -veryUnsafeCoerceSqlExprValueList EEmptyList = - error "veryUnsafeCoerceSqlExprValueList: empty list." +veryUnsafeCoerceSqlExprValueList EEmptyList = throw EmptySqlExprValueList ---------------------------------------------------------------------- @@ -1055,7 +1068,7 @@ makeFrom info mode fs = ret , mk Parens rhs , maybe mempty makeOnClause monClause ] - mk _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)" + mk _ (OnClause _) = unexpectedCase "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)" base ident@(I identText) def = let db@(DBName dbText) = entityDB def @@ -1080,8 +1093,10 @@ makeFrom info mode fs = ret mkExc (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/mkExc" unexpectedCompositeKeyError :: String -> a -unexpectedCompositeKeyError w = error $ w ++ ": non-id/composite keys not expected here" +unexpectedCompositeKeyError w = throw $ UnexpectedCompositeKeyError (w ++ ": non-id/composite keys not expected here") +unexpectedCase :: String -> a +unexpectedCase = throw . UnexpectedCase makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty @@ -1172,7 +1187,7 @@ class SqlSelect a r | a -> r, r -> a where -- | Create @INSERT INTO@ clause instead. sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) - sqlInsertInto = error "Type does not support sqlInsertInto." + sqlInsertInto = throw UnsupportedSqlInsertIntoType -- | @INSERT INTO@ hack. From b77a0c3e7185f627807702cec553fd41d4512cf2 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sun, 30 Jul 2017 15:04:45 +0100 Subject: [PATCH 2/6] Missed some error calls in: *) unsafeSqlBinOpComposite *) sqlSelectProcessRow in the instance of SqlSelect (SqlExpr InsertFinal) InsertFinal --- src/Database/Esqueleto/Internal/Sql.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index c8a3c54..7eb3669 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -82,6 +82,7 @@ data EsqueletoProblem = | UnexpectedCase String -- | Unexpected function case encountered | EmptySqlExprValueList -- | EEmptyList found for value list | UnsupportedSqlInsertIntoType -- | Default Exception for sqlInsertInto + | UnsafeSqlBinOpComposite String -- | Error in unsafeSqlBinOpComposite deriving (Show) instance Exception EsqueletoProblem @@ -674,7 +675,7 @@ unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify vc = v1 <> v2 err' = err . (++ (", " ++ show ((b1, v1), (b2, v2)))) - err = error . ("unsafeSqlBinOpComposite: " ++) + err = throw . UnsafeSqlBinOpComposite . ("unsafeSqlBinOpComposite: " ++) -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. @@ -1201,7 +1202,7 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info sqlSelectColCount = const 0 - sqlSelectProcessRow = const (Right (error msg)) + sqlSelectProcessRow = const (Right (throw $ UnexpectedCase msg)) where msg = "sqlSelectProcessRow/SqlSelect/InsertionFinal: never here" From 431080611de1f626fc743fc1410c2bcca343e4e0 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sun, 30 Jul 2017 16:55:02 +0100 Subject: [PATCH 3/6] Broke out the error types into three seperate sum types with one sum type enumerating them Identified and rewrote all error sections --- src/Database/Esqueleto/Internal/Sql.hs | 97 +++++++++++++++----------- 1 file changed, 58 insertions(+), 39 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 7eb3669..d341eef 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -76,16 +76,46 @@ import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Internal.Language --- | Exception data type for @esqueleto@ internal problems -data EsqueletoProblem = - UnexpectedCompositeKeyError String -- | Unexpected composite key error - | UnexpectedCase String -- | Unexpected function case encountered - | EmptySqlExprValueList -- | EEmptyList found for value list - | UnsupportedSqlInsertIntoType -- | Default Exception for sqlInsertInto - | UnsafeSqlBinOpComposite String -- | Error in unsafeSqlBinOpComposite +-- | Exception data type for @esqueleto@ internal errors +data EsqueletoError = + CompositeKeyErr CompositeKeyError + | UnexpectedCaseErr UnexpectedCaseError + | SqlBinOpCompositeErr SqlBinOpCompositeError deriving (Show) -instance Exception EsqueletoProblem +data CompositeKeyError = + NotError + | ToInsertionError + | CombineInsertionError + | FoldHelpError + | SqlCaseError + | SqlBinOpError + | MakeOnClauseError + | MakeExcError + | MakeSetError + | MakeWhereError + | MakeHavingError + deriving (Show) + +data UnexpectedCaseError = + EmptySqlExprValueList + | MakeFromError + | UnsupportedSqlInsertIntoType + | InsertionFinalError + | NewIdentForError + | UnsafeSqlCaseError + deriving (Show) + +data SqlBinOpCompositeError = + MismatchingLengthsError + | NullPlaceholdersError + | DeconstructionError + deriving (Show) + +instance Exception SqlBinOpCompositeError +instance Exception UnexpectedCaseError +instance Exception CompositeKeyError +instance Exception EsqueletoError ---------------------------------------------------------------------- @@ -253,7 +283,7 @@ newIdentFor = Q . lift . try . unDBName s <- S.get let go (t:ts) | t `HS.member` inUse s = go ts | otherwise = use t - go [] = unexpectedCase "Esqueleto/Sql/newIdentFor: never here" + go [] = throw NewIdentForError go (possibilities orig) possibilities t = t : map addNum [2..] @@ -463,7 +493,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals) - not_ (ECompositeKey _) = unexpectedCompositeKeyError "not_" + not_ (ECompositeKey _) = throw (CompositeKeyErr NotError) (==.) = unsafeSqlBinOpComposite " = " " AND " (!=.) = unsafeSqlBinOpComposite " != " " OR " @@ -529,13 +559,13 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where field /=. expr = setAux field (\ent -> ent ^. field /. expr) (<#) _ (ERaw _ f) = EInsert Proxy f - (<#) _ (ECompositeKey _) = unexpectedCompositeKeyError "(<#)" + (<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError) (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> let (fb, fv) = f x (gb, gv) = g x in (fb <> ", " <> gb, fv ++ gv) - (EInsert _ _) <&> (ECompositeKey _) = unexpectedCompositeKeyError "(<&>)" + (EInsert _ _) <&> (ECompositeKey _) = throw (CompositeKeyErr CombineInsertionError) case_ = unsafeSqlCase toBaseId = veryUnsafeCoerceSqlExprValue @@ -593,7 +623,7 @@ unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) - mapWhen [] _ = unexpectedCase "unsafeSqlCase: empty when list." + mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) @@ -601,8 +631,8 @@ unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase let (b1, vals1) = f1' info (b2, vals2) = f2 info in ( b0 <> " WHEN " <> parensM p1' b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 ) - foldHelp _ _ _ = unexpectedCompositeKeyError "unsafeSqlCase/foldHelp" -unsafeSqlCase _ (ECompositeKey _) = unexpectedCompositeKeyError "unsafeSqlCase" + foldHelp _ _ _ = throw (CompositeKeyErr FoldHelpError) +unsafeSqlCase _ (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError) -- | (Internal) Create a custom binary operator. You /should/ @@ -624,7 +654,7 @@ unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 ) -unsafeSqlBinOp _ _ _ = unexpectedCompositeKeyError "unsafeSqlBinOp" +unsafeSqlBinOp _ _ _ = throw (CompositeKeyErr SqlBinOpError) {-# INLINE unsafeSqlBinOp #-} @@ -662,20 +692,17 @@ unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), []) - deconstruct x = err $ "cannot deconstruct " ++ show x ++ "." + deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError) compose f1 f2 info - | not (null v1 || null v2) = err' "one side needs to have null placeholders" - | length b1 /= length b2 = err' "mismatching lengths" + | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError) + | length b1 /= length b2 = throw (SqlBinOpCompositeErr MismatchingLengthsError) | otherwise = (bc, vc) where (b1, v1) = f1 info (b2, v2) = f2 info bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2] vc = v1 <> v2 - err' = err . (++ (", " ++ show ((b1, v1), (b2, v2)))) - - err = throw . UnsafeSqlBinOpComposite . ("unsafeSqlBinOpComposite: " ++) -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. @@ -754,7 +781,7 @@ veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) veryUnsafeCoerceSqlExprValueList (EList v) = v -veryUnsafeCoerceSqlExprValueList EEmptyList = throw EmptySqlExprValueList +veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlExprValueList) ---------------------------------------------------------------------- @@ -1069,7 +1096,7 @@ makeFrom info mode fs = ret , mk Parens rhs , maybe mempty makeOnClause monClause ] - mk _ (OnClause _) = unexpectedCase "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)" + mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError) base ident@(I identText) def = let db@(DBName dbText) = entityDB def @@ -1085,31 +1112,25 @@ makeFrom info mode fs = ret fromKind FullOuterJoinKind = " FULL OUTER JOIN " makeOnClause (ERaw _ f) = first (" ON " <>) (f info) - makeOnClause (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/makeOnClause" + makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f info) - mkExc (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/mkExc" - -unexpectedCompositeKeyError :: String -> a -unexpectedCompositeKeyError w = throw $ UnexpectedCompositeKeyError (w ++ ": non-id/composite keys not expected here") - -unexpectedCase :: String -> a -unexpectedCase = throw . UnexpectedCase + mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError) makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where mk (SetClause (ERaw _ f)) = [f info] - mk (SetClause (ECompositeKey _)) = unexpectedCompositeKeyError "makeSet" -- FIXME + mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) -makeWhere _ (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeWhere" +makeWhere _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeWhereError) makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) @@ -1126,7 +1147,7 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) -makeHaving _ (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeHaving" +makeHaving _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeHavingError) -- makeHaving, makeWhere and makeOrderBy makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) @@ -1188,7 +1209,7 @@ class SqlSelect a r | a -> r, r -> a where -- | Create @INSERT INTO@ clause instead. sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) - sqlInsertInto = throw UnsupportedSqlInsertIntoType + sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType) -- | @INSERT INTO@ hack. @@ -1202,9 +1223,7 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info sqlSelectColCount = const 0 - sqlSelectProcessRow = const (Right (throw $ UnexpectedCase msg)) - where - msg = "sqlSelectProcessRow/SqlSelect/InsertionFinal: never here" + sqlSelectProcessRow = const (Right (throw InsertionFinalError)) -- | Not useful for 'select', but used for 'update' and 'delete'. From b7df667d3e5eada7b053f29e252e1c452e054aba Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Sun, 30 Jul 2017 11:07:27 -0500 Subject: [PATCH 4/6] Fix spurious Exception instances --- src/Database/Esqueleto/Internal/Sql.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index d341eef..3b8f3c1 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -112,9 +112,6 @@ data SqlBinOpCompositeError = | DeconstructionError deriving (Show) -instance Exception SqlBinOpCompositeError -instance Exception UnexpectedCaseError -instance Exception CompositeKeyError instance Exception EsqueletoError @@ -283,7 +280,7 @@ newIdentFor = Q . lift . try . unDBName s <- S.get let go (t:ts) | t `HS.member` inUse s = go ts | otherwise = use t - go [] = throw NewIdentForError + go [] = throw (UnexpectedCaseErr NewIdentForError) go (possibilities orig) possibilities t = t : map addNum [2..] @@ -1223,7 +1220,8 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info sqlSelectColCount = const 0 - sqlSelectProcessRow = const (Right (throw InsertionFinalError)) + sqlSelectProcessRow = + const (Right (throw (UnexpectedCaseErr InsertionFinalError))) -- | Not useful for 'select', but used for 'update' and 'delete'. From 36acb1e1c27b01b34f0b0943ec68339aa7fb4d02 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Sun, 30 Jul 2017 11:10:38 -0500 Subject: [PATCH 5/6] Move Exception closer to EsqueletoError --- src/Database/Esqueleto/Internal/Sql.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 3b8f3c1..bf49f5f 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -83,6 +83,8 @@ data EsqueletoError = | SqlBinOpCompositeErr SqlBinOpCompositeError deriving (Show) +instance Exception EsqueletoError + data CompositeKeyError = NotError | ToInsertionError @@ -112,8 +114,6 @@ data SqlBinOpCompositeError = | DeconstructionError deriving (Show) -instance Exception EsqueletoError - ---------------------------------------------------------------------- From bf66a49beba20e7f2f5014be9c4f7ad4042cc7b5 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Mon, 31 Jul 2017 10:48:03 -0500 Subject: [PATCH 6/6] Spurious ruler --- src/Database/Esqueleto/Internal/Sql.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index bf49f5f..02861ab 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -115,8 +115,6 @@ data SqlBinOpCompositeError = deriving (Show) ----------------------------------------------------------------------- - -- | SQL backend for @esqueleto@ using 'SqlPersistT'. newtype SqlQuery a =