[TSD-85] Added basic tests, missing tests on other calls on DataLayer.

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

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

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
 ------------------------------------------------------------

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.

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
 

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