[haskell] Prevent que networking code from triggering the API rate limiting

2 files changed, 18 insertions, 8 deletions

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
diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs
index feeb54b..5c70a1d 100644
--- a/haskell/src/SpaceTraders/Automation/Init.hs
+++ b/haskell/src/SpaceTraders/Automation/Init.hs
@@ -30,7 +30,7 @@ initST :: IO Env
 initST = do
   conn <- open
   t <- runReaderT getToken conn `catch` handleNoToken conn
-  let env = Env conn (tokenReq t)
+  env <- newEnv conn (tokenReq t)
   ma <- runReaderT getAgent conn -- We compare the agent state in the database
   ma' <- runSpaceTradersT myAgent env -- with the one on the servers
   case ma' of
@@ -44,7 +44,7 @@ initST = do
       return $ env
   where
     handleNoToken :: S.Connection -> SomeException -> IO T.Text
-    handleNoToken conn _ = runReaderT registerST (Env conn defaultReq)
+    handleNoToken conn _ = newEnv conn defaultReq >>= runReaderT registerST
 
 registerST :: SpaceTradersT (T.Text)
 registerST = do
@@ -64,5 +64,5 @@ wipe c = do
       close c
       removeFile "spacetraders.db"
       conn' <- open
-      t <- runReaderT registerST (Env conn' defaultReq)
-      return $ Env conn' (tokenReq t)
+      t <- newEnv conn' defaultReq >>= runReaderT registerST
+      newEnv conn' (tokenReq t)