From dcd0a7a9b2612f383c1f627c72c27868c367058d Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Fri, 21 Jul 2023 00:01:02 +0200 Subject: [haskell] abstracted away common database access patterns --- haskell/src/SpaceTraders/APIClient/Contracts.hs | 30 +++++++++++++++++++ haskell/src/SpaceTraders/Database/Agents.hs | 14 ++------- haskell/src/SpaceTraders/Database/Contracts.hs | 23 +++++---------- haskell/src/SpaceTraders/Database/Ships.hs | 24 +++++----------- haskell/src/SpaceTraders/Database/Systems.hs | 6 +--- haskell/src/SpaceTraders/Utils.hs | 38 ++++++++++++++++++++++++- 6 files changed, 85 insertions(+), 50 deletions(-) create mode 100644 haskell/src/SpaceTraders/APIClient/Contracts.hs (limited to 'haskell') 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 -- cgit v1.2.3