[haskell] Finalized the agent initialization, refresh and reset

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.Errors
-import SpaceTraders.APIClient.Client
-import SpaceTraders.APIClient.Ships
 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
+  runSpaceTradersT getAgent env >>= print
-  case ma of
+  s <- runSpaceTradersT initSystems env
-   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
   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
+  runSpaceTradersT getContracts env >>= print
-  case ships of
+  runSpaceTradersT getShips env >>= print
-    Left e -> throwIO e
-    Right s' -> print $ s'
   deinitST env

haskell/src/SpaceTraders/APIClient/Client.hs

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

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])
+myShips :: SpaceTradersT (APIResponse [Ship])
-listShips = do
+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'
+          mapM_ setShip r
-          --if (length r == 0 || ((page p') * (limit p')
+          if (limit p' * page p' < total p') then listShips' (nextPage p')
-          --addShips conn r
+                                             else Right <$> getShips
-          --listShips' (nextPage p')
-          return $ Right  r
         _ -> undefined

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])
+initSystems :: SpaceTradersT (APIResponse [System])
-listSystems = do
+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

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
+  ma <- runReaderT getAgent conn -- We compare the agent state in the database
-  case ma of
+  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

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

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)

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)

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)