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

4 files changed, 39 insertions, 8 deletions

diff --git a/haskell/package.yaml b/haskell/package.yaml
index 5f62014..ed81dbd 100644
--- a/haskell/package.yaml
+++ b/haskell/package.yaml
@@ -27,6 +27,7 @@ dependencies:
 - sqlite-simple
 - text
 - time
+- unbounded-delays
 - unix
 
 ghc-options:
diff --git a/haskell/src/SpaceTraders.hs b/haskell/src/SpaceTraders.hs
index 2a531fe..5bd7526 100644
--- a/haskell/src/SpaceTraders.hs
+++ b/haskell/src/SpaceTraders.hs
@@ -1,28 +1,46 @@
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders
   ( SpaceTradersT
+  , microSinceEpoch
+  , newEnv
   , runSpaceTradersT
   , Env(..)
   , HasDatabaseConn
   , HasRequest
   , ask
   , getConn
+  , getLastAPICall
   , getRequest
   , liftIO
   ) where
 
 import Control.Monad.IO.Class
 import Control.Monad.Reader
+import Data.IORef
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import qualified Database.SQLite.Simple as S
 import Network.HTTP.Simple
 
 type SpaceTradersT a = ReaderT Env IO a
 
+newEnv :: S.Connection -> Request -> IO Env
+newEnv conn req = do
+  r <- newIORef 0
+  return $ Env conn r req
+
 runSpaceTradersT :: SpaceTradersT a -> Env -> IO a
 runSpaceTradersT = runReaderT
 
+microSinceEpoch :: IO Integer
+microSinceEpoch = do
+  t <- getCurrentTime
+  return $ floor . (1e6 *) . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds t
+
 data Env = Env { envConn :: S.Connection
+               , envLastAPICall :: IORef Integer
                , envRequest :: Request }
 
 class HasDatabaseConn a where
@@ -33,6 +51,8 @@ instance HasDatabaseConn Env where
   getConn = envConn
 
 class HasRequest a where
+  getLastAPICall :: a -> IORef Integer
   getRequest :: a -> Request
 instance HasRequest Env where
+  getLastAPICall = envLastAPICall
   getRequest = envRequest
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)