adyxax/spacetraders
1
0
Fork 0
Code Issues Activity

[haskell] Finalized the agent initialization, refresh and reset

Browse source
This commit is contained in:
Julien Dessaux 2023-07-20 00:24:31 +02:00
parent b763823376
commit 24f6c8eb90
Signed by: adyxax
GPG key ID: F92E51B86E07177E
9 changed files with 105 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
haskell/app/Main.hs
View file

@ -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

3
haskell/src/SpaceTraders/APIClient/Client.hs
View file

@ -2,8 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Client
( APIError(..)
, APIMessage(..)
( APIMessage(..)
, APIPaginatedResponse
, APIResponse
, defaultReq

24
haskell/src/SpaceTraders/APIClient/Ships.hs
View file

@ -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

10
haskell/src/SpaceTraders/APIClient/Systems.hs
View file

@ -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

18
haskell/src/SpaceTraders/Automation/Init.hs
View file

@ -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

15
haskell/src/SpaceTraders/Database/Agents.hs
View file

@ -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))

23
haskell/src/SpaceTraders/Database/Contracts.hs
View file

@ -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)

26
haskell/src/SpaceTraders/Database/Ships.hs
View file

@ -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)

2
haskell/src/SpaceTraders/Model/Agent.hs
View file

@ -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)