adyxax/spacetraders
1
0
Fork 0
Code Issues Activity

[haskell] abstracted away common database access patterns

Browse source
This commit is contained in:
Julien Dessaux 2023-07-21 00:01:02 +02:00
parent 24f6c8eb90
commit dcd0a7a9b2
Signed by: adyxax
GPG key ID: F92E51B86E07177E
6 changed files with 85 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
haskell/src/SpaceTraders/APIClient/Contracts.hs Normal file
View file

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

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

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

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

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

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

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

6
haskell/src/SpaceTraders/Database/Systems.hs
View file

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

38
haskell/src/SpaceTraders/Utils.hs
View file

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