summaryrefslogtreecommitdiff
path: root/haskell
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
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 '')
-rw-r--r--haskell/package.yaml1
-rw-r--r--haskell/src/SpaceTraders.hs20
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs18
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs8
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)