summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders/Database
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--haskell/src/SpaceTraders/Database.hs18
-rw-r--r--haskell/src/SpaceTraders/Database/Agents.hs28
-rw-r--r--haskell/src/SpaceTraders/Database/Contracts.hs33
-rw-r--r--haskell/src/SpaceTraders/Database/Ships.hs33
-rw-r--r--haskell/src/SpaceTraders/Database/Systems.hs12
-rw-r--r--haskell/src/SpaceTraders/Database/Tokens.hs12
6 files changed, 60 insertions, 76 deletions
diff --git a/haskell/src/SpaceTraders/Database.hs b/haskell/src/SpaceTraders/Database.hs
index 66ff893..0166da9 100644
--- a/haskell/src/SpaceTraders/Database.hs
+++ b/haskell/src/SpaceTraders/Database.hs
@@ -1,24 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
module SpaceTraders.Database
( close
, open
) where
-import Control.Exception
-import qualified Data.ByteString as B
-import Data.FileEmbed
+import Control.Exception
+import qualified Data.ByteString as B
+import Data.FileEmbed
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
migrations :: [B.ByteString]
migrations = [ $(embedFile "src/SpaceTraders/Database/000_init.sql") ]
close :: S.Connection -> IO ()
-close conn = S.close conn
+close = S.close
open :: IO S.Connection
open = do
@@ -27,7 +27,7 @@ open = do
S.execute_ conn "PRAGMA journal_mode = WAL;"
S.withTransaction conn $ do
version <- getSchemaVersion conn `catch` defaultVersion
- mapM_ (S.execute_ conn) $ S.Query <$> (filter (/= "\n") . concat . map ((T.splitOn ";") . T.decodeUtf8) $ drop version migrations)
+ mapM_ (S.execute_ conn) $ S.Query <$> concatMap (filter (/= "\n") . T.splitOn ";" . T.decodeUtf8) (drop version migrations)
S.execute_ conn "DELETE FROM schema_version;"
S.execute conn "INSERT INTO schema_version (version) VALUES (?);" (S.Only $ length migrations)
return conn
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index 49ae11f..d596d79 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -1,24 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Agents
- ( addAgent
- , getAgent
+ ( getAgent
, setAgent
) where
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import Control.Monad.Error.Class
+import Control.Monad.Reader
+import Data.Aeson
+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 = execute "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))
+import SpaceTraders
+import SpaceTraders.Model.Agent
+import SpaceTraders.Utils
getAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m Agent
-getAgent = one_ "SELECT data FROM agents";
+getAgent = one_ "SELECT data FROM agents"; -- we only support one agent at a time
-setAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
-setAgent agent = execute "UPDATE agents SET data = json(?);" (S.Only (encode agent))
+setAgent :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Agent -> m ()
+setAgent agent = updateAgent `catchError` addAgent
+ where
+ addAgent _ = execute "INSERT INTO agents(data) VALUES (json(?));" (S.Only $ encode agent)
+ updateAgent = 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 20170ba..7cebc37 100644
--- a/haskell/src/SpaceTraders/Database/Contracts.hs
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -1,31 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Contracts
- ( addContract
- , getContracts
+ ( getContracts
, setContract
- , updateContract
) where
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import Control.Monad.Error.Class
+import Control.Monad.Reader
+import Data.Aeson
+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 = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
+import SpaceTraders
+import SpaceTraders.Model.Contract
+import SpaceTraders.Utils
getContracts :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Contract]
getContracts = query_ "SELECT data FROM contracts;"
-setContract :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Contract -> m ()
-setContract contract = do
- 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 = execute "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId contract)
+setContract :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Contract -> m ()
+setContract contract = updateContract `catchError` addContract
+ where
+ addContract _ = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
+ updateContract = 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 5a2ab7c..eabf429 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -1,31 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Ships
- ( addShip
- , getShips
+ ( getShips
, setShip
- , updateShip
) where
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import Control.Monad.Error.Class
+import Control.Monad.Reader
+import Data.Aeson
+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 = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
+import SpaceTraders
+import SpaceTraders.Model.Ship
+import SpaceTraders.Utils
getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship]
getShips = query_ "SELECT data FROM ships;"
-setShip :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Ship -> m ()
-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
-
-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)
+setShip :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Ship -> m ()
+setShip ship = updateShip `catchError` addShip
+ where
+ addShip _ = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
+ updateShip = 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 07749be..7c43caf 100644
--- a/haskell/src/SpaceTraders/Database/Systems.hs
+++ b/haskell/src/SpaceTraders/Database/Systems.hs
@@ -5,13 +5,13 @@ module SpaceTraders.Database.Systems
, getSystems
) where
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import Control.Monad.Reader
+import Data.Aeson
+import qualified Database.SQLite.Simple as S
-import SpaceTraders
-import SpaceTraders.Model.System
-import SpaceTraders.Utils
+import SpaceTraders
+import SpaceTraders.Model.System
+import SpaceTraders.Utils
addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m ()
addSystems systems = do
diff --git a/haskell/src/SpaceTraders/Database/Tokens.hs b/haskell/src/SpaceTraders/Database/Tokens.hs
index e99e49e..0a29a55 100644
--- a/haskell/src/SpaceTraders/Database/Tokens.hs
+++ b/haskell/src/SpaceTraders/Database/Tokens.hs
@@ -1,21 +1,19 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
module SpaceTraders.Database.Tokens
( addToken
, getToken
) where
-import Control.Monad.Reader
+import Control.Monad.Reader
+import qualified Data.Text as T
import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
-import SpaceTraders
+import SpaceTraders
+import SpaceTraders.Utils
addToken :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => T.Text -> m ()
-addToken value = do
- env <- ask
- liftIO $ S.execute (getConn env) "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
+addToken value = execute "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text
getToken = do
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-26 16:20:33 +0000