From 7bd1c116c26d0c2147aa787b04f6e7de85d44133 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Tue, 11 Jul 2023 21:55:55 +0200 Subject: [haskell] Implemented pagination and systems list api call --- haskell/src/SpaceTraders/APIClient/Agent.hs | 4 +-- haskell/src/SpaceTraders/APIClient/Client.hs | 39 +++++++++++++++++++++--- haskell/src/SpaceTraders/APIClient/Pagination.hs | 19 ++++++++++++ haskell/src/SpaceTraders/APIClient/Systems.hs | 34 +++++++++++++++++++++ haskell/src/SpaceTraders/Database.hs | 7 ++++- haskell/src/SpaceTraders/Database/Systems.hs | 23 ++++++++++++++ haskell/src/SpaceTraders/Model/System.hs | 37 ++++++++++++++++++++++ haskell/src/SpaceTraders/Model/Waypoint.hs | 28 +++++++++++++++++ 8 files changed, 183 insertions(+), 8 deletions(-) create mode 100644 haskell/src/SpaceTraders/APIClient/Pagination.hs create mode 100644 haskell/src/SpaceTraders/APIClient/Systems.hs create mode 100644 haskell/src/SpaceTraders/Database/Systems.hs create mode 100644 haskell/src/SpaceTraders/Model/System.hs create mode 100644 haskell/src/SpaceTraders/Model/Waypoint.hs (limited to 'haskell/src') diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs index 865764f..7773972 100644 --- a/haskell/src/SpaceTraders/APIClient/Agent.hs +++ b/haskell/src/SpaceTraders/APIClient/Agent.hs @@ -18,7 +18,7 @@ import SpaceTraders.Model.Agent(Agent) import SpaceTraders.Model.Ship(Ship) import SpaceTraders.Model.Contract -myAgent :: T.Text -> IO (Either APIError Agent) +myAgent :: T.Text -> IO (APIResponse Agent) myAgent t = send $ setRequestPath "/v2/my/agent" $ tokenReq t @@ -31,7 +31,7 @@ data RegisterMessage = RegisterMessage { agent :: Agent , token :: T.Text } deriving (FromJSON, Generic, Show) -register :: T.Text -> T.Text -> IO (Either APIError RegisterMessage) +register :: T.Text -> T.Text -> IO (APIResponse RegisterMessage) register s f = send $ setRequestPath "/v2/register" $ 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 cbbe422..87147b6 100644 --- a/haskell/src/SpaceTraders/APIClient/Client.hs +++ b/haskell/src/SpaceTraders/APIClient/Client.hs @@ -4,25 +4,39 @@ module SpaceTraders.APIClient.Client ( APIError(..) , APIMessage(..) + , APIPaginatedResponse + , APIResponse , defaultReq , fromJSONValue + , paginatedReq , send + , sendPaginated , tokenReq ) where import Control.Concurrent import Data.Aeson import Data.Aeson.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Simple import Network.HTTP.Types.Status import SpaceTraders.APIClient.Errors +import SpaceTraders.APIClient.Pagination -data FromJSON a => APIMessage a = APIMessage { data_ :: a } deriving (Show) +data FromJSON a => APIMessage a = APIMessage { messageData :: a + , messagePagination :: Maybe Pagination + } deriving (Show) instance FromJSON a => FromJSON (APIMessage a) where - parseJSON = withObject "APIMessage" $ \o -> APIMessage <$> o .: "data" + parseJSON = withObject "APIMessage" $ \o -> + APIMessage <$> o .: "data" + <*> o .:? "meta" + +type APIPaginatedResponse a = Either APIError (APIMessage a) +type APIResponse a = Either APIError a defaultReq :: Request defaultReq = setRequestHost "api.spacetraders.io" @@ -31,6 +45,14 @@ 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 @@ -38,18 +60,25 @@ tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> t fromJSONValue :: FromJSON a => Value -> Either String a fromJSONValue = parseEither parseJSON -send :: FromJSON a => Request -> IO (Either APIError a) +send :: FromJSON a => Request -> IO (APIResponse a) send request = do + response <- sendPaginated request + 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 $ data_ r + 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)) - send request + sendPaginated request Right e -> return $ Left e diff --git a/haskell/src/SpaceTraders/APIClient/Pagination.hs b/haskell/src/SpaceTraders/APIClient/Pagination.hs new file mode 100644 index 0000000..bb9bcd1 --- /dev/null +++ b/haskell/src/SpaceTraders/APIClient/Pagination.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.APIClient.Pagination + ( Pagination(..) + , nextPage + ) where + +import Data.Aeson +import GHC.Generics + +data Pagination = Pagination { limit :: Int + , page :: Int + , total :: Int + } deriving (FromJSON, Generic, Show) + +nextPage :: Pagination -> Pagination +nextPage (Pagination l p t) = Pagination l (p + 1) t diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs new file mode 100644 index 0000000..fca2037 --- /dev/null +++ b/haskell/src/SpaceTraders/APIClient/Systems.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.APIClient.Systems + ( listSystems + ) where + +import Control.Exception +import qualified Data.Text as T +import qualified Database.SQLite.Simple as S +import Network.HTTP.Simple + +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' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0} + where + listSystems' :: Pagination -> IO (APIResponse [System]) + listSystems' p = do + resp <- sendPaginated $ setRequestPath "/v2/systems" + $ paginatedReq t (Just p) + case resp of + Left e -> throwIO e + Right (APIMessage [] _) -> Right <$> getSystems conn + Right (APIMessage r (Just p')) -> do + addSystems conn r + listSystems' (nextPage p') + _ -> undefined diff --git a/haskell/src/SpaceTraders/Database.hs b/haskell/src/SpaceTraders/Database.hs index ac3aa7b..4fffb07 100644 --- a/haskell/src/SpaceTraders/Database.hs +++ b/haskell/src/SpaceTraders/Database.hs @@ -31,7 +31,12 @@ migrations = [ id INTEGER PRIMARY KEY, data TEXT NOT NULL );|], - [r|CREATE UNIQUE INDEX ships_data_symbol ON ships (json_extract(data, '$.symbol'));|]] + [r|CREATE UNIQUE INDEX ships_data_symbol ON ships (json_extract(data, '$.symbol'));|], + [r|CREATE TABLE systems ( + id INTEGER PRIMARY KEY, + data TEXT NOT NULL + );|], + [r|CREATE UNIQUE INDEX systems_data_symbol ON systems (json_extract(data, '$.symbol'));|]] close :: S.Connection -> IO () close conn = S.close conn diff --git a/haskell/src/SpaceTraders/Database/Systems.hs b/haskell/src/SpaceTraders/Database/Systems.hs new file mode 100644 index 0000000..5312fd0 --- /dev/null +++ b/haskell/src/SpaceTraders/Database/Systems.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.Database.Systems + ( addSystems + , getSystems + ) where + +import Data.Aeson +import Data.Maybe +import qualified Database.SQLite.Simple as S + +import Data.Text.Encoding (encodeUtf8Builder) +import Data.ByteString.Builder(toLazyByteString) + +import SpaceTraders.Model.System + +addSystems :: S.Connection -> [System] -> IO () +addSystems conn systems = S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems + +getSystems :: S.Connection -> IO [System] +getSystems conn = do + ret <- S.query_ conn "SELECT data from systems;" + return . catMaybes $ map (decode . toLazyByteString . encodeUtf8Builder . head) ret diff --git a/haskell/src/SpaceTraders/Model/System.hs b/haskell/src/SpaceTraders/Model/System.hs new file mode 100644 index 0000000..dacd27a --- /dev/null +++ b/haskell/src/SpaceTraders/Model/System.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.Model.System + ( System(..) + ) where + +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics + +import SpaceTraders.Model.Waypoint(Waypoint) + +data System = System { sectorSymbol :: T.Text + , symbol :: T.Text + , systemType :: T.Text + , x :: Int + , y :: Int + , waypoints :: [Waypoint] + --, factions :: [Faction] + } deriving (Generic, Show) +instance FromJSON System where + parseJSON = withObject "System" $ \o -> + System <$> o .: "sectorSymbol" + <*> o .: "symbol" + <*> o .: "type" + <*> o .: "x" + <*> o .: "y" + <*> o .: "waypoints" +instance ToJSON System where + toEncoding (System ss s t xx yy w) = pairs ( "sectorSymbol" .= ss + <> "symbol" .= s + <> "type" .= t + <> "x" .= xx + <> "y" .= yy + <> "waypoints" .= w ) diff --git a/haskell/src/SpaceTraders/Model/Waypoint.hs b/haskell/src/SpaceTraders/Model/Waypoint.hs new file mode 100644 index 0000000..d18cc11 --- /dev/null +++ b/haskell/src/SpaceTraders/Model/Waypoint.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.Model.Waypoint + ( Waypoint(..) + ) where + +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics + +data Waypoint = Waypoint { symbol :: T.Text + , waypointType :: T.Text + , x :: Int + , y :: Int + } deriving (Generic, Show) +instance FromJSON Waypoint where + parseJSON = withObject "Waypoint" $ \o -> + Waypoint <$> o .: "symbol" + <*> o .: "type" + <*> o .: "x" + <*> o .: "y" +instance ToJSON Waypoint where + toEncoding (Waypoint s t xx yy) = pairs ( "symbol" .= s + <> "type" .= t + <> "x" .= xx + <> "y" .= yy ) -- cgit v1.2.3