diff --git a/log-classifier.cabal b/log-classifier.cabal index 613e688..b116114 100644 --- a/log-classifier.cabal +++ b/log-classifier.cabal @@ -28,11 +28,11 @@ library DataSource Configuration Util + HttpLayer other-modules: Paths_log_classifier DataSource.DB DataSource.Types DataSource.Http - HttpLayer ghc-options: -Wall build-depends: aeson , array diff --git a/src/DataSource/DB.hs b/src/DataSource/DB.hs index 58b96b5..eb0bf46 100644 --- a/src/DataSource/DB.hs +++ b/src/DataSource/DB.hs @@ -123,7 +123,7 @@ emptyDBLayer = DBLayer -- | The simple connection Zendesk layer. Used for database querying. -- We need to sync occasionaly. -connDataLayer :: forall m. (MonadIO m, MonadReader Config m) => DataLayer m +connDataLayer :: forall m. (MonadIO m, MonadCatch m, MonadReader Config m) => DataLayer m connDataLayer = DataLayer { zlGetTicketInfo = \tId -> withProdDatabase $ \conn -> getTicketInfoByTicketId conn tId , zlListDeletedTickets = zlListDeletedTickets basicDataLayer @@ -158,7 +158,7 @@ connDBLayer = DBLayer -- | The connection pooled Zendesk layer. Used for database querying. -- We need to sync occasionaly. connPoolDataLayer - :: forall m. (MonadBaseControl IO m, MonadIO m, MonadReader Config m) + :: forall m. (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadReader Config m) => DBConnPool -> DataLayer m connPoolDataLayer connPool = DataLayer @@ -176,7 +176,7 @@ connPoolDataLayer connPool = DataLayer -- | The connection pooled database layer. Used for database modification. -connPoolDBLayer +connPoolDBLayer :: forall m. ( MonadBaseControl IO m, MonadIO m, MonadReader Config m, MonadCatch m) => DBConnPool -> DBLayer m diff --git a/src/DataSource/Http.hs b/src/DataSource/Http.hs index 17c440c..6ac5599 100644 --- a/src/DataSource/Http.hs +++ b/src/DataSource/Http.hs @@ -18,7 +18,8 @@ import Data.Aeson.Text (encodeToLazyText) import Data.List (nub) import Network.HTTP.Simple (Request, getResponseBody, httpLBS, parseRequest_) -import HttpLayer (HTTPNetworkLayer (..), apiRequest, apiRequestAbsolute) +import HttpLayer (HTTPNetworkLayer (..), HttpNetworkLayerException (..), apiRequest, + apiRequestAbsolute) import DataSource.Types (Attachment (..), AttachmentContent (..), Comment (..), CommentBody (..), CommentId (..), Config (..), DataLayer (..), @@ -39,7 +40,7 @@ import DataSource.Types (Attachment (..), AttachmentContent (..), Comm -- - get returns a single result (wrapped in @Maybe@) -- - list returns multiple results -- - post submits a result (maybe PUT?!) -basicDataLayer :: (MonadIO m, MonadReader Config m) => DataLayer m +basicDataLayer :: (MonadIO m, MonadCatch m, MonadReader Config m) => DataLayer m basicDataLayer = DataLayer { zlGetTicketInfo = getTicketInfo , zlListDeletedTickets = listDeletedTickets @@ -74,7 +75,7 @@ emptyDataLayer = DataLayer -- | Get single ticket info. getTicketInfo - :: (HasCallStack, MonadIO m, MonadReader Config m) + :: (HasCallStack, MonadIO m, MonadCatch m, MonadReader Config m) => TicketId -> m (Maybe TicketInfo) getTicketInfo ticketId = do @@ -85,7 +86,54 @@ getTicketInfo ticketId = do apiCall <- asksHTTPNetworkLayer hnlApiCall - Just <$> apiCall parseTicket req + result <- try $ apiCall parseTicket req + + notFoundExceptionToMaybe result + where + -- | We want only @HttpNotFound@ to return @Nothing@, otherwise + -- propagate the exception. + notFoundExceptionToMaybe + :: forall m a. (MonadCatch m) + => Either HttpNetworkLayerException a + -> m (Maybe a) + notFoundExceptionToMaybe result = case result of + Left exception -> case exception of + HttpNotFound _ -> pure Nothing + otherExceptions -> throwM otherExceptions + Right ticketInfo -> pure $ Just ticketInfo + +-- | Get ticket's comments +getTicketComments + :: (HasCallStack, MonadIO m, MonadCatch m, MonadReader Config m) + => TicketId + -> m [Comment] +getTicketComments tId = do + cfg <- ask + + apiCall <- asksHTTPNetworkLayer hnlApiCall + + let url = showURL $ TicketCommentsURL tId + let req = apiRequest cfg url + + result <- try $ apiCall parseComments req + + notFoundExceptionToList result + where + -- | We want only @HttpNotFound@ to return an empty list, otherwise + -- propagate the exception. + -- When a @Ticket@ is not found, we don't have any of the @[Comment]@, + -- effectivly returning an empty list. + -- We might include a stricter policy to cause exception when no ticket is + -- found, but this should be good as well. + notFoundExceptionToList + :: forall m a. (MonadCatch m) + => Either HttpNetworkLayerException [a] + -> m [a] + notFoundExceptionToList result = case result of + Left exception -> case exception of + HttpNotFound _ -> pure [] + otherExceptions -> throwM otherExceptions + Right comments -> pure comments -- | Return list of deleted tickets. listDeletedTickets @@ -151,7 +199,7 @@ listAdminAgents = do -- NOTE: If count is less than 1000, then stop paginating. -- Otherwise, use the next_page URL to get the next page of results. getExportedTickets - :: forall m. (MonadIO m, MonadReader Config m) + :: forall m. (MonadIO m, MonadCatch m, MonadReader Config m) => ExportFromTime -> m [TicketInfo] getExportedTickets time = do @@ -193,7 +241,7 @@ getExportedTickets time = do -- | Send API request to post comment postTicketComment - :: (MonadIO m, MonadReader Config m) + :: (MonadIO m, MonadCatch m, MonadReader Config m) => TicketInfo -> ZendeskResponse -> m () @@ -231,7 +279,7 @@ createResponseTicket agentId TicketInfo{..} ZendeskResponse{..} = -- | Get user information. _getUser - :: (MonadIO m, MonadReader Config m) + :: (MonadIO m, MonadCatch m, MonadReader Config m) => m User _getUser = do cfg <- ask @@ -253,27 +301,6 @@ getAttachment Attachment{..} = Just . AttachmentContent . getResponseBody <$> ht req :: Request req = parseRequest_ (toString aURL) --- | Get ticket's comments -getTicketComments - :: (MonadIO m, MonadReader Config m) - => TicketId - -> m [Comment] -getTicketComments tId = do - cfg <- ask - - apiCallSafe <- asksHTTPNetworkLayer hnlApiCallSafe - - let url = showURL $ TicketCommentsURL tId - let req = apiRequest cfg url - - result <- apiCallSafe parseComments req - - -- TODO(ks): For now return empty if there is an exception. - -- After we have exception handling, we propagate this up. - case result of - Left _ -> pure [] - Right r -> pure r - ------------------------------------------------------------ -- Utility ------------------------------------------------------------ diff --git a/src/DataSource/Types.hs b/src/DataSource/Types.hs index d6c8835..aa07a0b 100644 --- a/src/DataSource/Types.hs +++ b/src/DataSource/Types.hs @@ -206,9 +206,10 @@ data DataLayer m = DataLayer -- We need to use RankNTypes due to some complications that appeared. data HTTPNetworkLayer = HTTPNetworkLayer { hnlAddJsonBody :: forall a. (ToJSON a) => a -> Request -> Request - -- TODO(ks): These two below are basically the same, will fix in future PR, requires refactoring. - , hnlApiCall :: forall m a. (MonadIO m, FromJSON a) => (Value -> Parser a) -> Request -> m a - , hnlApiCallSafe :: forall m a. (MonadIO m, FromJSON a) => (Value -> Parser a) -> Request -> m (Either String a) + , hnlApiCall :: forall m a. (MonadIO m, MonadCatch m, FromJSON a) + => (Value -> Parser a) + -> Request + -> m a } -- | The IOLayer interface that we can expose. diff --git a/src/HttpLayer.hs b/src/HttpLayer.hs index fc32350..8f04125 100644 --- a/src/HttpLayer.hs +++ b/src/HttpLayer.hs @@ -1,5 +1,6 @@ module HttpLayer ( HTTPNetworkLayer (..) + , HttpNetworkLayerException (..) , basicHTTPNetworkLayer , emptyHTTPNetworkLayer , apiRequest @@ -8,14 +9,16 @@ module HttpLayer import Universum -import Data.Aeson (FromJSON, ToJSON, Value, encode) +import Data.Aeson (FromJSON, ToJSON, Value) import Data.Aeson.Types (Parser, parseEither) -import Network.HTTP.Simple (Request, addRequestHeader, getResponseBody, httpJSON, - parseRequest_, setRequestBasicAuth, setRequestBodyJSON, - setRequestMethod, setRequestPath) +import Network.HTTP.Simple (Request, addRequestHeader, defaultRequest, getResponseBody, + getResponseStatusCode, httpJSONEither, parseRequest_, + setRequestBasicAuth, setRequestBodyJSON, setRequestMethod, + setRequestPath) import DataSource.Types (Config (..), HTTPNetworkLayer (..)) +import Test.QuickCheck (Arbitrary (..), oneof) ------------------------------------------------------------ -- Layer @@ -25,16 +28,75 @@ basicHTTPNetworkLayer :: HTTPNetworkLayer basicHTTPNetworkLayer = HTTPNetworkLayer { hnlAddJsonBody = addJsonBody , hnlApiCall = apiCall - , hnlApiCallSafe = apiCallSafe } emptyHTTPNetworkLayer :: HTTPNetworkLayer emptyHTTPNetworkLayer = HTTPNetworkLayer { hnlAddJsonBody = \_ _ -> error "hnlAddJsonBody not implemented!" , hnlApiCall = \_ -> error "hnlApiCall not implemented!" - , hnlApiCallSafe = \_ _ -> error "hnlApiCallSafe not implemented!" } +------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------ + +data HttpNetworkLayerException + = HttpDecodingJSON Request String + -- 4XX + | HttpBadRequest Request + | HttpUnauthorized Request + | HttpForbidden Request + | HttpNotFound Request + | HttpMethodNotAllowed Request + | HttpUnsupportedMediaType Request + | HttpTooManyRequests Request + -- 5XX + | HttpInternalServerError Request + | HttpNotImplemented Request + | HttpServiceUnavailable Request + deriving (Show) + +-- | The way to convert the status codes to exceptions. +statusCodeToException :: forall m. (MonadThrow m) => Request -> Int -> m () +statusCodeToException request = \case + 400 -> throwM $ HttpBadRequest request + 401 -> throwM $ HttpUnauthorized request + 403 -> throwM $ HttpForbidden request + 404 -> throwM $ HttpNotFound request + 405 -> throwM $ HttpMethodNotAllowed request + 415 -> throwM $ HttpUnsupportedMediaType request + 429 -> throwM $ HttpTooManyRequests request + + 500 -> throwM $ HttpInternalServerError request + 501 -> throwM $ HttpNotImplemented request + 503 -> throwM $ HttpServiceUnavailable request + + _ -> pure () + + +instance Exception HttpNetworkLayerException + +-- | TODO(ks): Good enough for our purposes +instance Arbitrary Request where + arbitrary = pure defaultRequest + +instance Arbitrary HttpNetworkLayerException where + arbitrary = oneof + [ HttpDecodingJSON <$> arbitrary <*> arbitrary + + , HttpBadRequest <$> arbitrary + , HttpUnauthorized <$> arbitrary + , HttpForbidden <$> arbitrary + , HttpNotFound <$> arbitrary + , HttpMethodNotAllowed <$> arbitrary + , HttpUnsupportedMediaType <$> arbitrary + , HttpTooManyRequests <$> arbitrary + + , HttpInternalServerError <$> arbitrary + , HttpNotImplemented <$> arbitrary + , HttpServiceUnavailable <$> arbitrary + ] + ------------------------------------------------------------ -- Functions ------------------------------------------------------------ @@ -64,29 +126,27 @@ addJsonBody :: forall a. ToJSON a => a -> Request -> Request addJsonBody body req = setRequestBodyJSON body $ setRequestMethod "PUT" req -- | Make an api call --- TODO(ks): Switch to @Either@. apiCall - :: forall m a. (MonadIO m, FromJSON a) + :: forall m a. (MonadIO m, MonadCatch m, FromJSON a) => (Value -> Parser a) -> Request -> m a -apiCall parser req = do - putTextLn $ show req - v <- getResponseBody <$> httpJSON req - case parseEither parser v of - Right o -> pure o - Left e -> error $ "couldn't parse response " - <> toText e <> "\n" <> decodeUtf8 (encode v) - --- | Make a safe api call. -apiCallSafe - :: forall m a. (MonadIO m, FromJSON a) - => (Value -> Parser a) - -> Request - -> m (Either String a) -apiCallSafe parser req = do - putTextLn $ show req - v <- getResponseBody <$> httpJSON req - pure $ parseEither parser v +apiCall parser request = do + -- putTextLn $ show req -- logging !?! + httpResult <- httpJSONEither request + + let httpResponseBody = getResponseBody httpResult + + httpResponse <- either + (throwM . HttpDecodingJSON request . show) + pure + httpResponseBody + + let httpStatusCode = getResponseStatusCode httpResult + + _ <- statusCodeToException request httpStatusCode + case parseEither parser httpResponse of + Left reason -> throwM $ HttpDecodingJSON request reason + Right value -> pure value diff --git a/src/Lib.hs b/src/Lib.hs index 04a68b4..752cd39 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -14,6 +14,9 @@ module Lib , listAndSortTickets , filterAnalyzedTickets , exportZendeskDataToLocalDB + -- * optional + , fetchTicket + , fetchTicketComments ) where import Universum @@ -354,6 +357,20 @@ fetchTickets = do -- Anything that has a "to_be_analysed" tag pure $ filter (elem (renderTicketStatus ToBeAnalyzed) . getTicketTags . tiTags) allTickets +-- | Fetch a single ticket if found. +fetchTicket :: TicketId -> App (Maybe TicketInfo) +fetchTicket ticketId = do + getTicketInfo <- asksDataLayer zlGetTicketInfo + getTicketInfo ticketId + + +-- | Fetch comments from a ticket, if the ticket is found. +fetchTicketComments :: TicketId -> App [Comment] +fetchTicketComments ticketId = do + getTicketComments <- asksDataLayer zlGetTicketComments + getTicketComments ticketId + + fetchAndShowTickets :: App () fetchAndShowTickets = do allTickets <- fetchTickets diff --git a/test/Spec.hs b/test/Spec.hs index 31a029b..ee95455 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,8 +3,8 @@ module Main where import Universum import Data.List (nub) -import Database.SQLite.Simple (Connection (..), NamedParam (..), queryNamed, - withConnection, query_) +import Database.SQLite.Simple (Connection (..), NamedParam (..), queryNamed, query_, + withConnection) import Test.Hspec (Spec, describe, hspec, it, pending, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) @@ -15,17 +15,19 @@ import Test.QuickCheck.Monadic (assert, monadicIO, pre, run) import Configuration (basicIOLayer, defaultConfig) import DataSource (App, Attachment (..), AttachmentId (..), Comment (..), CommentBody (..), CommentId (..), Config (..), DBLayerException (..), - DataLayer (..), DeletedTicket (..), ExportFromTime (..), IOLayer (..), - Ticket (..), TicketId (..), TicketInfo (..), TicketStatus (..), - TicketTag (..), TicketTags (..), TicketURL (..), User, UserId (..), - ZendeskAPIUrl (..), ZendeskResponse (..), createResponseTicket, + DataLayer (..), DeletedTicket (..), ExportFromTime (..), + HTTPNetworkLayer (..), IOLayer (..), Ticket (..), TicketId (..), + TicketInfo (..), TicketStatus (..), TicketTag (..), TicketTags (..), + TicketURL (..), User, UserId (..), ZendeskAPIUrl (..), + ZendeskResponse (..), basicDataLayer, createResponseTicket, createSchema, deleteAllData, emptyDBLayer, emptyDataLayer, insertCommentAttachments, insertTicketComments, insertTicketInfo, renderTicketStatus, runApp, showURL) import Exceptions (ProcessTicketExceptions (..)) +import HttpLayer (HttpNetworkLayerException (..), basicHTTPNetworkLayer) -import Lib (exportZendeskDataToLocalDB, filterAnalyzedTickets, getAttachmentsFromComment, - listAndSortTickets, processTicket) +import Lib (exportZendeskDataToLocalDB, fetchTicket, fetchTicketComments, filterAnalyzedTickets, + getAttachmentsFromComment, listAndSortTickets, processTicket) import Statistics (filterTicketsByStatus, filterTicketsWithAttachments, showAttachmentInfo, showCommentAttachments) @@ -34,6 +36,7 @@ import Statistics (filterTicketsByStatus, filterTicketsWithAttachments main :: IO () main = hspec spec +-- stack test --test-arguments "--seed=1425428185" -- stack test log-classifier --fast --test-arguments "-m Zendesk" spec :: Spec spec = @@ -56,6 +59,9 @@ spec = exportZendeskDataToLocalDBSpec getAttachmentsFromCommentSpec + describe "HttpNetworkLayer" $ do + parsingFailureSpec + describe "Database" $ do deleteAllDataSpec insertCommentAttachmentsSpec @@ -67,9 +73,9 @@ spec = withStubbedIOAndDataLayer :: DataLayer App -> Config withStubbedIOAndDataLayer stubbedDataLayer = defaultConfig - { cfgDataLayer = stubbedDataLayer - , cfgIOLayer = stubbedIOLayer - , cfgDBLayer = emptyDBLayer + { cfgDataLayer = stubbedDataLayer + , cfgIOLayer = stubbedIOLayer + , cfgDBLayer = emptyDBLayer } where stubbedIOLayer :: IOLayer App @@ -80,6 +86,87 @@ withStubbedIOAndDataLayer stubbedDataLayer = -- ^ Do nothing with the output } + +-- | A utility function for testing which stubs http network and returns +-- the @Config@ with the @DataLayer@ and @HttpNetworkLayer@ that was passed into it. +withStubbedNetworkAndDataLayer :: HTTPNetworkLayer -> Config +withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer = + defaultConfig + { cfgDataLayer = basicDataLayer + , cfgIOLayer = stubbedIOLayer + , cfgDBLayer = emptyDBLayer + , cfgHTTPNetworkLayer = stubbedHttpNetworkLayer + } + where + stubbedIOLayer :: IOLayer App + stubbedIOLayer = + basicIOLayer + { iolPrintText = \_ -> pure () + , iolAppendFile = \_ _ -> pure () + -- ^ Do nothing with the output + } + + +-- | Generate a @HttpNotFound@ so we can test when a ticket can't be found. +generateHttpNotFoundExceptions :: Gen HttpNetworkLayerException +generateHttpNotFoundExceptions = HttpNotFound <$> arbitrary + + +parsingFailureSpec :: Spec +parsingFailureSpec = + describe "parsingFailureSpec " $ modifyMaxSuccess (const 1000) $ do + it "should return Nothing when parsing fails at getTicketInfo" $ do + forAll arbitrary $ \ticketId -> + forAll generateHttpNotFoundExceptions $ \exception -> + monadicIO $ do + + -- we exclusivly want just @HttpNotFound@, others are rethrown. + pre $ case exception of + HttpNotFound _ -> True + _ -> False + + let stubbedHttpNetworkLayer :: HTTPNetworkLayer + stubbedHttpNetworkLayer = + basicHTTPNetworkLayer + { hnlApiCall = \_ _ -> throwM exception + } + + let stubbedConfig :: Config + stubbedConfig = withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer + + let appExecution :: IO (Maybe TicketInfo) + appExecution = runApp (fetchTicket ticketId) stubbedConfig + + ticket <- run appExecution + + -- Check we don't have any tickets, since they would all raise a parsing exception. + assert . isNothing $ ticket + + it "should return empty when parsing fails at getTicketComments" $ do + forAll arbitrary $ \ticketId -> + forAll generateHttpNotFoundExceptions $ \exception -> + + monadicIO $ do + + let stubbedHttpNetworkLayer :: HTTPNetworkLayer + stubbedHttpNetworkLayer = + basicHTTPNetworkLayer + { hnlApiCall = \_ _ -> throwM exception + } + + let stubbedConfig :: Config + stubbedConfig = withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer + + -- TODO(ks): There is an indication that we need to propage this exception. + let appExecution :: IO [Comment] + appExecution = runApp (fetchTicketComments ticketId) stubbedConfig + + comments <- run appExecution + + -- Check we don't have any comments. + assert . null $ comments + + listAndSortTicketsSpec :: Spec listAndSortTicketsSpec = describe "listAndSortTickets" $ modifyMaxSuccess (const 200) $ do @@ -660,7 +747,7 @@ deleteAllDataSpec = describe "deleteAllData" $ modifyMaxSuccess (const 200) $ do prop "should delete all datas from database" $ monadicIO $ do - (tickets, ticketComments, commentAttachments, attachmentContents) <- + (tickets, ticketComments, commentAttachments, attachmentContents) <- run . withDBSchema ":memory:" $ \conn -> do deleteAllData conn tickets <- query_ conn "SELECT * from ticket_info" @@ -694,7 +781,7 @@ insertCommentAttachmentsSpec = return (dbAttachments :: [DBCommentAttachment]) assert . isJust . safeHead $ dbAttachments - whenJust (safeHead dbAttachments) $ + whenJust (safeHead dbAttachments) $ \(attachmentId, commentId, attUrl, attContentType, attSize) -> do assert $ attachmentId == aId attachment assert $ commentId == cId comment @@ -706,7 +793,7 @@ insertCommentAttachmentsSpec = \(comment :: Comment) (attachment :: Attachment) -> monadicIO $ do eResult <- run . try $ - withConnection ":memory:" $ \conn + withConnection ":memory:" $ \conn -> insertCommentAttachments conn comment attachment assert $ isLeft (eResult :: Either DBLayerException ())