summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders
diff options
context:
space:
mode:
authorJulien Dessaux2023-07-21 00:01:02 +0200
committerJulien Dessaux2023-07-21 00:01:02 +0200
commitdcd0a7a9b2612f383c1f627c72c27868c367058d (patch)
tree773b322f5b353cd39fbaf4161deba93968d20b56 /haskell/src/SpaceTraders
parent[haskell] Finalized the agent initialization, refresh and reset (diff)
downloadspacetraders-dcd0a7a9b2612f383c1f627c72c27868c367058d.tar.gz
spacetraders-dcd0a7a9b2612f383c1f627c72c27868c367058d.tar.bz2
spacetraders-dcd0a7a9b2612f383c1f627c72c27868c367058d.zip
[haskell] abstracted away common database access patterns
Diffstat (limited to 'haskell/src/SpaceTraders')
-rw-r--r--haskell/src/SpaceTraders/APIClient/Contracts.hs30
-rw-r--r--haskell/src/SpaceTraders/Database/Agents.hs14
-rw-r--r--haskell/src/SpaceTraders/Database/Contracts.hs23
-rw-r--r--haskell/src/SpaceTraders/Database/Ships.hs24
-rw-r--r--haskell/src/SpaceTraders/Database/Systems.hs6
-rw-r--r--haskell/src/SpaceTraders/Utils.hs38
6 files changed, 85 insertions, 50 deletions
diff --git a/haskell/src/SpaceTraders/APIClient/Contracts.hs b/haskell/src/SpaceTraders/APIClient/Contracts.hs
new file mode 100644
index 0000000..a62eb26
--- /dev/null
+++ b/haskell/src/SpaceTraders/APIClient/Contracts.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.APIClient.Contracts
+ ( myContracts
+ ) where
+
+import Network.HTTP.Simple
+
+import SpaceTraders
+import SpaceTraders.APIClient.Client
+import SpaceTraders.APIClient.Pagination
+import SpaceTraders.Database.Contracts
+import SpaceTraders.Model.Contract(Contract)
+
+myContracts :: SpaceTradersT (APIResponse [Contract])
+myContracts = do
+ listContracts' Pagination{limit=20, page=1, total=0}
+ where
+ listContracts' :: Pagination -> SpaceTradersT (APIResponse [Contract])
+ listContracts' p = do
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/my/contracts" :: SpaceTradersT (APIPaginatedResponse [Contract])
+ case resp of
+ Left e -> return $ Left e
+ Right (APIMessage r (Just p')) -> do
+ mapM_ setContract r
+ if (limit p' * page p' < total p') then listContracts' (nextPage p')
+ else Right <$> getContracts
+ _ -> undefined
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index 0557b1d..49ae11f 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -8,7 +8,6 @@ module SpaceTraders.Database.Agents
import Control.Monad.Reader
import Data.Aeson
-import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
@@ -16,17 +15,10 @@ 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))
+addAgent agent = execute "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
+getAgent = one_ "SELECT data FROM agents";
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))
+setAgent agent = execute "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 1084447..20170ba 100644
--- a/haskell/src/SpaceTraders/Database/Contracts.hs
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -9,7 +9,6 @@ module SpaceTraders.Database.Contracts
import Control.Monad.Reader
import Data.Aeson
-import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
@@ -17,24 +16,16 @@ 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))
+addContract contract = execute "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
+getContracts = query_ "SELECT data FROM contracts;"
-setContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
+setContract :: (HasDatabaseConn env, MonadFail m, 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
+ c <- count "SELECT count(id) FROM contracts WHERE data->>'contractId' = ?;" (S.Only $ contractId contract)
+ if c == 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)
+updateContract contract = execute "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 5dd6be0..5a2ab7c 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -7,10 +7,8 @@ module SpaceTraders.Database.Ships
, 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
@@ -18,24 +16,16 @@ 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)
+addShip ship = execute "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
+getShips = query_ "SELECT data FROM ships;"
-setShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
+setShip :: (HasDatabaseConn env, MonadFail m, 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
+ c <- count "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship)
+ if c == 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)
+updateShip ship = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
diff --git a/haskell/src/SpaceTraders/Database/Systems.hs b/haskell/src/SpaceTraders/Database/Systems.hs
index d3d19c7..07749be 100644
--- a/haskell/src/SpaceTraders/Database/Systems.hs
+++ b/haskell/src/SpaceTraders/Database/Systems.hs
@@ -7,7 +7,6 @@ module SpaceTraders.Database.Systems
import Control.Monad.Reader
import Data.Aeson
-import Data.Maybe
import qualified Database.SQLite.Simple as S
import SpaceTraders
@@ -21,7 +20,4 @@ addSystems systems = do
liftIO $ S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems
getSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [System]
-getSystems = do
- env <- ask
- ret <- liftIO $ S.query_ (getConn env) "SELECT data FROM systems;"
- return . catMaybes $ map (decodeText . head) ret
+getSystems = query_ "SELECT data FROM systems;"
diff --git a/haskell/src/SpaceTraders/Utils.hs b/haskell/src/SpaceTraders/Utils.hs
index 12bfd6a..f78fda1 100644
--- a/haskell/src/SpaceTraders/Utils.hs
+++ b/haskell/src/SpaceTraders/Utils.hs
@@ -1,22 +1,58 @@
module SpaceTraders.Utils
- ( decodeText
+ ( count
+ , decodeText
+ , execute
, fromJSONValue
, int2ByteString
+ , one_
+ , query
+ , query_
) where
+import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Internal as B
+import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
+import qualified Database.SQLite.Simple as S
+
+import SpaceTraders
decodeText :: FromJSON a => T.Text -> Maybe a
decodeText = decode . B.toLazyByteString . T.encodeUtf8Builder
+execute :: (HasDatabaseConn env, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m ()
+execute q t = do
+ env <- ask
+ liftIO $ S.execute (getConn env) q t
+
fromJSONValue :: FromJSON a => Value -> Either String a
fromJSONValue = parseEither parseJSON
int2ByteString :: Int -> B.ByteString
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
+ ret <- liftIO $ S.query (getConn env) q t
+ return . catMaybes $ map (decodeText . head) ret
+
+query_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m [b]
+query_ q = do
+ env <- ask
+ ret <- liftIO $ S.query_ (getConn env) q
+ return . catMaybes $ map (decodeText . head) ret