From 24f6c8eb90555b81a96b142fec8057b05d334035 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Thu, 20 Jul 2023 00:24:31 +0200 Subject: [haskell] Finalized the agent initialization, refresh and reset --- haskell/app/Main.hs | 30 +++++++++++--------------- haskell/src/SpaceTraders/APIClient/Client.hs | 3 +-- haskell/src/SpaceTraders/APIClient/Ships.hs | 24 ++++++++------------- haskell/src/SpaceTraders/APIClient/Systems.hs | 10 ++++----- haskell/src/SpaceTraders/Automation/Init.hs | 18 +++++++++++----- haskell/src/SpaceTraders/Database/Agents.hs | 15 +++++++++++++ haskell/src/SpaceTraders/Database/Contracts.hs | 23 ++++++++++++++++++++ haskell/src/SpaceTraders/Database/Ships.hs | 26 +++++++++++++++++++++- haskell/src/SpaceTraders/Model/Agent.hs | 2 +- 9 files changed, 105 insertions(+), 46 deletions(-) (limited to 'haskell') diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs index 1b2ccec..85b07da 100644 --- a/haskell/app/Main.hs +++ b/haskell/app/Main.hs @@ -8,29 +8,25 @@ import System.Posix.Process import SpaceTraders import SpaceTraders.Automation.Init -import SpaceTraders.APIClient.Agent(myAgent) -import SpaceTraders.APIClient.Client -import SpaceTraders.APIClient.Ships +import SpaceTraders.APIClient.Errors import SpaceTraders.APIClient.Systems +import SpaceTraders.Database.Agents +import SpaceTraders.Database.Contracts +import SpaceTraders.Database.Ships main :: IO () main = do env <- initST - ma <- runSpaceTradersT myAgent env - case ma of - Left (APIResetHappened _) -> do - p <- getExecutablePath - a <- getArgs - e <- getEnvironment - executeFile p False a (Just e) - Left e -> throwIO e - Right ma' -> print ma' - s <- runSpaceTradersT listSystems env + runSpaceTradersT getAgent env >>= print + s <- runSpaceTradersT initSystems env case s of + Left (APIResetHappened _) -> do + p <- getExecutablePath + a <- getArgs + e <- getEnvironment + executeFile p False a (Just e) Left e -> throwIO e Right s' -> print $ length s' - ships <- runSpaceTradersT listShips env - case ships of - Left e -> throwIO e - Right s' -> print $ s' + runSpaceTradersT getContracts env >>= print + runSpaceTradersT getShips env >>= print deinitST env 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) -- cgit v1.2.3