summaryrefslogtreecommitdiff
path: root/haskell/src
diff options
context:
space:
mode:
Diffstat (limited to 'haskell/src')
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs3
-rw-r--r--haskell/src/SpaceTraders/APIClient/Ships.hs24
-rw-r--r--haskell/src/SpaceTraders/APIClient/Systems.hs10
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs18
-rw-r--r--haskell/src/SpaceTraders/Database/Agents.hs15
-rw-r--r--haskell/src/SpaceTraders/Database/Contracts.hs23
-rw-r--r--haskell/src/SpaceTraders/Database/Ships.hs26
-rw-r--r--haskell/src/SpaceTraders/Model/Agent.hs2
8 files changed, 92 insertions, 29 deletions
diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index c7b58e0..1ca03ee 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -2,8 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Client
- ( APIError(..)
- , APIMessage(..)
+ ( APIMessage(..)
, APIPaginatedResponse
, APIResponse
, defaultReq
diff --git a/haskell/src/SpaceTraders/APIClient/Ships.hs b/haskell/src/SpaceTraders/APIClient/Ships.hs
index 0efbb5d..e2cf15c 100644
--- a/haskell/src/SpaceTraders/APIClient/Ships.hs
+++ b/haskell/src/SpaceTraders/APIClient/Ships.hs
@@ -3,34 +3,28 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Ships
- ( listShips
+ ( myShips
) 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.Database.Ships
import SpaceTraders.Model.Ship(Ship)
-import Debug.Trace
-listShips :: SpaceTradersT (APIResponse [Ship])
-listShips = do
+myShips :: SpaceTradersT (APIResponse [Ship])
+myShips = 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"
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/my/ships" :: SpaceTradersT (APIPaginatedResponse [Ship])
case resp of
- Left e -> throw e
+ Left e -> return $ Left 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
+ mapM_ setShip r
+ if (limit p' * page p' < total p') then listShips' (nextPage p')
+ else Right <$> getShips
_ -> undefined
diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs
index 2e275ee..eb15b4d 100644
--- a/haskell/src/SpaceTraders/APIClient/Systems.hs
+++ b/haskell/src/SpaceTraders/APIClient/Systems.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Systems
- ( listSystems
+ ( initSystems
) where
import Control.Exception
@@ -15,8 +15,8 @@ import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Systems
import SpaceTraders.Model.System(System)
-listSystems :: SpaceTradersT (APIResponse [System])
-listSystems = do
+initSystems :: SpaceTradersT (APIResponse [System])
+initSystems = do
s <- getSystems
listSystems' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0}
where
@@ -25,8 +25,8 @@ listSystems = do
resp <- sendPaginated (Just p) $ setRequestPath "/v2/systems"
case resp of
Left e -> throw e
- Right (APIMessage [] _) -> Right <$> getSystems
Right (APIMessage r (Just p')) -> do
addSystems r
- listSystems' (nextPage p')
+ if (limit p' * page p' < total p') then listSystems' (nextPage p')
+ else Right <$> getSystems
_ -> undefined
diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs
index 2e9d8bb..feeb54b 100644
--- a/haskell/src/SpaceTraders/Automation/Init.hs
+++ b/haskell/src/SpaceTraders/Automation/Init.hs
@@ -14,10 +14,12 @@ import System.Directory
import SpaceTraders
import SpaceTraders.APIClient.Agent
import SpaceTraders.APIClient.Client
+import SpaceTraders.APIClient.Contracts
+import SpaceTraders.APIClient.Errors
+import SpaceTraders.APIClient.Ships
import SpaceTraders.Database
import SpaceTraders.Database.Agents
import SpaceTraders.Database.Contracts
-import SpaceTraders.Database.Ships
import SpaceTraders.Database.Tokens
deinitST :: Env -> IO ()
@@ -29,11 +31,17 @@ initST = do
conn <- open
t <- runReaderT getToken conn `catch` handleNoToken conn
let env = Env conn (tokenReq t)
- ma <- runSpaceTradersT myAgent env
- case ma of
+ ma <- runReaderT getAgent conn -- We compare the agent state in the database
+ ma' <- runSpaceTradersT myAgent env -- with the one on the servers
+ case ma' of
Left (APIResetHappened _) -> wipe conn
Left e -> throwIO e
- _ -> return $ env
+ Right ma'' -> do
+ when (ma /= ma'') $ do
+ _ <- runReaderT myContracts env -- refresh contracts
+ _ <- runReaderT myShips env -- refresh ships
+ runReaderT (setAgent ma'') conn -- store the fresh agent state
+ return $ env
where
handleNoToken :: S.Connection -> SomeException -> IO T.Text
handleNoToken conn _ = runReaderT registerST (Env conn defaultReq)
@@ -45,7 +53,7 @@ registerST = do
Right r' -> do
addAgent $ agent r'
addContract $ contract r'
- addShip $ ship r'
+ _ <- myShips -- in order to fetch the starting probe that is not advertised in the register message
let t = token r'
addToken t
return t
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index b34ca04..0557b1d 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -2,16 +2,31 @@
module SpaceTraders.Database.Agents
( addAgent
+ , getAgent
+ , setAgent
) where
import Control.Monad.Reader
import Data.Aeson
+import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
import SpaceTraders.Model.Agent
+import SpaceTraders.Utils
addAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
addAgent agent = do
env <- ask
liftIO $ S.execute (getConn env) "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))
+
+getAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m Agent
+getAgent = do
+ env <- ask
+ ret <- liftIO $ S.query_ (getConn env) "SELECT data FROM agents;"
+ return . head . catMaybes $ map (decodeText . head) ret
+
+setAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
+setAgent agent = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "UPDATE agents SET data = json(?);" (S.Only (encode agent))
diff --git a/haskell/src/SpaceTraders/Database/Contracts.hs b/haskell/src/SpaceTraders/Database/Contracts.hs
index 26c4a1f..1084447 100644
--- a/haskell/src/SpaceTraders/Database/Contracts.hs
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -2,16 +2,39 @@
module SpaceTraders.Database.Contracts
( addContract
+ , getContracts
+ , setContract
+ , updateContract
) where
import Control.Monad.Reader
import Data.Aeson
+import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
import SpaceTraders.Model.Contract
+import SpaceTraders.Utils
addContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
addContract contract = do
env <- ask
liftIO $ S.execute (getConn env) "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
+
+getContracts :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Contract]
+getContracts = do
+ env <- ask
+ ret <- liftIO $ S.query_ (getConn env) "SELECT data FROM contracts;"
+ return . catMaybes $ map (decodeText . head) ret
+
+setContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
+setContract contract = do
+ env <- ask
+ count <- liftIO (S.query (getConn env) "SELECT count(id) FROM contracts WHERE data->>'contractId' = ?;" (S.Only $ contractId contract) :: IO [[Int]])
+ if count == [[0]] then addContract contract
+ else updateContract contract
+
+updateContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
+updateContract contract = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId contract)
diff --git a/haskell/src/SpaceTraders/Database/Ships.hs b/haskell/src/SpaceTraders/Database/Ships.hs
index 95b0b5d..5dd6be0 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -2,16 +2,40 @@
module SpaceTraders.Database.Ships
( addShip
+ , getShips
+ , setShip
+ , updateShip
) where
+import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson
+import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
import SpaceTraders.Model.Ship
+import SpaceTraders.Utils
addShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
addShip ship = do
env <- ask
- liftIO $ S.execute (getConn env) "INSERT INTO ships(data) VALUES (json(?));" (S.Only (encode ship))
+ liftIO $ S.execute (getConn env) "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
+
+getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship]
+getShips = do
+ env <- ask
+ ret <- liftIO $ S.query_ (getConn env) "SELECT data FROM ships;"
+ return . catMaybes $ map (decodeText . head) ret
+
+setShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
+setShip ship = do
+ env <- ask
+ count <- liftIO (S.query (getConn env) "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship) :: IO [[Int]])
+ if count == [[0]] then addShip ship
+ else updateShip ship
+
+updateShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
+updateShip ship = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
diff --git a/haskell/src/SpaceTraders/Model/Agent.hs b/haskell/src/SpaceTraders/Model/Agent.hs
index 3852107..01c08a0 100644
--- a/haskell/src/SpaceTraders/Model/Agent.hs
+++ b/haskell/src/SpaceTraders/Model/Agent.hs
@@ -16,4 +16,4 @@ data Agent = Agent { accountId :: T.Text
, headquarters :: T.Text
, startingFaction :: T.Text
, symbol :: T.Text
- } deriving (FromJSON, Generic, Show, ToJSON)
+ } deriving (Eq, FromJSON, Generic, Show, ToJSON)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 09:44:03 +0000