summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders
diff options
context:
space:
mode:
authorJulien Dessaux2023-07-22 00:10:02 +0200
committerJulien Dessaux2023-07-22 00:10:02 +0200
commitd1f0faf30f5b5d05ae9f5eda36de8f9cffcade2d (patch)
tree3aa9d1c035d2dc5931db030a4fd764cf43b3f507 /haskell/src/SpaceTraders
parent[haskell] abstracted away common database access patterns (diff)
downloadspacetraders-d1f0faf30f5b5d05ae9f5eda36de8f9cffcade2d.tar.gz
spacetraders-d1f0faf30f5b5d05ae9f5eda36de8f9cffcade2d.tar.bz2
spacetraders-d1f0faf30f5b5d05ae9f5eda36de8f9cffcade2d.zip
[haskell] Prevent que networking code from triggering the API rate limiting
Diffstat (limited to 'haskell/src/SpaceTraders')
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs18
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs8
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)