summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders
diff options
context:
space:
mode:
authorJulien Dessaux2023-07-27 23:29:28 +0200
committerJulien Dessaux2023-07-27 23:29:28 +0200
commit20d4381c9c9f3f64feafc246d12dc546542e5e84 (patch)
treee149ffb4cbffebefd0c831b970342dea53339908 /haskell/src/SpaceTraders
parent[haskell] embed sql migration scripts from external files (diff)
downloadspacetraders-20d4381c9c9f3f64feafc246d12dc546542e5e84.tar.gz
spacetraders-20d4381c9c9f3f64feafc246d12dc546542e5e84.tar.bz2
spacetraders-20d4381c9c9f3f64feafc246d12dc546542e5e84.zip
[haskell] implemented ships's availability tracking in the database
Diffstat (limited to '')
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs2
-rw-r--r--haskell/src/SpaceTraders/Database/000_init.sql3
-rw-r--r--haskell/src/SpaceTraders/Database/Ships.hs13
-rw-r--r--haskell/src/SpaceTraders/Utils.hs12
4 files changed, 19 insertions, 11 deletions
diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs
index 5c70a1d..42c19e1 100644
--- a/haskell/src/SpaceTraders/Automation/Init.hs
+++ b/haskell/src/SpaceTraders/Automation/Init.hs
@@ -20,6 +20,7 @@ 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 ()
@@ -53,6 +54,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
diff --git a/haskell/src/SpaceTraders/Database/000_init.sql b/haskell/src/SpaceTraders/Database/000_init.sql
index 78a62cd..cbe6029 100644
--- a/haskell/src/SpaceTraders/Database/000_init.sql
+++ b/haskell/src/SpaceTraders/Database/000_init.sql
@@ -15,7 +15,8 @@ CREATE TABLE contracts (
);
CREATE TABLE ships (
id INTEGER PRIMARY KEY,
- data TEXT NOT NULL
+ data TEXT NOT NULL,
+ available DATE NOT NULL
);
CREATE UNIQUE INDEX ships_data_symbol ON ships (json_extract(data, '$.symbol'));
CREATE TABLE systems (
diff --git a/haskell/src/SpaceTraders/Database/Ships.hs b/haskell/src/SpaceTraders/Database/Ships.hs
index 5a2ab7c..8c47059 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -9,6 +9,8 @@ module SpaceTraders.Database.Ships
import Control.Monad.Reader
import Data.Aeson
+import Data.Time
+import Data.Time.Format.ISO8601
import qualified Database.SQLite.Simple as S
import SpaceTraders
@@ -16,7 +18,9 @@ import SpaceTraders.Model.Ship
import SpaceTraders.Utils
addShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
-addShip ship = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
+addShip ship = do
+ t <- liftIO getCurrentTime
+ execute "INSERT INTO ships(data, available) VALUES (json(?), ?);" (encode ship, iso8601Show t)
getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship]
getShips = query_ "SELECT data FROM ships;"
@@ -25,7 +29,8 @@ setShip :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => S
setShip ship = do
c <- count "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship)
if c == 0 then addShip ship
- else updateShip ship
+ else updateShip ship Nothing
-updateShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
-updateShip ship = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
+updateShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> Maybe UTCTime -> m ()
+updateShip ship (Just time) = execute "UPDATE ships SET data = json(?), available = ? WHERE data->>'symbol' = ?;" (encode ship, iso8601Show time, symbol ship)
+updateShip ship Nothing = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
diff --git a/haskell/src/SpaceTraders/Utils.hs b/haskell/src/SpaceTraders/Utils.hs
index f78fda1..2f54a81 100644
--- a/haskell/src/SpaceTraders/Utils.hs
+++ b/haskell/src/SpaceTraders/Utils.hs
@@ -22,6 +22,12 @@ import qualified Database.SQLite.Simple as S
import SpaceTraders
+count :: (HasDatabaseConn env, MonadFail m, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m Int
+count q t = do
+ env <- ask
+ [[ret]] <- liftIO (S.query (getConn env) q t :: IO [[Int]])
+ return ret
+
decodeText :: FromJSON a => T.Text -> Maybe a
decodeText = decode . B.toLazyByteString . T.encodeUtf8Builder
@@ -39,12 +45,6 @@ int2ByteString = B.pack . map B.c2w . show
one_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m b
one_ q = query_ q >>= pure . head
-count :: (HasDatabaseConn env, MonadFail m, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m Int
-count q t = do
- env <- ask
- [[ret]] <- liftIO (S.query (getConn env) q t :: IO [[Int]])
- return ret
-
query :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m [b]
query q t = do
env <- ask