From 3b5d938cc33237863618ef7028f7b982f107c263 Mon Sep 17 00:00:00 2001
From: Tristan Cacqueray <tdecacqu@redhat.com>
Date: Tue, 19 Sep 2023 18:02:49 +0000
Subject: [PATCH] Handle Authentication Error

This change avoids retrying requests that fail with a 401 error.
---
 src/Lentille/GitHub/RateLimit.hs |  8 ++++++-
 src/Lentille/GraphQL.hs          | 16 +++++++-------
 src/Macroscope/Worker.hs         | 38 ++++++++++++++++++++++++++++++--
 3 files changed, 51 insertions(+), 11 deletions(-)

diff --git a/src/Lentille/GitHub/RateLimit.hs b/src/Lentille/GitHub/RateLimit.hs
index bae6a0191..c78c300ef 100644
--- a/src/Lentille/GitHub/RateLimit.hs
+++ b/src/Lentille/GitHub/RateLimit.hs
@@ -10,7 +10,7 @@ import Lentille.GitHub.Types
 import Lentille.GraphQL
 import Monocle.Prelude
 import Network.HTTP.Client (responseBody, responseStatus)
-import Network.HTTP.Types (Status, badGateway502, forbidden403, ok200)
+import Network.HTTP.Types (Status, badGateway502, forbidden403, ok200, unauthorized401)
 
 import Effectful.Retry
 
@@ -57,6 +57,9 @@ retryCheck = \case
     | isRepoNotFound status body -> do
         logWarn_ "Repository not found. Will not retry."
         pure DontRetry
+    | isAuthError status -> do
+        logWarn "Authentication error"  ["body" .= body]
+        pure DontRetry
     | otherwise -> do
         logWarn "Unexpected error" ["err" .= show @Text err]
         pure ConsultPolicy
@@ -64,6 +67,9 @@ retryCheck = \case
     status = responseStatus resp
     body = decodeUtf8 $ responseBody resp
  where
+  isAuthError :: Status -> Bool
+  isAuthError status = status == unauthorized401
+
   isTimeoutError :: Status -> Text -> Bool
   isTimeoutError status body =
     let msg = "Something went wrong while executing your query. This may be the result of a timeout"
diff --git a/src/Lentille/GraphQL.hs b/src/Lentille/GraphQL.hs
index 95a30c38c..547e8c44d 100644
--- a/src/Lentille/GraphQL.hs
+++ b/src/Lentille/GraphQL.hs
@@ -144,7 +144,7 @@ doRequest ::
 doRequest client mkArgs retryCheck depthM pageInfoM =
   retryingDynamic policy (const retryCheck) $ \rs -> do
     when (rs.rsIterNumber > 0)
-      $ logWarn "Faulty response" ["num" .= rs.rsIterNumber]
+      $ logWarn "Retrying request" ["num" .= rs.rsIterNumber]
     runFetch rs.rsIterNumber
  where
   delay = 1_100_000 -- 1.1 seconds
@@ -209,8 +209,8 @@ streamFetch client@GraphClient {..} mkArgs StreamFetchOptParams {..} transformRe
 
   requestWithPageInfo pageInfoM storedRateLimitM = do
     holdOnIfNeeded storedRateLimitM
-    respE <- doRequest client mkArgs fpRetryCheck fpDepth pageInfoM
-    pure $ case respE of
+    eResp <- doRequest client mkArgs fpRetryCheck fpDepth pageInfoM
+    pure $ case eResp of
       Left err -> Left err
       Right resp ->
         let (pageInfo, rateLimitM, decodingErrors, xs) = transformResponse resp
@@ -225,19 +225,19 @@ streamFetch client@GraphClient {..} mkArgs StreamFetchOptParams {..} transformRe
 
   startFetch = do
     --- Perform a pre GraphQL request to gather rateLimit
-    fpRespE <- case fpGetRatelimit of
+    (mErr :: Maybe GraphQLError) <- case fpGetRatelimit of
       Just getRateLimit -> lift
         $ E.modifyMVar rateLimitMVar
         $ const do
-          rlE <- getRateLimit client
-          case rlE of
+          eRateLimit <- getRateLimit client
+          case eRateLimit of
             Left err -> do
               logWarn_ "Could not fetch the current rate limit"
               pure (Nothing, Just err)
-            Right rl -> pure (rl, Nothing)
+            Right rateLimit -> pure (rateLimit, Nothing)
       Nothing -> pure Nothing
 
-    case fpRespE of
+    case mErr of
       Just err -> S.yield (Left $ GraphError err)
       Nothing -> go Nothing 0
 
diff --git a/src/Macroscope/Worker.hs b/src/Macroscope/Worker.hs
index e9be76b52..421cf52c3 100644
--- a/src/Macroscope/Worker.hs
+++ b/src/Macroscope/Worker.hs
@@ -293,8 +293,8 @@ getStreamOldestEntity indexName crawlerName entityType offset = do
 -- | Remove the left part of the stream and throw an error when they occurs.
 -- The error contains the first left encountered, and the rest of the stream.
 eitherStreamToError ::
-  Stream (Of (Either err a)) (Eff es) () ->
-  Stream (Of a) (Eff (Error (err, Stream (Of (Either err a)) (Eff es) ()) : es)) ()
+  Stream (Of (Either LentilleError DocumentType)) (Eff es) () ->
+  Stream (Of DocumentType) (Eff (Error (StreamError es) : es)) ()
 eitherStreamToError stream = do
   nextE <- hoist E.raise (lift (S.next stream))
   case nextE of
@@ -307,3 +307,37 @@ eitherStreamToError stream = do
         Right v -> do
           S.yield v
           eitherStreamToError xs
+
+{-
+-- | A printf test for eitherStreamToError
+testStreamError :: IO ()
+testStreamError = runEff do
+  print "starting..."
+  res <- runErrorNoCallStack (doTest fakeStream)
+  case res of
+    Left (x, _) -> print x
+    _ -> pure ()
+
+  res <- runErrorNoCallStack (doTest fakeStream)
+  case res of
+    Left (x, _) -> print x
+    _ -> pure ()
+
+
+  where
+    fakeAdd _xs = do
+      print "Adding"
+      pure (AddDocResponse Nothing)
+
+    -- doTest :: IOE :> es => Eff (Error (StreamError es) : es) ()
+    doTest s = do
+      xs <- process (\_ -> pure ()) fakeAdd (eitherStreamToError s)
+      print "Commiting!"
+
+    fakeStream :: Stream (Of (Either LentilleError DocumentType)) (Eff es) ()
+    fakeStream = do
+      S.yield (Right (DTProject (CrawlerPB.Project "project-name")))
+      S.yield (Left (DecodeError ["Oop"]))
+      S.yield (Right (DTProject (CrawlerPB.Project "project-name")))
+      pure ()
+-}