From 4af96da5670566c111fa5c7dac9572eaac021a4b Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Tue, 18 Jul 2023 00:02:33 +0200 Subject: [haskell] Refactored everything with a ReaderT pattern --- haskell/src/SpaceTraders/APIClient/Agent.hs | 17 +++---- haskell/src/SpaceTraders/APIClient/Client.hs | 70 +++++++++++++-------------- haskell/src/SpaceTraders/APIClient/Ships.hs | 36 ++++++++++++++ haskell/src/SpaceTraders/APIClient/Systems.hs | 20 ++++---- 4 files changed, 86 insertions(+), 57 deletions(-) create mode 100644 haskell/src/SpaceTraders/APIClient/Ships.hs (limited to 'haskell/src/SpaceTraders/APIClient') 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 -- cgit v1.2.3