From d1f0faf30f5b5d05ae9f5eda36de8f9cffcade2d Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Sat, 22 Jul 2023 00:10:02 +0200
Subject: [haskell] Prevent que networking code from triggering the API rate
 limiting

---
 haskell/src/SpaceTraders/APIClient/Client.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

(limited to 'haskell/src/SpaceTraders/APIClient/Client.hs')

diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index 1ca03ee..5c2aa66 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -11,9 +11,11 @@ module SpaceTraders.APIClient.Client
   , tokenReq
   ) where
 
-import Control.Concurrent
+import Control.Concurrent.Thread.Delay
+import Control.Monad
 import Control.Monad.Reader
 import Data.Aeson
+import Data.IORef
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Network.HTTP.Simple
@@ -62,9 +64,17 @@ sendPaginated pagination requestBuilder = do
         Nothing -> request
   sendPaginated' request'
   where
-    sendPaginated' :: (FromJSON a, MonadIO m) => Request -> m (APIPaginatedResponse a)
+    sendPaginated' :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Request -> m (APIPaginatedResponse a)
     sendPaginated' request = do
-      response <- liftIO $ httpLbs request
+      env <- ask
+      let iref = getLastAPICall env
+      response <- liftIO $ do
+        now <- microSinceEpoch
+        prev <- readIORef iref
+        let diff = prev + 400_000 - now
+        when (diff > 0) (delay diff)
+        writeIORef iref now
+        httpLbs request
       let status = statusCode $ getResponseStatus response
           body = getResponseBody response
       if status >= 200 && status <= 299
@@ -74,6 +84,6 @@ sendPaginated pagination requestBuilder = do
         else case eitherDecode body of
           Left e -> return . Left $ APIError (-status) (T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body]) Null
           Right (APIRateLimit r) -> do
-            liftIO $ threadDelay (1_000_000 * (round $ retryAfter r))
+            liftIO $ delay (1_000_000 * (round $ retryAfter r))
             sendPaginated' request
           Right e -> return $ Left e
-- 
cgit v1.2.3