From a6b184eb5908e02bbee0a419f61f55e8ccaeb485 Mon Sep 17 00:00:00 2001 From: ksaric Date: Tue, 28 Aug 2018 15:15:04 +0200 Subject: [PATCH 1/5] [TSD-85] Added basic tests, missing tests on other calls on DataLayer. --- log-classifier.cabal | 2 +- src/DataSource/DB.hs | 6 +-- src/DataSource/Http.hs | 25 +++++----- src/DataSource/Types.hs | 7 +-- src/HttpLayer.hs | 42 ++++++++--------- src/Lib.hs | 17 +++++++ test/Spec.hs | 100 ++++++++++++++++++++++++++++++++++------ 7 files changed, 141 insertions(+), 58 deletions(-) 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..23c31db 100644 --- a/src/DataSource/Http.hs +++ b/src/DataSource/Http.hs @@ -39,7 +39,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 +74,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 @@ -84,8 +84,9 @@ getTicketInfo ticketId = do let req = apiRequest cfg url apiCall <- asksHTTPNetworkLayer hnlApiCall + result <- tryAny $ apiCall parseTicket req - Just <$> apiCall parseTicket req + pure $ either (const Nothing) Just result -- | Return list of deleted tickets. listDeletedTickets @@ -151,7 +152,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 +194,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 +232,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 @@ -255,24 +256,20 @@ getAttachment Attachment{..} = Just . AttachmentContent . getResponseBody <$> ht -- | Get ticket's comments getTicketComments - :: (MonadIO m, MonadReader Config m) + :: (MonadIO m, MonadCatch m, MonadReader Config m) => TicketId -> m [Comment] getTicketComments tId = do cfg <- ask - apiCallSafe <- asksHTTPNetworkLayer hnlApiCallSafe + apiCall <- asksHTTPNetworkLayer hnlApiCall let url = showURL $ TicketCommentsURL tId let req = apiRequest cfg url - result <- apiCallSafe parseComments req + result <- tryAny $ apiCall 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 + pure $ either (const []) id result ------------------------------------------------------------ -- 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..9a509e5 100644 --- a/src/HttpLayer.hs +++ b/src/HttpLayer.hs @@ -1,5 +1,6 @@ module HttpLayer ( HTTPNetworkLayer (..) + , HttpNetworkLayerException (..) , basicHTTPNetworkLayer , emptyHTTPNetworkLayer , apiRequest @@ -8,7 +9,7 @@ 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, @@ -25,16 +26,24 @@ 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 + = CannotParseResult String -- Request + deriving (Show) + +instance Exception HttpNetworkLayerException + ------------------------------------------------------------ -- Functions ------------------------------------------------------------ @@ -64,29 +73,16 @@ 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 !?! + httpResponse <- getResponseBody <$> httpJSON request + case parseEither parser httpResponse of + Left reason -> throwM $ CannotParseResult 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..ffe6bcf 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) @@ -56,6 +58,9 @@ spec = exportZendeskDataToLocalDBSpec getAttachmentsFromCommentSpec + describe "HttpNetworkLayer" $ do + parsingFailureSpec + describe "Database" $ do deleteAllDataSpec insertCommentAttachmentsSpec @@ -67,9 +72,29 @@ spec = withStubbedIOAndDataLayer :: DataLayer App -> Config withStubbedIOAndDataLayer stubbedDataLayer = defaultConfig - { cfgDataLayer = stubbedDataLayer - , cfgIOLayer = stubbedIOLayer - , cfgDBLayer = emptyDBLayer + { cfgDataLayer = stubbedDataLayer + , cfgIOLayer = stubbedIOLayer + , cfgDBLayer = emptyDBLayer + } + where + stubbedIOLayer :: IOLayer App + stubbedIOLayer = + basicIOLayer + { iolPrintText = \_ -> pure () + , iolAppendFile = \_ _ -> pure () + -- ^ 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 @@ -80,6 +105,53 @@ withStubbedIOAndDataLayer stubbedDataLayer = -- ^ Do nothing with the output } + +parsingFailureSpec :: Spec +parsingFailureSpec = + describe "parsingFailureSpec " $ modifyMaxSuccess (const 1000) $ do + it "should return Nothing when parsing fails at getTicketInfo" $ do + forAll arbitrary $ \ticketId -> + monadicIO $ do + + let stubbedHttpNetworkLayer :: HTTPNetworkLayer + stubbedHttpNetworkLayer = + basicHTTPNetworkLayer + { hnlApiCall = \_ _ -> throwM $ CannotParseResult "error parsing" + } + + 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 -> + monadicIO $ do + + let stubbedHttpNetworkLayer :: HTTPNetworkLayer + stubbedHttpNetworkLayer = + basicHTTPNetworkLayer + { hnlApiCall = \_ _ -> throwM $ CannotParseResult "error parsing" + } + + 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 +732,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 +766,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 +778,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 ()) From 7456074512f820332fcf2adbb0907912167500b2 Mon Sep 17 00:00:00 2001 From: ksaric Date: Wed, 29 Aug 2018 08:49:55 +0200 Subject: [PATCH 2/5] [TSD-85] Added more exceptions to track, arbitrary exception tests. --- src/HttpLayer.hs | 22 ++++++++++++++++------ test/Spec.hs | 10 ++++++---- 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/src/HttpLayer.hs b/src/HttpLayer.hs index 9a509e5..df4b287 100644 --- a/src/HttpLayer.hs +++ b/src/HttpLayer.hs @@ -11,12 +11,13 @@ import Universum 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 (JSONException, Request, addRequestHeader, getResponseBody, + httpJSON, httpJSONEither, parseRequest_, setRequestBasicAuth, + setRequestBodyJSON, setRequestMethod, setRequestPath) import DataSource.Types (Config (..), HTTPNetworkLayer (..)) +import Test.QuickCheck (Arbitrary (..), oneof) ------------------------------------------------------------ -- Layer @@ -39,11 +40,18 @@ emptyHTTPNetworkLayer = HTTPNetworkLayer ------------------------------------------------------------ data HttpNetworkLayerException - = CannotParseResult String -- Request + = JSONDecodingException String -- JSONException + | HttpCannotParseJSON String -- Request deriving (Show) instance Exception HttpNetworkLayerException +instance Arbitrary HttpNetworkLayerException where + arbitrary = oneof + [ JSONDecodingException <$> arbitrary + , HttpCannotParseJSON <$> arbitrary + ] + ------------------------------------------------------------ -- Functions ------------------------------------------------------------ @@ -80,9 +88,11 @@ apiCall -> m a apiCall parser request = do -- putTextLn $ show req -- logging !?! - httpResponse <- getResponseBody <$> httpJSON request + httpResult <- getResponseBody <$> httpJSONEither request + + httpResponse <- either (throwM . JSONDecodingException . show) pure httpResult case parseEither parser httpResponse of - Left reason -> throwM $ CannotParseResult reason + Left reason -> throwM $ HttpCannotParseJSON reason Right value -> pure value diff --git a/test/Spec.hs b/test/Spec.hs index ffe6bcf..3b2f949 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,6 +25,7 @@ import DataSource (App, Attachment (..), AttachmentId (..), Comment (. renderTicketStatus, runApp, showURL) import Exceptions (ProcessTicketExceptions (..)) import HttpLayer (HttpNetworkLayerException (..), basicHTTPNetworkLayer) +import Network.HTTP.Simple (JSONException) import Lib (exportZendeskDataToLocalDB, fetchTicket, fetchTicketComments, filterAnalyzedTickets, getAttachmentsFromComment, listAndSortTickets, processTicket) @@ -110,13 +111,13 @@ parsingFailureSpec :: Spec parsingFailureSpec = describe "parsingFailureSpec " $ modifyMaxSuccess (const 1000) $ do it "should return Nothing when parsing fails at getTicketInfo" $ do - forAll arbitrary $ \ticketId -> + forAll arbitrary $ \(ticketId, exception :: HttpNetworkLayerException) -> monadicIO $ do let stubbedHttpNetworkLayer :: HTTPNetworkLayer stubbedHttpNetworkLayer = basicHTTPNetworkLayer - { hnlApiCall = \_ _ -> throwM $ CannotParseResult "error parsing" + { hnlApiCall = \_ _ -> throwM exception } let stubbedConfig :: Config @@ -131,13 +132,13 @@ parsingFailureSpec = assert . isNothing $ ticket it "should return empty when parsing fails at getTicketComments" $ do - forAll arbitrary $ \ticketId -> + forAll arbitrary $ \(ticketId, exception :: HttpNetworkLayerException) -> monadicIO $ do let stubbedHttpNetworkLayer :: HTTPNetworkLayer stubbedHttpNetworkLayer = basicHTTPNetworkLayer - { hnlApiCall = \_ _ -> throwM $ CannotParseResult "error parsing" + { hnlApiCall = \_ _ -> throwM exception } let stubbedConfig :: Config @@ -152,6 +153,7 @@ parsingFailureSpec = -- Check we don't have any comments. assert . null $ comments + listAndSortTicketsSpec :: Spec listAndSortTicketsSpec = describe "listAndSortTickets" $ modifyMaxSuccess (const 200) $ do From c95e1d31745b08f48ee6528bc2217776ffa25655 Mon Sep 17 00:00:00 2001 From: ksaric Date: Wed, 29 Aug 2018 11:33:13 +0200 Subject: [PATCH 3/5] [TSD-85] Added http status exceptions, now we can track different exceptions from this layer. --- src/HttpLayer.hs | 73 +++++++++++++++++++++++++++++++++++++++++------- test/Spec.hs | 1 - 2 files changed, 63 insertions(+), 11 deletions(-) diff --git a/src/HttpLayer.hs b/src/HttpLayer.hs index df4b287..0118a16 100644 --- a/src/HttpLayer.hs +++ b/src/HttpLayer.hs @@ -11,9 +11,10 @@ import Universum import Data.Aeson (FromJSON, ToJSON, Value) import Data.Aeson.Types (Parser, parseEither) -import Network.HTTP.Simple (JSONException, Request, addRequestHeader, getResponseBody, - httpJSON, httpJSONEither, 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 (..)) @@ -40,16 +41,61 @@ emptyHTTPNetworkLayer = HTTPNetworkLayer ------------------------------------------------------------ data HttpNetworkLayerException - = JSONDecodingException String -- JSONException - | HttpCannotParseJSON String -- Request + = 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 - [ JSONDecodingException <$> arbitrary - , HttpCannotParseJSON <$> arbitrary + [ HttpDecodingJSON <$> arbitrary <*> arbitrary + + , HttpBadRequest <$> arbitrary + , HttpUnauthorized <$> arbitrary + , HttpForbidden <$> arbitrary + , HttpNotFound <$> arbitrary + , HttpMethodNotAllowed <$> arbitrary + , HttpUnsupportedMediaType <$> arbitrary + , HttpTooManyRequests <$> arbitrary + + , HttpInternalServerError <$> arbitrary + , HttpNotImplemented <$> arbitrary + , HttpServiceUnavailable <$> arbitrary ] ------------------------------------------------------------ @@ -88,11 +134,18 @@ apiCall -> m a apiCall parser request = do -- putTextLn $ show req -- logging !?! - httpResult <- getResponseBody <$> httpJSONEither request + httpResult <- httpJSONEither request + + httpResponse <- either + (throwM . HttpDecodingJSON request . show) + pure + (getResponseBody httpResult) + + let httpStatusCode = getResponseStatusCode httpResult - httpResponse <- either (throwM . JSONDecodingException . show) pure httpResult + _ <- statusCodeToException request httpStatusCode case parseEither parser httpResponse of - Left reason -> throwM $ HttpCannotParseJSON reason + Left reason -> throwM $ HttpDecodingJSON request reason Right value -> pure value diff --git a/test/Spec.hs b/test/Spec.hs index 3b2f949..7c77a4a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,7 +25,6 @@ import DataSource (App, Attachment (..), AttachmentId (..), Comment (. renderTicketStatus, runApp, showURL) import Exceptions (ProcessTicketExceptions (..)) import HttpLayer (HttpNetworkLayerException (..), basicHTTPNetworkLayer) -import Network.HTTP.Simple (JSONException) import Lib (exportZendeskDataToLocalDB, fetchTicket, fetchTicketComments, filterAnalyzedTickets, getAttachmentsFromComment, listAndSortTickets, processTicket) From 66248b0b17a9feb5c8cc245281dc4551494fe87e Mon Sep 17 00:00:00 2001 From: ksaric Date: Thu, 30 Aug 2018 14:44:02 +0200 Subject: [PATCH 4/5] [TSD-85] Fixed catching a single type of exception that is acceptable, rethrow others. --- src/DataSource/Http.hs | 20 +++++++++++++++++--- src/HttpLayer.hs | 7 ++++--- test/Spec.hs | 40 ++++++++++++++++++++++++++-------------- 3 files changed, 47 insertions(+), 20 deletions(-) diff --git a/src/DataSource/Http.hs b/src/DataSource/Http.hs index 23c31db..2bf234e 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 (..), @@ -84,9 +85,22 @@ getTicketInfo ticketId = do let req = apiRequest cfg url apiCall <- asksHTTPNetworkLayer hnlApiCall - result <- tryAny $ apiCall parseTicket req - pure $ either (const Nothing) Just result + result <- try $ apiCall parseTicket req + + notFoundExceptionToMaybe result + where + -- | We want only @HttpNotFound@ to return @Nothing@, otherwise + -- propagate the exception. + notFoundExceptionToMaybe + :: forall m. (MonadCatch m) + => Either HttpNetworkLayerException TicketInfo + -> m (Maybe TicketInfo) + notFoundExceptionToMaybe result = case result of + Left exception -> case exception of + HttpNotFound _ -> pure Nothing + otherExceptions -> throwM otherExceptions + Right ticketInfo -> pure $ Just ticketInfo -- | Return list of deleted tickets. listDeletedTickets diff --git a/src/HttpLayer.hs b/src/HttpLayer.hs index 0118a16..8f04125 100644 --- a/src/HttpLayer.hs +++ b/src/HttpLayer.hs @@ -56,7 +56,6 @@ data HttpNetworkLayerException | HttpServiceUnavailable Request deriving (Show) - -- | The way to convert the status codes to exceptions. statusCodeToException :: forall m. (MonadThrow m) => Request -> Int -> m () statusCodeToException request = \case @@ -136,12 +135,14 @@ apiCall parser request = do -- putTextLn $ show req -- logging !?! httpResult <- httpJSONEither request + let httpResponseBody = getResponseBody httpResult + httpResponse <- either (throwM . HttpDecodingJSON request . show) pure - (getResponseBody httpResult) + httpResponseBody - let httpStatusCode = getResponseStatusCode httpResult + let httpStatusCode = getResponseStatusCode httpResult _ <- statusCodeToException request httpStatusCode diff --git a/test/Spec.hs b/test/Spec.hs index 7c77a4a..cc028f5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -36,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 = @@ -106,29 +107,40 @@ withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer = } +-- | 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, exception :: HttpNetworkLayerException) -> - monadicIO $ do + forAll arbitrary $ \ticketId -> + forAll generateHttpNotFoundExceptions $ \exception -> + monadicIO $ do - let stubbedHttpNetworkLayer :: HTTPNetworkLayer - stubbedHttpNetworkLayer = - basicHTTPNetworkLayer - { hnlApiCall = \_ _ -> throwM exception - } + -- we exclusivly want just @HttpNotFound@, others are rethrown. + pre $ case exception of + HttpNotFound _ -> True + _ -> False - let stubbedConfig :: Config - stubbedConfig = withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer + let stubbedHttpNetworkLayer :: HTTPNetworkLayer + stubbedHttpNetworkLayer = + basicHTTPNetworkLayer + { hnlApiCall = \_ _ -> throwM exception + } + + let stubbedConfig :: Config + stubbedConfig = withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer - let appExecution :: IO (Maybe TicketInfo) - appExecution = runApp (fetchTicket ticketId) stubbedConfig + let appExecution :: IO (Maybe TicketInfo) + appExecution = runApp (fetchTicket ticketId) stubbedConfig - ticket <- run appExecution + ticket <- run appExecution - -- Check we don't have any tickets, since they would all raise a parsing exception. - assert . isNothing $ ticket + -- 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, exception :: HttpNetworkLayerException) -> From 0d1a274dd95045009385cb5283d9c85c7995abae Mon Sep 17 00:00:00 2001 From: ksaric Date: Thu, 30 Aug 2018 15:10:11 +0200 Subject: [PATCH 5/5] [TSD-85] Fixed getTicketComments function to return an empty list if the ticket cannot be found. --- src/DataSource/Http.hs | 56 +++++++++++++++++++++++++++--------------- test/Spec.hs | 32 +++++++++++++----------- 2 files changed, 53 insertions(+), 35 deletions(-) diff --git a/src/DataSource/Http.hs b/src/DataSource/Http.hs index 2bf234e..6ac5599 100644 --- a/src/DataSource/Http.hs +++ b/src/DataSource/Http.hs @@ -93,15 +93,48 @@ getTicketInfo ticketId = do -- | We want only @HttpNotFound@ to return @Nothing@, otherwise -- propagate the exception. notFoundExceptionToMaybe - :: forall m. (MonadCatch m) - => Either HttpNetworkLayerException TicketInfo - -> m (Maybe TicketInfo) + :: 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 :: forall m. (MonadIO m, MonadReader Config m) @@ -268,23 +301,6 @@ getAttachment Attachment{..} = Just . AttachmentContent . getResponseBody <$> ht req :: Request req = parseRequest_ (toString aURL) --- | Get ticket's comments -getTicketComments - :: (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 <- tryAny $ apiCall parseComments req - - pure $ either (const []) id result - ------------------------------------------------------------ -- Utility ------------------------------------------------------------ diff --git a/test/Spec.hs b/test/Spec.hs index cc028f5..ee95455 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -143,26 +143,28 @@ parsingFailureSpec = assert . isNothing $ ticket it "should return empty when parsing fails at getTicketComments" $ do - forAll arbitrary $ \(ticketId, exception :: HttpNetworkLayerException) -> - monadicIO $ do + forAll arbitrary $ \ticketId -> + forAll generateHttpNotFoundExceptions $ \exception -> - let stubbedHttpNetworkLayer :: HTTPNetworkLayer - stubbedHttpNetworkLayer = - basicHTTPNetworkLayer - { hnlApiCall = \_ _ -> throwM exception - } + monadicIO $ do - let stubbedConfig :: Config - stubbedConfig = withStubbedNetworkAndDataLayer stubbedHttpNetworkLayer + 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 + -- 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 + comments <- run appExecution - -- Check we don't have any comments. - assert . null $ comments + -- Check we don't have any comments. + assert . null $ comments listAndSortTicketsSpec :: Spec