From c18318de560134ad94d1cd21e3dd8091b8aba36f Mon Sep 17 00:00:00 2001
From: Chris Allen <cma@bitemyapp.com>
Date: Sat, 5 May 2018 15:54:27 -0500
Subject: [PATCH] Made EsProtocolException more helpful

---
 src/Bloodhound/Import.hs                      |  3 ++
 src/Database/V5/Bloodhound/Client.hs          | 36 ++++++++++---------
 src/Database/V5/Bloodhound/Internal/Client.hs |  5 +--
 3 files changed, 26 insertions(+), 18 deletions(-)

diff --git a/src/Bloodhound/Import.hs b/src/Bloodhound/Import.hs
index cee26d2..4af8fb7 100644
--- a/src/Bloodhound/Import.hs
+++ b/src/Bloodhound/Import.hs
@@ -79,3 +79,6 @@ deleteSeveral ks hm = foldr HM.delete hm ks
 oPath :: ToJSON a => NonEmpty Text -> a -> Value
 oPath (k :| []) v   = object [k .= v]
 oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
diff --git a/src/Database/V5/Bloodhound/Client.hs b/src/Database/V5/Bloodhound/Client.hs
index 3a1994e..1613f8e 100644
--- a/src/Database/V5/Bloodhound/Client.hs
+++ b/src/Database/V5/Bloodhound/Client.hs
@@ -639,19 +639,24 @@ existentialQuery url = do
 -- categories. If they don't, a 'EsProtocolException' will be
 -- thrown. If you encounter this, please report the full body it
 -- reports along with your Elasticsearch verison.
-parseEsResponse :: (MonadThrow m, FromJSON a) => Reply
+parseEsResponse :: ( MonadThrow m
+                   , FromJSON a
+                   )
+                => Reply
                 -> m (Either EsError a)
 parseEsResponse reply
   | respIsTwoHunna reply = case eitherDecode body of
                              Right a -> return (Right a)
-                             Left _ -> tryParseError
-  | otherwise = tryParseError
+                             Left err ->
+                               tryParseError err
+  | otherwise = tryParseError "Non-200 status code"
   where body = responseBody reply
-        tryParseError = case eitherDecode body of
-                          Right e -> return (Left e)
-                          -- this case should not be possible
-                          Left _ -> explode
-        explode = throwM (EsProtocolException body)
+        tryParseError originalError
+          = case eitherDecode body of
+              Right e -> return (Left e)
+              -- Failed to parse the error message.
+              Left err -> explode ("Original error was: " <> originalError <> " Error parse failure was: " <> err)
+        explode errorMsg = throwM (EsProtocolException (T.pack errorMsg) body)
 
 -- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
 --   in IO
@@ -711,16 +716,15 @@ listIndices =
   parse . responseBody =<< get =<< url
   where
     url = joinPath ["_cat/indices?format=json"]
-    parse body = maybe (throwM (EsProtocolException body)) return $ do
-      vals <- decode body
+    parse body = either (\msg -> (throwM (EsProtocolException (T.pack msg) body))) return $ do
+      vals <- eitherDecode body
       forM vals $ \val ->
         case val of
-          Object obj -> do
-            indexVal <- HM.lookup "index" obj
-            case indexVal of
-              String txt -> Just (IndexName txt)
-              _ -> Nothing
-          _ -> Nothing
+          Object obj ->
+            case HM.lookup "index" obj of
+              (Just (String txt)) -> Right (IndexName txt)
+              v -> Left $ "indexVal in listIndices failed on non-string, was: " <> show v
+          v -> Left $ "One of the values parsed in listIndices wasn't an object, it was: " <> show v
 
 -- | 'updateIndexAliases' updates the server's index alias
 -- table. Operations are atomic. Explained in further detail at
diff --git a/src/Database/V5/Bloodhound/Internal/Client.hs b/src/Database/V5/Bloodhound/Internal/Client.hs
index 0e955b7..cf58403 100644
--- a/src/Database/V5/Bloodhound/Internal/Client.hs
+++ b/src/Database/V5/Bloodhound/Internal/Client.hs
@@ -693,8 +693,9 @@ sure that your mappings are correct, then this error may be an indication of an
 incompatibility between Bloodhound and Elasticsearch. Please open a bug report
 and be sure to include the exception body.
 -}
-newtype EsProtocolException = EsProtocolException
-  { esProtoExBody :: LByteString
+data EsProtocolException = EsProtocolException
+  { esProtoExMessage :: !Text
+  , esProtoExBody :: !LByteString
   } deriving (Eq, Show)
 
 instance Exception EsProtocolException