Skip to content

Commit 378bfea

Browse files
ksaricksaric
authored
[TSD-39] Caching using a simple SQLite database (#18)
* [TSD-39] Caching using a simple SQLite database. * [TSD-39] Adding a simple mapping, seems complicated. * [TSD-39] Switched to simple-sqlite, fixed some field, functions, ... . * [TSD-39] Correct simple read-only implementation. * [TSD-39] Fix review comments.
1 parent f4b8730 commit 378bfea

File tree

10 files changed

+782
-441
lines changed

10 files changed

+782
-441
lines changed

‎log-classifier.cabal‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -23,10 +23,11 @@ library
2323
LogAnalysis.Types
2424
Regex
2525
Util
26-
Zendesk
26+
DataSource
2727
other-modules: Paths_log_classifier
28-
Zendesk.Types
29-
Zendesk.Functions
28+
DataSource.DB
29+
DataSource.Types
30+
DataSource.Http
3031
ghc-options: -Wall
3132
build-depends: aeson
3233
, array
@@ -43,6 +44,9 @@ library
4344
, universum
4445
, zip-archive
4546
, QuickCheck
47+
-- Database backend
48+
, sqlite-simple
49+
, generics-sop
4650

4751
default-language: Haskell2010
4852
default-extensions: TypeOperators

‎src/DataSource.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
-- Here we need to export just the public info.
2+
module DataSource
3+
( module DataSource.Types
4+
, module DataSource.Http
5+
, module DataSource.DB
6+
) where
7+
8+
import DataSource.Types
9+
import DataSource.Http
10+
import DataSource.DB
11+

‎src/DataSource/DB.hs‎

Lines changed: 163 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,163 @@
1+
{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
-- The idea behind this module and doing orphan instances is that
3+
-- if we ever want to switch to another implementation, we should
4+
-- just remove this module, not rewrite all the types and change instances.
5+
-- This way, we have real separation.
6+
7+
module DataSource.DB
8+
( withDatabase
9+
, withProdDatabase
10+
, cachedZendeskLayer
11+
) where
12+
13+
import Universum
14+
15+
import Data.Text (split)
16+
17+
import Database.SQLite.Simple (FromRow (..), NamedParam (..), SQLData (..), close, field,
18+
open, queryNamed, query_)
19+
import Database.SQLite.Simple.FromField (FromField (..), ResultError (..), returnError)
20+
import Database.SQLite.Simple.Internal (Connection, Field (..))
21+
import Database.SQLite.Simple.Ok (Ok (..))
22+
import Database.SQLite.Simple.ToField (ToField (..))
23+
24+
import DataSource.Types (Attachment (..), AttachmentContent (..), AttachmentId (..),
25+
Comment (..), CommentBody (..), CommentId (..), Config,
26+
TicketId (..), TicketInfo (..), TicketStatus (..),
27+
TicketTags (..), TicketURL (..), UserId (..), ZendeskLayer (..))
28+
29+
30+
-- https://ocharles.org.uk/blog/posts/2014-08-07-postgresql-simple-generic-sop.html
31+
32+
-- | The cached Zendesk layer. We are using a simple SQLite DB behind the scenes
33+
-- that we need to sync occasionaly.
34+
cachedZendeskLayer :: (MonadIO m, MonadReader Config m) => ZendeskLayer m
35+
cachedZendeskLayer = ZendeskLayer
36+
{ zlGetTicketInfo = liftIO . getTicketInfoByTicketId
37+
, zlListAssignedTickets = liftIO . getAllAssignedTicketsByUser
38+
, zlListRequestedTickets = liftIO . getAllRequestedTicketsByUser
39+
, zlGetAttachment = liftIO . DataSource.DB.getAttachmentContent
40+
, zlGetTicketComments = liftIO . getTicketComments
41+
, zlPostTicketComment = error "We won't use this for now!"
42+
}
43+
44+
-- Database instances
45+
-- FROM
46+
47+
instance FromField TicketId where
48+
fromField (Field (SQLInteger tId) _) = Ok . TicketId . fromIntegral $ tId
49+
fromField f = returnError ConversionFailed f "need an integer, ticket id"
50+
51+
instance FromField UserId where
52+
fromField (Field (SQLInteger uId) _) = Ok . UserId . fromIntegral $ uId
53+
fromField f = returnError ConversionFailed f "need an integer, user id"
54+
55+
instance FromField TicketURL where
56+
fromField (Field (SQLText tURL) _) = Ok . TicketURL $ tURL
57+
fromField f = returnError ConversionFailed f "need a text, ticket url"
58+
59+
-- | TODO(ks): Yes, yes, normal form...
60+
instance FromField TicketTags where
61+
fromField (Field (SQLText tTags) _) = Ok . TicketTags . split (==',') $ tTags
62+
fromField f = returnError ConversionFailed f "need a text, ticket tags"
63+
64+
instance FromField TicketStatus where
65+
fromField (Field (SQLText tStat) _) = Ok . TicketStatus $ tStat
66+
fromField f = returnError ConversionFailed f "need a text, ticket status"
67+
68+
instance FromRow TicketInfo where
69+
fromRow = TicketInfo <$> field <*> field <*> field <*> field <*> field <*> field
70+
71+
instance FromField CommentId where
72+
fromField (Field (SQLInteger commId) _) = Ok . CommentId . fromIntegral $ commId
73+
fromField f = returnError ConversionFailed f "need an integer, comment id"
74+
75+
instance FromField CommentBody where
76+
fromField (Field (SQLText cBody) _) = Ok . CommentBody $ cBody
77+
fromField f = returnError ConversionFailed f "need a text, comment body"
78+
79+
instance FromField AttachmentId where
80+
fromField (Field (SQLInteger attId) _) = Ok . AttachmentId . fromIntegral $ attId
81+
fromField f = returnError ConversionFailed f "need an integer, attachment id"
82+
83+
84+
-- TO
85+
86+
instance FromRow Attachment where
87+
fromRow = Attachment <$> field <*> field <*> field <*> field
88+
89+
instance FromRow AttachmentContent where
90+
fromRow = AttachmentContent <$> field
91+
92+
instance ToField TicketId where
93+
toField (TicketId tId) = SQLInteger . fromIntegral $ tId
94+
95+
instance ToField UserId where
96+
toField (UserId userId) = SQLInteger . fromIntegral $ userId
97+
98+
instance ToField CommentId where
99+
toField (CommentId commentId) = SQLInteger . fromIntegral $ commentId
100+
101+
instance ToField AttachmentId where
102+
toField (AttachmentId attachmentId) = SQLInteger . fromIntegral $ attachmentId
103+
104+
105+
-- | A general resource closing function.
106+
withDatabase :: forall a. String -> (Connection -> IO a) -> IO a
107+
withDatabase dbName dbOperation =
108+
bracket
109+
(open dbName)
110+
(close)
111+
dbOperation
112+
113+
-- | A production resource closing function.
114+
withProdDatabase :: forall a. (Connection -> IO a) -> IO a
115+
withProdDatabase = withDatabase "./prod.db"
116+
117+
_getTicketsInfo :: IO [TicketInfo]
118+
_getTicketsInfo = withProdDatabase $ \conn ->
119+
query_ conn "SELECT * FROM ticket_info"
120+
121+
getTicketInfoByTicketId :: TicketId -> IO (Maybe TicketInfo)
122+
getTicketInfoByTicketId ticketId = withProdDatabase $ \conn ->
123+
safeHead <$> queryNamed conn "SELECT * FROM ticket_info WHERE ticket_id = :id" [":id" := ticketId]
124+
125+
getAllAssignedTicketsByUser :: UserId -> IO [TicketInfo]
126+
getAllAssignedTicketsByUser userId = withProdDatabase $ \conn ->
127+
queryNamed conn "SELECT * FROM ticket_info WHERE assignee_id = :id" [":id" := userId]
128+
129+
getAllRequestedTicketsByUser :: UserId -> IO [TicketInfo]
130+
getAllRequestedTicketsByUser userId = withProdDatabase $ \conn ->
131+
queryNamed conn "SELECT * FROM ticket_info WHERE requester_id = :id" [":id" := userId]
132+
133+
134+
-- | A join would be more performance, but KISS for now.
135+
getTicketComments :: TicketId -> IO [Comment]
136+
getTicketComments ticketId = do
137+
commentsInfo <- getTicketIdComments ticketId
138+
139+
forM commentsInfo $ \(commentId, commentBody, commentIsPublic, commentAuthorId) -> do
140+
141+
commentAttachments <- getCommentAttachments commentId
142+
143+
pure Comment
144+
{ cId = commentId
145+
, cBody = commentBody
146+
, cAttachments = commentAttachments
147+
, cPublic = commentIsPublic
148+
, cAuthor = commentAuthorId
149+
}
150+
where
151+
getTicketIdComments :: TicketId -> IO [(CommentId, CommentBody, Bool, Integer)]
152+
getTicketIdComments ticketId' = withProdDatabase $ \conn ->
153+
queryNamed conn "SELECT tc.id, tc.body, tc.is_public, tc.author_id FROM ticket_comment tc WHERE tc.ticket_id = :id" [":id" := ticketId']
154+
155+
getCommentAttachments :: CommentId -> IO [Attachment]
156+
getCommentAttachments commentId = withProdDatabase $ \conn ->
157+
queryNamed conn "SELECT * FROM comment_attachments WHERE comment_id = :id" [":id" := commentId]
158+
159+
160+
getAttachmentContent :: Attachment -> IO (Maybe AttachmentContent)
161+
getAttachmentContent Attachment{..} = withProdDatabase $ \conn ->
162+
safeHead <$> queryNamed conn "SELECT * FROM attachment_content WHERE attachment_id = :id" [":id" := aId]
163+

src/Zendesk/Functions.hs renamed to src/DataSource/Http.hs

Lines changed: 55 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE RecordWildCards #-}
33

4-
module Zendesk.Functions
4+
module DataSource.Http
55
( basicZendeskLayer
66
, emptyZendeskLayer
77
, basicIOLayer
@@ -18,11 +18,12 @@ import Network.HTTP.Simple (Request, addRequestHeader, getResponseBody
1818
parseRequest_, setRequestBasicAuth, setRequestBodyJSON,
1919
setRequestMethod, setRequestPath)
2020

21-
import Zendesk.Types (Attachment (..), Comment (..), Config (..), IOLayer (..),
22-
RequestType (..), Ticket (..), TicketId, TicketInfo (..),
23-
TicketList (..), TicketTag (..), ZendeskLayer (..),
24-
ZendeskResponse (..), parseAgentId, parseComments, parseTickets,
25-
renderTicketStatus)
21+
import DataSource.Types (Attachment (..), AttachmentContent (..), Comment (..),
22+
CommentBody (..), CommentId (..), Config (..), IOLayer (..),
23+
Ticket (..), TicketId, TicketInfo (..), TicketList (..),
24+
TicketTag (..), User, UserId, ZendeskLayer (..),
25+
ZendeskResponse (..), parseComments, parseTickets,
26+
renderTicketStatus)
2627

2728

2829
-- | The default configuration.
@@ -45,9 +46,9 @@ defaultConfig =
4546
basicZendeskLayer :: (MonadIO m, MonadReader Config m) => ZendeskLayer m
4647
basicZendeskLayer = ZendeskLayer
4748
{ zlGetTicketInfo = getTicketInfo
48-
, zlListTickets = listTickets
49+
, zlListRequestedTickets = listRequestedTickets
50+
, zlListAssignedTickets = listAssignedTickets
4951
, zlPostTicketComment = postTicketComment
50-
, zlGetAgentId = getAgentId
5152
, zlGetAttachment = getAttachment
5253
, zlGetTicketComments = getTicketComments
5354
}
@@ -60,12 +61,12 @@ basicIOLayer = IOLayer
6061
}
6162

6263
-- | The non-implemented Zendesk layer.
63-
emptyZendeskLayer :: (MonadIO m, MonadReader Config m) => ZendeskLayer m
64+
emptyZendeskLayer :: forall m. ZendeskLayer m
6465
emptyZendeskLayer = ZendeskLayer
6566
{ zlGetTicketInfo = \_ -> error "Not implemented zlGetTicketInfo!"
66-
, zlListTickets = \_ -> error "Not implemented zlListTickets!"
67+
, zlListRequestedTickets = \_ -> error "Not implemented zlListRequestedTickets!"
68+
, zlListAssignedTickets = \_ -> error "Not implemented zlListAssignedTickets!"
6769
, zlPostTicketComment = \_ -> error "Not implemented zlPostTicketComment!"
68-
, zlGetAgentId = pure 1
6970
, zlGetAttachment = \_ -> error "Not implemented zlGetAttachment!"
7071
, zlGetTicketComments = \_ -> error "Not implemented zlGetTicketComments!"
7172
}
@@ -75,26 +76,47 @@ emptyZendeskLayer = ZendeskLayer
7576
getTicketInfo
7677
:: (MonadIO m, MonadReader Config m)
7778
=> TicketId
78-
-> m TicketInfo
79+
-> m (Maybe TicketInfo)
7980
getTicketInfo ticketId = do
8081
cfg <- ask
8182

8283
let req = apiRequest cfg ("tickets/" <> show ticketId <> ".json")
8384
liftIO $ apiCall parseJSON req
8485

85-
-- | Return list of ticketIds that has been requested by config user (not used)
86-
listTickets
87-
:: (MonadIO m, MonadReader Config m)
88-
=> RequestType
86+
87+
-- | Return list of ticketIds that has been requested by config user.
88+
listRequestedTickets
89+
:: forall m. (MonadIO m, MonadReader Config m)
90+
=> UserId
91+
-> m [TicketInfo]
92+
listRequestedTickets userId = do
93+
cfg <- ask
94+
95+
let url = "/users/" <> show userId <> "/tickets/requested.json"
96+
let req = apiRequest cfg url
97+
98+
iterateTicketPages req
99+
100+
-- | Return list of ticketIds that has been assigned by config user.
101+
listAssignedTickets
102+
:: forall m. (MonadIO m, MonadReader Config m)
103+
=> UserId
89104
-> m [TicketInfo]
90-
listTickets request = do
105+
listAssignedTickets userId = do
91106
cfg <- ask
92107

93-
let agentId = cfgAgentId cfg
94-
let url = case request of
95-
Requested -> "/users/" <> show agentId <> "/tickets/requested.json"
96-
Assigned -> "/users/" <> show agentId <> "/tickets/assigned.json"
97-
let req = apiRequest cfg url
108+
let url = "/users/" <> show userId <> "/tickets/assigned.json"
109+
let req = apiRequest cfg url
110+
111+
iterateTicketPages req
112+
113+
-- | Iterate all the ticket pages and combine into a result.
114+
iterateTicketPages
115+
:: forall m. (MonadIO m, MonadReader Config m)
116+
=> Request -> m [TicketInfo]
117+
iterateTicketPages req = do
118+
119+
cfg <- ask
98120

99121
let go :: [TicketInfo] -> Text -> IO [TicketInfo]
100122
go list' nextPage' = do
@@ -120,28 +142,28 @@ postTicketComment ZendeskResponse{..} = do
120142
let req1 = apiRequest cfg ("tickets/" <> show zrTicketId <> ".json")
121143
let req2 = addJsonBody
122144
(Ticket
123-
(Comment ("**Log classifier**\n\n" <> zrComment) [] zrIsPublic (cfgAgentId cfg))
145+
(Comment (CommentId 0) (CommentBody $ "**Log classifier**\n\n" <> zrComment) [] zrIsPublic (cfgAgentId cfg))
124146
(cfgAssignTo cfg)
125147
(renderTicketStatus AnalyzedByScriptV1_0:zrTags)
126148
)
127149
req1
128150
void $ liftIO $ apiCall (pure . encodeToLazyText) req2
129151

130-
-- | Get agent id that has been set on Config
131-
getAgentId
152+
-- | Get user information.
153+
_getUser
132154
:: (MonadIO m, MonadReader Config m)
133-
=> m Integer
134-
getAgentId = do
155+
=> m User
156+
_getUser = do
135157
cfg <- ask
136158
let req = apiRequest cfg "users/me.json"
137-
liftIO $ apiCall parseAgentId req
159+
liftIO $ apiCall parseJSON req
138160

139161
-- | Given attachmentUrl, return attachment in bytestring
140162
getAttachment
141-
:: (MonadIO m, MonadReader Config m) -- TODO(ks): We have to fix this
163+
:: (MonadIO m)
142164
=> Attachment
143-
-> m LByteString
144-
getAttachment Attachment{..} = getResponseBody <$> httpLBS req
165+
-> m (Maybe AttachmentContent)
166+
getAttachment Attachment{..} = Just . AttachmentContent . getResponseBody <$> httpLBS req
145167
where
146168
req :: Request
147169
req = parseRequest_ (toString aURL)
@@ -151,9 +173,9 @@ getTicketComments
151173
:: (MonadIO m, MonadReader Config m)
152174
=> TicketId
153175
-> m [Comment]
154-
getTicketComments tid = do
176+
getTicketComments tId = do
155177
cfg <- ask
156-
let req = apiRequest cfg ("tickets/" <> show tid <> "/comments.json")
178+
let req = apiRequest cfg ("tickets/" <> show tId <> "/comments.json")
157179
liftIO $ apiCall parseComments req
158180

159181
------------------------------------------------------------

0 commit comments

Comments
 (0)