From f23fe74dbe264cebe6e18eabac0600c4b06b5caf Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Fri, 7 Jul 2023 22:33:43 +0200
Subject: [haskell] back off when hitting the rate limit

---
 haskell/src/SpaceTraders/APIClient/Agent.hs  |  2 +-
 haskell/src/SpaceTraders/APIClient/Client.hs | 29 +++++++++----------
 haskell/src/SpaceTraders/APIClient/Errors.hs | 42 ++++++++++++++++++++++++++++
 haskell/src/SpaceTraders/Model/Agent.hs      |  7 ++---
 4 files changed, 60 insertions(+), 20 deletions(-)
 create mode 100644 haskell/src/SpaceTraders/APIClient/Errors.hs

(limited to 'haskell/src/SpaceTraders')

diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs
index 4ac550c..865764f 100644
--- a/haskell/src/SpaceTraders/APIClient/Agent.hs
+++ b/haskell/src/SpaceTraders/APIClient/Agent.hs
@@ -14,7 +14,7 @@ import qualified Data.Text as T
 import Network.HTTP.Simple
 
 import SpaceTraders.APIClient.Client
-import SpaceTraders.Model.Agent
+import SpaceTraders.Model.Agent(Agent)
 import SpaceTraders.Model.Ship(Ship)
 import SpaceTraders.Model.Contract
 
diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index e4744aa..4e9e9d1 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Client
@@ -9,6 +10,7 @@ module SpaceTraders.APIClient.Client
   , tokenReq
   ) where
 
+import Control.Concurrent
 import Control.Exception
 import Control.Monad
 import Data.Aeson
@@ -18,16 +20,7 @@ import qualified Data.Text.Encoding as T
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
 
-data APIError = APIError { apiErrorCode :: Int
-                         , apiErrorMessage :: T.Text
-                         } deriving Show
-instance Exception APIError
-instance FromJSON APIError where
-  parseJSON (Object o) = do
-    e <- o .: "error"
-    APIError <$> e .: "code"
-             <*> e .: "message"
-  parseJSON _ = mzero
+import SpaceTraders.APIClient.Errors
 
 data APIMessage = APIMessage { data_ :: Value } deriving (Show)
 instance FromJSON APIMessage where
@@ -55,13 +48,21 @@ send request = do
       body = getResponseBody response
   if status >= 200 && status <= 299
     then case eitherDecode body of
-      Left e -> return $ Left APIError{apiErrorCode = -1000, apiErrorMessage = T.pack $ concat ["Error decoding JSON APIMessage: ", e]}
+      Left e -> return . Left $ APIError (-1000) Null (T.pack $ concat ["Error decoding JSON APIMessage: ", e])
       Right r -> case fromJSONValue (data_ r) of
-        Left e -> return $ Left APIError{apiErrorCode = -1001, apiErrorMessage = T.pack $ concat ["Error decoding JSON message contents: ", e]}
+        Left e -> return . Left $ APIError (-1001) Null (T.pack $ concat ["Error decoding JSON message contents: ", e])
         Right m -> return $ Right m
     else case eitherDecode body of
-      Left e -> return $ Left APIError{apiErrorCode = -status, apiErrorMessage = T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body]}
-      Right e -> return $ Left e
+      Left e -> return . Left $ APIError (-status) Null (T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body])
+      Right e -> case apiErrorCode e of
+        429 -> do -- We are being rate limited
+          let d = apiErrorData e
+          w <- case fromJSONValue d of
+            Left _ -> throwIO e
+            Right e' -> return $ retryAfter e'
+          threadDelay (1_000_000 * (round w))
+          send request
+        _ -> return $ Left e
 
 --handleAPIError :: SomeException -> IO (Maybe RegisterMessage)
 --handleAPIError e = do
diff --git a/haskell/src/SpaceTraders/APIClient/Errors.hs b/haskell/src/SpaceTraders/APIClient/Errors.hs
new file mode 100644
index 0000000..4ab47bc
--- /dev/null
+++ b/haskell/src/SpaceTraders/APIClient/Errors.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.APIClient.Errors
+  ( APIError(..)
+  , RateLimit(..)
+  ) where
+
+import Control.Exception
+import Control.Monad
+import Data.Aeson
+import Data.Time
+import qualified Data.Text as T
+
+data APIError = APIError { apiErrorCode :: Int
+                         , apiErrorData :: Value
+                         , apiErrorMessage :: T.Text
+                         } deriving Show
+instance Exception APIError
+instance FromJSON APIError where
+  parseJSON (Object o) = do
+    e <- o .: "error"
+    APIError <$> e .: "code"
+             <*> e .: "data"
+             <*> e .: "message"
+  parseJSON _ = mzero
+
+data RateLimit = RateLimit { limitBurst :: Int
+                           , limitPerSecond :: Int
+                           , rateLimitType :: T.Text
+                           , remaining :: Int
+                           , reset :: UTCTime
+                           , retryAfter :: Double
+                           } deriving Show
+instance FromJSON RateLimit where
+  parseJSON (Object o) = do
+    RateLimit <$> o .: "limitBurst"
+              <*> o .: "limitPerSecond"
+              <*> o .: "type"
+              <*> o .: "remaining"
+              <*> o .: "reset"
+              <*> o .: "retryAfter"
+  parseJSON _ = mzero
diff --git a/haskell/src/SpaceTraders/Model/Agent.hs b/haskell/src/SpaceTraders/Model/Agent.hs
index be97ac4..3852107 100644
--- a/haskell/src/SpaceTraders/Model/Agent.hs
+++ b/haskell/src/SpaceTraders/Model/Agent.hs
@@ -3,8 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Agent
-  ( Agent(accountId, credits, headquarters)
-  , agentSymbol
+  ( Agent(..)
   ) where
 
 import Data.Aeson
@@ -13,10 +12,8 @@ import qualified Data.Text as T
 
 data Agent = Agent { accountId :: T.Text
                    , credits :: Integer
+                   --, faction :: Faction
                    , headquarters :: T.Text
                    , startingFaction :: T.Text
                    , symbol :: T.Text
                    } deriving (FromJSON, Generic, Show, ToJSON)
-
-agentSymbol :: Agent -> T.Text
-agentSymbol = symbol
-- 
cgit v1.2.3