Skip to content

Commit af6bd53

Browse files
HirotoShioiksaric
HirotoShioi
authored and
ksaric
committed
[TSD-93] Exception handling on DBLayer (#47)
* [TSD-93] Exception handling on DBLayer * Fixes based upon Kristijan's comments * Exception handling on DBLayer (attempt2) * Apply small fixes based upon the review * Add test cases * Small fix * Implement positive tests * Adjustments on positive tests * Add positive tests on deleteAllData * Fix styling * Fix typo * Remove redundant constraints * Fix query on tests * Small fixes * Remove parentheses * Fix styling * Remove more parentheses
1 parent 9b11fb5 commit af6bd53

File tree

3 files changed

+331
-67
lines changed

3 files changed

+331
-67
lines changed

‎log-classifier.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ library
5151
, optparse-applicative
5252
, reflection
5353
, regex-tdfa
54+
, safe-exceptions
5455
, text
5556
, time
5657
, universum
@@ -71,6 +72,7 @@ library
7172
ScopedTypeVariables
7273
FlexibleInstances
7374
FlexibleContexts
75+
LambdaCase
7476
TypeFamilies
7577
TypeApplications
7678
TypeOperators
@@ -129,6 +131,7 @@ test-suite log-classifier-test
129131
, log-classifier
130132
, mtl
131133
, reflection
134+
, sqlite-simple
132135
, regex-tdfa
133136
, text
134137
, universum

‎src/DataSource/DB.hs‎

Lines changed: 176 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,13 @@
66

77
module DataSource.DB
88
( DBConnPool
9+
, DBException(..)
10+
, DBLayerException(..)
11+
, createSchema
12+
, deleteAllData
13+
, insertCommentAttachments
14+
, insertTicketComments
15+
, insertTicketInfo
916
, withDatabase
1017
, withProdDatabase
1118
-- * Empty layer
@@ -22,13 +29,16 @@ module DataSource.DB
2229

2330
import Universum
2431

32+
import Control.Exception.Safe (Handler (..), catches)
2533
import Control.Monad.Trans.Control (MonadBaseControl)
2634

2735
import Data.Pool (Pool, createPool, withResource)
2836
import Data.Text (split)
37+
import Prelude as P (Show (..))
2938

30-
import Database.SQLite.Simple (FromRow (..), NamedParam (..), SQLData (..), close,
31-
executeNamed, execute_, field, open, queryNamed, query_)
39+
import Database.SQLite.Simple (FormatError (..), FromRow (..), NamedParam (..),
40+
Query (..), SQLData (..), close, executeNamed, execute_,
41+
field, open, queryNamed, query_)
3242
import Database.SQLite.Simple.FromField (FromField (..), ResultError (..), returnError)
3343
import Database.SQLite.Simple.Internal (Connection, Field (..))
3444
import Database.SQLite.Simple.Ok (Ok (..))
@@ -37,10 +47,10 @@ import Database.SQLite.Simple.ToField (ToField (..))
3747
import DataSource.Http (basicDataLayer)
3848
import DataSource.Types (Attachment (..), AttachmentContent (..), AttachmentId (..),
3949
Comment (..), CommentBody (..), CommentId (..), Config,
40-
DBLayer (..), TicketField (..), TicketFieldId (..),
41-
TicketFieldValue (..), TicketId (..), TicketInfo (..),
42-
TicketStatus (..), TicketTags (..), TicketURL (..), UserId (..),
43-
DataLayer (..))
50+
DBLayer (..), DataLayer (..), TicketField (..),
51+
TicketFieldId (..), TicketFieldValue (..), TicketId (..),
52+
TicketInfo (..), TicketStatus (..), TicketTags (..),
53+
TicketURL (..), UserId (..))
4454

4555
------------------------------------------------------------
4656
-- Single connection, simple
@@ -147,7 +157,10 @@ connDBLayer = DBLayer
147157

148158
-- | The connection pooled Zendesk layer. Used for database querying.
149159
-- We need to sync occasionaly.
150-
connPoolDataLayer :: forall m. (MonadBaseControl IO m, MonadIO m, MonadReader Config m) => DBConnPool -> DataLayer m
160+
connPoolDataLayer
161+
:: forall m. (MonadBaseControl IO m, MonadIO m, MonadReader Config m)
162+
=> DBConnPool
163+
-> DataLayer m
151164
connPoolDataLayer connPool = DataLayer
152165
{ zlGetTicketInfo = \tId -> withConnPool connPool $ \conn -> getTicketInfoByTicketId conn tId
153166
, zlListDeletedTickets = zlListDeletedTickets basicDataLayer
@@ -163,7 +176,10 @@ connPoolDataLayer connPool = DataLayer
163176

164177

165178
-- | The connection pooled database layer. Used for database modification.
166-
connPoolDBLayer :: forall m. (MonadBaseControl IO m, MonadIO m, MonadReader Config m) => DBConnPool -> DBLayer m
179+
connPoolDBLayer
180+
:: forall m. ( MonadBaseControl IO m, MonadIO m, MonadReader Config m, MonadCatch m)
181+
=> DBConnPool
182+
-> DBLayer m
167183
connPoolDBLayer connPool = DBLayer
168184
{ dlInsertTicketInfo = \tIn -> withConnPool connPool $ \conn -> insertTicketInfo conn tIn
169185
, dlInsertTicketComments = \tId comm -> withConnPool connPool $ \conn -> insertTicketComments conn tId comm
@@ -252,6 +268,9 @@ instance FromRow Attachment where
252268
instance FromRow AttachmentContent where
253269
fromRow = AttachmentContent <$> field
254270

271+
instance FromRow TicketId where
272+
fromRow = TicketId <$> field
273+
255274
instance ToField TicketId where
256275
toField (TicketId tId) = SQLInteger . fromIntegral $ tId
257276

@@ -360,47 +379,58 @@ getAttachmentContent conn Attachment{..} =
360379
-- TODO(ks): withTransaction
361380

362381
createSchema :: forall m. (MonadIO m) => Connection -> m ()
363-
createSchema conn = liftIO $ execute_ conn
364-
"CREATE TABLE `ticket_info` ( \
365-
\ `tiId` INTEGER, \
366-
\ `tiRequesterId` INTEGER NOT NULL, \
367-
\ `tiAssigneeId` INTEGER, \
368-
\ `tiUrl` TEXT NOT NULL, \
369-
\ `tiTags` TEXT NOT NULL, \
370-
\ `tiStatus` TEXT NOT NULL, \
371-
\ PRIMARY KEY(tiId) \
372-
\ ) WITHOUT ROWID; \
373-
\ \
374-
\ CREATE TABLE `ticket_comment` ( \
375-
\ `id` INTEGER, \
376-
\ `ticket_id` INTEGER NOT NULL, \
377-
\ `body` TEXT NOT NULL, \
378-
\ `is_public` INTEGER NOT NULL, \
379-
\ `author_id` INTEGER NOT NULL, \
380-
\ PRIMARY KEY(id), \
381-
\ FOREIGN KEY(`ticket_id`) REFERENCES ticket_info(tId) \
382-
\ ) WITHOUT ROWID; \
383-
\ \
384-
\ CREATE TABLE `comment_attachment` ( \
385-
\ `aId` INTEGER, \
386-
\ `comment_id` INTEGER NOT NULL, \
387-
\ `aURL` TEXT NOT NULL, \
388-
\ `aContentType` TEXT NOT NULL, \
389-
\ `aSize` INTEGER NOT NULL, \
390-
\ PRIMARY KEY(aId), \
391-
\ FOREIGN KEY(`comment_id`) REFERENCES ticket_comment ( ticket_id ) \
392-
\ ) WITHOUT ROWID; \
393-
\ \
394-
\ CREATE TABLE `attachment_content` ( \
395-
\ `attachment_id` INTEGER, \
396-
\ `content` BLOB NOT NULL, \
397-
\ PRIMARY KEY(attachment_id), \
398-
\ FOREIGN KEY(`attachment_id`) REFERENCES comment_attachment(aId) \
399-
\ )"
400-
401-
insertTicketInfo :: forall m. (MonadIO m) => Connection -> TicketInfo -> m ()
382+
createSchema conn = do
383+
createTicketInfoTable
384+
createTicketCommentTable
385+
createCommentAttachmentTable
386+
createAttachmentContentTable
387+
where
388+
createTicketInfoTable :: m ()
389+
createTicketInfoTable = liftIO $ execute_ conn
390+
"CREATE TABLE `ticket_info` ( \
391+
\ `tiId` INTEGER, \
392+
\ `tiRequesterId` INTEGER NOT NULL, \
393+
\ `tiAssigneeId` INTEGER, \
394+
\ `tiUrl` TEXT NOT NULL, \
395+
\ `tiTags` TEXT NOT NULL, \
396+
\ `tiStatus` TEXT NOT NULL, \
397+
\ PRIMARY KEY(tiId) \
398+
\ ) WITHOUT ROWID;"
399+
createTicketCommentTable :: m ()
400+
createTicketCommentTable = liftIO $ execute_ conn
401+
"CREATE TABLE `ticket_comment` ( \
402+
\ `id` INTEGER, \
403+
\ `ticket_id` INTEGER NOT NULL, \
404+
\ `body` TEXT NOT NULL, \
405+
\ `is_public` INTEGER NOT NULL, \
406+
\ `author_id` INTEGER NOT NULL, \
407+
\ PRIMARY KEY(id), \
408+
\ FOREIGN KEY(`ticket_id`) REFERENCES ticket_info(tiId) \
409+
\ ) WITHOUT ROWID;"
410+
createCommentAttachmentTable :: m ()
411+
createCommentAttachmentTable = liftIO $ execute_ conn
412+
"CREATE TABLE `comment_attachment` ( \
413+
\ `aId` INTEGER, \
414+
\ `comment_id` INTEGER NOT NULL, \
415+
\ `aURL` TEXT NOT NULL, \
416+
\ `aContentType` TEXT NOT NULL, \
417+
\ `aSize` INTEGER NOT NULL, \
418+
\ PRIMARY KEY(aId), \
419+
\ FOREIGN KEY(`comment_id`) REFERENCES ticket_comment ( ticket_id ) \
420+
\ ) WITHOUT ROWID;"
421+
createAttachmentContentTable :: m ()
422+
createAttachmentContentTable = liftIO $ execute_ conn
423+
"CREATE TABLE `attachment_content` ( \
424+
\ `attachment_id` INTEGER, \
425+
\ `content` BLOB NOT NULL, \
426+
\ PRIMARY KEY(attachment_id), \
427+
\ FOREIGN KEY(`attachment_id`) REFERENCES comment_attachment(aId) \
428+
\ )"
429+
430+
insertTicketInfo :: forall m. (MonadIO m, MonadCatch m) => Connection -> TicketInfo -> m ()
402431
insertTicketInfo conn TicketInfo{..} =
403-
liftIO $ executeNamed conn "INSERT INTO ticket_info (tiId, tiRequesterId, tiAssigneeId, tiUrl, tiTags, tiStatus) \
432+
liftIO $ executeNamedSafe (InsertTicketInfoFailed tiId)
433+
conn "INSERT INTO ticket_info (tiId, tiRequesterId, tiAssigneeId, tiUrl, tiTags, tiStatus) \
404434
\VALUES (:tiId, :tiRequesterId, :tiAssigneeId, :tiUrl, :tiTags, :tiStatus)"
405435
[ ":tiId" := tiId
406436
, ":tiRequesterId" := tiRequesterId
@@ -410,9 +440,15 @@ insertTicketInfo conn TicketInfo{..} =
410440
, ":tiStatus" := tiStatus
411441
]
412442

413-
insertTicketComments :: forall m. (MonadIO m) => Connection -> TicketId -> Comment -> m ()
443+
insertTicketComments
444+
:: forall m. (MonadIO m, MonadCatch m)
445+
=> Connection
446+
-> TicketId
447+
-> Comment
448+
-> m ()
414449
insertTicketComments conn ticketId Comment{..} =
415-
liftIO $ executeNamed conn "INSERT INTO ticket_comment (id, ticket_id, body, is_public, author_id) \
450+
liftIO $ executeNamedSafe (InsertTicketCommentsFailed ticketId cId)
451+
conn "INSERT INTO ticket_comment (id, ticket_id, body, is_public, author_id) \
416452
\VALUES (:id, :ticket_id, :body, :is_public, :author_id)"
417453
[ ":id" := cId
418454
, ":ticket_id" := ticketId
@@ -421,9 +457,15 @@ insertTicketComments conn ticketId Comment{..} =
421457
, ":author_id" := cAuthor
422458
]
423459

424-
insertCommentAttachments :: forall m. (MonadIO m) => Connection -> Comment -> Attachment -> m ()
460+
insertCommentAttachments
461+
:: forall m. (MonadIO m, MonadCatch m)
462+
=> Connection
463+
-> Comment
464+
-> Attachment
465+
-> m ()
425466
insertCommentAttachments conn Comment{..} Attachment{..} =
426-
liftIO $ executeNamed conn "INSERT INTO comment_attachment (aId, comment_id, aURL, aContentType, aSize) \
467+
liftIO $ executeNamedSafe (InsertCommentAttachmentFailed cId aId)
468+
conn "INSERT INTO comment_attachment (aId, comment_id, aURL, aContentType, aSize) \
427469
\VALUES (:aId, :comment_id, :aURL, :aContentType, :aSize)"
428470
[ ":aId" := aId
429471
, ":comment_id" := cId
@@ -432,22 +474,97 @@ insertCommentAttachments conn Comment{..} Attachment{..} =
432474
, ":aSize" := aSize
433475
]
434476

435-
deleteCommentAttachments :: forall m. (MonadIO m) => Connection -> m ()
477+
deleteCommentAttachments :: forall m. (MonadIO m, MonadCatch m) => Connection -> m ()
436478
deleteCommentAttachments conn =
437-
liftIO $ execute_ conn "DELETE FROM comment_attachment"
479+
liftIO $ executeSafe_ DBDeleteFailed conn "DELETE FROM comment_attachment"
438480

439-
deleteTicketComments :: forall m. (MonadIO m) => Connection -> m ()
481+
deleteTicketComments :: forall m. (MonadIO m, MonadCatch m) => Connection -> m ()
440482
deleteTicketComments conn =
441-
liftIO $ execute_ conn "DELETE FROM ticket_comment"
483+
liftIO $ executeSafe_ DBDeleteFailed conn "DELETE FROM ticket_comment"
442484

443-
deleteTickets :: forall m. (MonadIO m) => Connection -> m ()
485+
deleteTickets :: forall m. (MonadIO m, MonadCatch m) => Connection -> m ()
444486
deleteTickets conn =
445-
liftIO $ execute_ conn "DELETE FROM ticket_info"
487+
liftIO $ executeSafe_ DBDeleteFailed conn "DELETE FROM ticket_info"
446488

447489
-- | Delete all data.
448-
deleteAllData :: forall m. (MonadIO m) => Connection -> m ()
490+
deleteAllData :: forall m. (MonadIO m, MonadCatch m) => Connection -> m ()
449491
deleteAllData conn = do
450492
deleteCommentAttachments conn
451493
deleteTicketComments conn
452494
deleteTickets conn
453495

496+
497+
------------------------------------------------------------
498+
-- Exception handling
499+
------------------------------------------------------------
500+
501+
-- | 'executeNamed' with exception handling
502+
executeNamedSafe :: DBException -> Connection -> Query -> [NamedParam] -> IO ()
503+
executeNamedSafe err conn query nm = executeNamed conn query nm `catches`
504+
[Handler formatError, Handler $ errorHandler err]
505+
506+
-- | 'execute_' with exception handling
507+
executeSafe_ :: DBException -> Connection -> Query -> IO ()
508+
executeSafe_ err conn query = execute_ conn query `catches`
509+
[Handler formatError, Handler $ errorHandler err]
510+
511+
-- | Exception handling on 'FormatError'
512+
-- For now, we don't do anything with it
513+
formatError :: FormatError -> IO ()
514+
formatError = throwM
515+
516+
-- | Exception handling on 'Error'
517+
-- Since 'Error' from sqlite-simple does not have instance of Exception,
518+
-- the only way of catching it by 'SomeException'
519+
-- We want to throw it with additional info (TicketId, Comment data, etc.)
520+
errorHandler :: DBException -> SomeException -> IO ()
521+
errorHandler dberr someErr = throwM $ DBLayerException dberr someErr
522+
523+
-- | Exceptions that can occur in 'DBLayer'
524+
data DBException
525+
= DBDeleteFailed
526+
-- ^ Exception upon data deletion
527+
| InsertCommentAttachmentFailed CommentId AttachmentId
528+
-- ^ Exception upon inserting 'Comment' and it's associated 'Attachment' to the database
529+
| InsertTicketCommentsFailed TicketId CommentId
530+
-- ^ Exception upon inserting 'TicketId' and it's associated 'Comment' to the database
531+
| InsertTicketInfoFailed TicketId
532+
-- ^ Exception upon inserting 'TicketInfo' to the database
533+
534+
-- | This is used to throw both 'DBLayerException' and 'SomeException'
535+
-- 'Error' from sqlite-simple has no instance of 'Exception'
536+
-- therefore the only way to catching it is by 'SomeException'
537+
-- Both of these exception are need in case the program crashes and we need to
538+
-- find the root cause of it.
539+
data DBLayerException = DBLayerException DBException SomeException
540+
541+
instance Exception DBException
542+
543+
instance Exception DBLayerException
544+
545+
instance Show DBException where
546+
show = \case
547+
DBDeleteFailed ->
548+
"Exception occured while trying to delete from databse"
549+
InsertCommentAttachmentFailed cid aid -> concat
550+
[ "Exception occured while inserting comment and attachment on commentId: "
551+
, P.show (getCommentId cid)
552+
, ", attachmentId: "
553+
, P.show (getAttachmentId aid)
554+
]
555+
InsertTicketCommentsFailed tid cid -> concat
556+
[ "Exception occured while inserting ticket and comment on commentId: "
557+
, P.show (getCommentId cid)
558+
, ", ticketId: "
559+
, P.show (getTicketId tid)
560+
]
561+
InsertTicketInfoFailed tid ->
562+
"Exception occured while inserting TicketInfo with ticketId" <> P.show (getTicketId tid)
563+
564+
instance Show DBLayerException where
565+
show (DBLayerException dberr someErr) = concat
566+
[ "Error occured on DBlayer: "
567+
, P.show dberr
568+
, " with reason: "
569+
, P.show someErr
570+
]

0 commit comments

Comments
 (0)