summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders/APIClient
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--haskell/src/SpaceTraders/APIClient/Agent.hs17
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs70
-rw-r--r--haskell/src/SpaceTraders/APIClient/Ships.hs36
-rw-r--r--haskell/src/SpaceTraders/APIClient/Systems.hs20
4 files changed, 86 insertions, 57 deletions
diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs
index 023a4f4..7b367f6 100644
--- a/haskell/src/SpaceTraders/APIClient/Agent.hs
+++ b/haskell/src/SpaceTraders/APIClient/Agent.hs
@@ -8,22 +8,20 @@ module SpaceTraders.APIClient.Agent
, register
) where
+import Control.Monad.Reader
import Data.Aeson
import GHC.Generics
import qualified Data.Text as T
import Network.HTTP.Simple
-import qualified SpaceTraders as ST
+import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.Model.Agent(Agent)
import SpaceTraders.Model.Ship(Ship)
import SpaceTraders.Model.Contract
-myAgent :: ST.SpaceTradersT (APIResponse Agent)
-myAgent = do
- c <- ST.ask
- ST.liftIO $ send $ setRequestPath "/v2/my/agent"
- $ tokenReq (ST.token c)
+myAgent :: SpaceTradersT (APIResponse Agent)
+myAgent = send $ setRequestPath "/v2/my/agent"
data RegisterRequest = RegisterRequest { faction :: T.Text
, symbol :: T.Text
@@ -34,8 +32,7 @@ data RegisterMessage = RegisterMessage { agent :: Agent
, token :: T.Text
} deriving (FromJSON, Generic, Show)
-register :: T.Text -> T.Text -> IO (APIResponse RegisterMessage)
+register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage)
register s f = send $ setRequestPath "/v2/register"
- $ setRequestMethod "POST"
- $ setRequestBodyJSON RegisterRequest{symbol = s, faction = f}
- $ defaultReq
+ . setRequestMethod "POST"
+ . setRequestBodyJSON RegisterRequest{symbol = s, faction = f}
diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index 0f0cf27..402431f 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -8,13 +8,13 @@ module SpaceTraders.APIClient.Client
, APIResponse
, defaultReq
, fromJSONValue
- , paginatedReq
, send
, sendPaginated
, tokenReq
) where
import Control.Concurrent
+import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString as B
@@ -23,9 +23,8 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Simple
import Network.HTTP.Types.Status
-import System.Environment
-import System.Posix.Process
+import SpaceTraders
import SpaceTraders.APIClient.Errors
import SpaceTraders.APIClient.Pagination
@@ -47,45 +46,44 @@ defaultReq = setRequestHost "api.spacetraders.io"
$ setRequestHeader "Content-Type" ["application/json"]
$ defaultRequest
-paginatedReq :: T.Text -> Maybe Pagination -> Request
-paginatedReq token Nothing = setRequestQueryString [("limit", Just "20")]
- $ tokenReq token
-paginatedReq token (Just myPage) = setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
- $ tokenReq token
- where
- int2ByteString = B.pack . map B.c2w . show
-
tokenReq :: T.Text -> Request
-tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token]
- $ defaultReq
+tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] defaultReq
fromJSONValue :: FromJSON a => Value -> Either String a
fromJSONValue = parseEither parseJSON
-send :: FromJSON a => Request -> IO (APIResponse a)
-send request = do
- response <- sendPaginated request
+int2ByteString :: Int -> B.ByteString
+int2ByteString = B.pack . map B.c2w . show
+
+send :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => (Request -> Request) -> m (APIResponse a)
+send requestBuilder = do
+ response <- sendPaginated Nothing requestBuilder
case response of
Left e -> return $ Left e
Right (APIMessage d _) -> return $ Right d
-sendPaginated :: FromJSON a => Request -> IO (APIPaginatedResponse a)
-sendPaginated request = do
- response <- httpLbs request
- let status = statusCode $ getResponseStatus response
- body = getResponseBody response
- if status >= 200 && status <= 299
- then case eitherDecode body of
- Left e -> return . Left $ APIError (-1000) (T.pack $ concat ["Error decoding JSON APIMessage: ", e]) Null
- Right r -> return $ Right r
- 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
- threadDelay (1_000_000 * (round $ retryAfter r))
- sendPaginated request
- Right (APIResetHappened _) -> do
- p <- getExecutablePath
- a <- getArgs
- e <- getEnvironment
- executeFile p False a (Just e)
- Right e -> return $ Left e
+sendPaginated :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Maybe Pagination -> (Request -> Request) -> m (APIPaginatedResponse a)
+sendPaginated pagination requestBuilder = do
+ env <- ask
+ let request = requestBuilder $ getRequest env
+ request' = case pagination of
+ Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
+ $ request
+ Nothing -> request
+ sendPaginated' request'
+ where
+ sendPaginated' :: (FromJSON a, MonadIO m) => Request -> m (APIPaginatedResponse a)
+ sendPaginated' request = do
+ response <- liftIO $ httpLbs request
+ let status = statusCode $ getResponseStatus response
+ body = getResponseBody response
+ if status >= 200 && status <= 299
+ then case eitherDecode body of
+ Left e -> return . Left $ APIError (-1000) (T.pack $ concat ["Error decoding JSON APIMessage: ", e]) Null
+ Right r -> return $ Right r
+ 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))
+ sendPaginated' request
+ Right e -> return $ Left e
diff --git a/haskell/src/SpaceTraders/APIClient/Ships.hs b/haskell/src/SpaceTraders/APIClient/Ships.hs
new file mode 100644
index 0000000..0efbb5d
--- /dev/null
+++ b/haskell/src/SpaceTraders/APIClient/Ships.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.APIClient.Ships
+ ( listShips
+ ) where
+
+import Control.Exception
+--import qualified Data.Text as T
+--import qualified Database.SQLite.Simple as S
+import Network.HTTP.Simple
+
+import SpaceTraders
+import SpaceTraders.APIClient.Client
+import SpaceTraders.APIClient.Pagination
+--import SpaceTraders.Database.Ships
+import SpaceTraders.Model.Ship(Ship)
+import Debug.Trace
+
+listShips :: SpaceTradersT (APIResponse [Ship])
+listShips = do
+ listShips' Pagination{limit=20, page=1, total=0}
+ where
+ listShips' :: Pagination -> SpaceTradersT (APIResponse [Ship])
+ listShips' p = do
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/my/ships"
+ case resp of
+ Left e -> throw e
+ Right (APIMessage r (Just p')) -> do
+ liftIO $ traceIO $ show p'
+ --if (length r == 0 || ((page p') * (limit p')
+ --addShips conn r
+ --listShips' (nextPage p')
+ return $ Right r
+ _ -> undefined
diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs
index fca2037..2e275ee 100644
--- a/haskell/src/SpaceTraders/APIClient/Systems.hs
+++ b/haskell/src/SpaceTraders/APIClient/Systems.hs
@@ -7,28 +7,26 @@ module SpaceTraders.APIClient.Systems
) where
import Control.Exception
-import qualified Data.Text as T
-import qualified Database.SQLite.Simple as S
import Network.HTTP.Simple
+import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Systems
import SpaceTraders.Model.System(System)
-listSystems :: T.Text -> S.Connection -> IO (APIResponse [System])
-listSystems t conn = do
- s <- getSystems conn
+listSystems :: SpaceTradersT (APIResponse [System])
+listSystems = do
+ s <- getSystems
listSystems' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0}
where
- listSystems' :: Pagination -> IO (APIResponse [System])
+ listSystems' :: Pagination -> SpaceTradersT (APIResponse [System])
listSystems' p = do
- resp <- sendPaginated $ setRequestPath "/v2/systems"
- $ paginatedReq t (Just p)
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/systems"
case resp of
- Left e -> throwIO e
- Right (APIMessage [] _) -> Right <$> getSystems conn
+ Left e -> throw e
+ Right (APIMessage [] _) -> Right <$> getSystems
Right (APIMessage r (Just p')) -> do
- addSystems conn r
+ addSystems r
listSystems' (nextPage p')
_ -> undefined
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 13:42:33 +0000