[haskell] Implemented pagination and systems list api call

9 files changed, 186 insertions, 8 deletions

diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs
index 76e4bef..38e6b0d 100644
--- a/haskell/app/Main.hs
+++ b/haskell/app/Main.hs
@@ -7,6 +7,7 @@ import qualified Database.SQLite.Simple as S
 import qualified Data.Text as T
 
 import SpaceTraders.APIClient.Agent
+import SpaceTraders.APIClient.Systems
 import SpaceTraders.Database
 import SpaceTraders.Database.Agents
 import SpaceTraders.Database.Contracts
@@ -19,6 +20,8 @@ main = do
   t <- getToken conn `catch` registerNow conn
   ma <- myAgent t
   print ma
+  s <- listSystems t conn
+  print s
   close conn
   where
     registerNow :: S.Connection -> SomeException -> IO (T.Text)
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 )