diff options
Diffstat (limited to 'haskell/src')
24 files changed, 274 insertions, 300 deletions
diff --git a/haskell/src/SpaceTraders.hs b/haskell/src/SpaceTraders.hs index 5bd7526..19d55d0 100644 --- a/haskell/src/SpaceTraders.hs +++ b/haskell/src/SpaceTraders.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} - module SpaceTraders ( SpaceTradersT , microSinceEpoch @@ -16,13 +13,13 @@ module SpaceTraders , liftIO ) where -import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.IORef -import Data.Time.Clock -import Data.Time.Clock.POSIX +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.IORef +import Data.Time.Clock +import Data.Time.Clock.POSIX import qualified Database.SQLite.Simple as S -import Network.HTTP.Simple +import Network.HTTP.Simple type SpaceTradersT a = ReaderT Env IO a @@ -39,9 +36,9 @@ microSinceEpoch = do t <- getCurrentTime return $ floor . (1e6 *) . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds t -data Env = Env { envConn :: S.Connection +data Env = Env { envConn :: S.Connection , envLastAPICall :: IORef Integer - , envRequest :: Request } + , envRequest :: Request } class HasDatabaseConn a where getConn :: a -> S.Connection diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs index 7b367f6..cdd04e6 100644 --- a/haskell/src/SpaceTraders/APIClient/Agent.hs +++ b/haskell/src/SpaceTraders/APIClient/Agent.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Agent @@ -8,28 +8,33 @@ module SpaceTraders.APIClient.Agent , register ) where -import Control.Monad.Reader -import Data.Aeson -import GHC.Generics -import qualified Data.Text as T -import Network.HTTP.Simple +import Control.Monad.Reader +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics +import Network.HTTP.Simple -import SpaceTraders -import SpaceTraders.APIClient.Client -import SpaceTraders.Model.Agent(Agent) -import SpaceTraders.Model.Ship(Ship) -import SpaceTraders.Model.Contract +import SpaceTraders +import SpaceTraders.APIClient.Client +import SpaceTraders.Database.Agents +import SpaceTraders.Model.Agent (Agent) +import SpaceTraders.Model.Contract +import SpaceTraders.Model.Ship (Ship) myAgent :: SpaceTradersT (APIResponse Agent) -myAgent = send $ setRequestPath "/v2/my/agent" +myAgent = do + a@(Right ag) <- send $ setRequestPath "/v2/my/agent" + setAgent ag + return a + data RegisterRequest = RegisterRequest { faction :: T.Text - , symbol :: T.Text + , symbol :: T.Text } deriving (ToJSON, Generic, Show) -data RegisterMessage = RegisterMessage { agent :: Agent +data RegisterMessage = RegisterMessage { agent :: Agent , contract :: Contract - , ship :: Ship - , token :: T.Text + , ship :: Ship + , token :: T.Text } deriving (FromJSON, Generic, Show) register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage) diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs index 9229813..7f28fde 100644 --- a/haskell/src/SpaceTraders/APIClient/Client.hs +++ b/haskell/src/SpaceTraders/APIClient/Client.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Client ( APIMessage(..) @@ -11,27 +11,27 @@ module SpaceTraders.APIClient.Client , tokenReq ) where -import Control.Concurrent.Thread.Delay -import Control.Monad -import Control.Monad.Reader -import Data.Aeson -import Data.IORef -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Simple -import Network.HTTP.Types.Status -import System.Directory -import System.Environment -import System.Posix.Process +import Control.Concurrent.Thread.Delay +import Control.Monad +import Control.Monad.Reader +import Data.Aeson +import Data.IORef +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Simple +import Network.HTTP.Types.Status +import System.Directory +import System.Environment +import System.Posix.Process -import SpaceTraders -import SpaceTraders.APIClient.Errors -import SpaceTraders.APIClient.Pagination -import SpaceTraders.Utils +import SpaceTraders +import SpaceTraders.APIClient.Errors +import SpaceTraders.APIClient.Pagination +import SpaceTraders.Utils -data FromJSON a => APIMessage a = APIMessage { messageData :: a - , messagePagination :: Maybe Pagination - } deriving (Show) +data APIMessage a = APIMessage { messageData :: a + , messagePagination :: Maybe Pagination + } deriving (Show) instance FromJSON a => FromJSON (APIMessage a) where parseJSON = withObject "APIMessage" $ \o -> APIMessage <$> o .: "data" @@ -45,7 +45,7 @@ defaultReq = setRequestHost "api.spacetraders.io" $ setRequestPort 443 $ setRequestSecure True $ setRequestHeader "Content-Type" ["application/json"] - $ defaultRequest + defaultRequest tokenReq :: T.Text -> Request tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] defaultReq @@ -54,7 +54,7 @@ send :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => (Request - send requestBuilder = do response <- sendPaginated Nothing requestBuilder case response of - Left e -> return $ Left e + Left e -> return $ Left e Right (APIMessage d _) -> return $ Right d sendPaginated :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Maybe Pagination -> (Request -> Request) -> m (APIPaginatedResponse a) @@ -63,7 +63,7 @@ sendPaginated pagination requestBuilder = do let request = requestBuilder $ getRequest env request' = case pagination of Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)] - $ request + request Nothing -> request sendPaginated' request' where @@ -82,12 +82,12 @@ sendPaginated pagination requestBuilder = do body = getResponseBody response if status >= 200 && status <= 299 then case eitherDecode body of - Left e -> return . Left $ APIError (-1000) (T.pack $ concat ["Error decoding JSON APIMessage: ", e]) Null + Left e -> return . Left $ APIError (-1000) (T.pack $ "Error decoding JSON APIMessage: " ++ e) Null Right r -> return $ Right r else case eitherDecode body of Left e -> return . Left $ APIError (-status) (T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body]) Null Right (APIRateLimit r) -> do - liftIO $ delay (1_000_000 * (round $ retryAfter r)) + liftIO $ delay (1_000_000 * round (retryAfter r)) sendPaginated' request Right (APIResetHappened _) -> liftIO $ do removeFile "spacetraders.db" diff --git a/haskell/src/SpaceTraders/APIClient/Contracts.hs b/haskell/src/SpaceTraders/APIClient/Contracts.hs index a62eb26..9c5bf02 100644 --- a/haskell/src/SpaceTraders/APIClient/Contracts.hs +++ b/haskell/src/SpaceTraders/APIClient/Contracts.hs @@ -1,18 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Contracts ( myContracts ) where -import Network.HTTP.Simple +import Network.HTTP.Simple -import SpaceTraders -import SpaceTraders.APIClient.Client -import SpaceTraders.APIClient.Pagination -import SpaceTraders.Database.Contracts -import SpaceTraders.Model.Contract(Contract) +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 @@ -25,6 +23,6 @@ myContracts = do 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') + if limit p' * page p' < total p' then listContracts' (nextPage p') else Right <$> getContracts _ -> undefined diff --git a/haskell/src/SpaceTraders/APIClient/Errors.hs b/haskell/src/SpaceTraders/APIClient/Errors.hs index 2b74784..eb87daa 100644 --- a/haskell/src/SpaceTraders/APIClient/Errors.hs +++ b/haskell/src/SpaceTraders/APIClient/Errors.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Errors @@ -8,11 +8,11 @@ module SpaceTraders.APIClient.Errors , ResetHappened(..) ) where -import Control.Exception -import Data.Aeson -import Data.Time -import qualified Data.Text as T -import GHC.Generics +import Control.Exception +import Data.Aeson +import qualified Data.Text as T +import Data.Time +import GHC.Generics data APIError = APIError Int T.Text Value | APIRateLimit RateLimit @@ -27,16 +27,15 @@ instance FromJSON APIError where case code of 401 -> APIResetHappened <$> parseJSON d 429 -> APIRateLimit <$> parseJSON d - _ -> APIError <$> pure code - <*> e .: "message" - <*> pure d + _ -> APIError code <$> e .: "message" + <*> pure d -data RateLimit = RateLimit { limitBurst :: Int +data RateLimit = RateLimit { limitBurst :: Int , limitPerSecond :: Int - , rateLimitType :: T.Text - , remaining :: Int - , reset :: UTCTime - , retryAfter :: Double + , rateLimitType :: T.Text + , remaining :: Int + , reset :: UTCTime + , retryAfter :: Double } deriving Show instance FromJSON RateLimit where parseJSON = withObject "RateLimit" $ \o -> @@ -47,6 +46,6 @@ instance FromJSON RateLimit where <*> o .: "reset" <*> o .: "retryAfter" -data ResetHappened = ResetHappened { actual :: T.Text +data ResetHappened = ResetHappened { actual :: T.Text , expected :: T.Text } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/APIClient/Pagination.hs b/haskell/src/SpaceTraders/APIClient/Pagination.hs index bb9bcd1..e6a2d44 100644 --- a/haskell/src/SpaceTraders/APIClient/Pagination.hs +++ b/haskell/src/SpaceTraders/APIClient/Pagination.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.APIClient.Pagination ( Pagination(..) , nextPage ) where -import Data.Aeson -import GHC.Generics +import Data.Aeson +import GHC.Generics data Pagination = Pagination { limit :: Int - , page :: Int + , page :: Int , total :: Int } deriving (FromJSON, Generic, Show) diff --git a/haskell/src/SpaceTraders/APIClient/Ships.hs b/haskell/src/SpaceTraders/APIClient/Ships.hs index 87c5ecb..4ce9371 100644 --- a/haskell/src/SpaceTraders/APIClient/Ships.hs +++ b/haskell/src/SpaceTraders/APIClient/Ships.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Ships @@ -8,19 +8,20 @@ module SpaceTraders.APIClient.Ships , orbit ) where -import Data.Aeson.Types -import qualified Data.Text.Encoding as T -import GHC.Generics -import Network.HTTP.Simple +import Data.Aeson.Types +import qualified Data.Text.Encoding as T +import GHC.Generics +import Network.HTTP.Simple -import SpaceTraders -import SpaceTraders.APIClient.Client -import SpaceTraders.APIClient.Pagination -import SpaceTraders.Database.Ships -import SpaceTraders.Model.Nav -import SpaceTraders.Model.Ship +import SpaceTraders +import SpaceTraders.APIClient.Client +import SpaceTraders.APIClient.Pagination +import SpaceTraders.Database.Ships +import SpaceTraders.Model.Nav +import SpaceTraders.Model.Ship + +newtype NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show) -data NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show) dock :: Ship -> SpaceTradersT (APIResponse Ship) dock ship = do resp <- send $ setRequestPath (T.encodeUtf8 $ mconcat ["/v2/my/ships/", symbol ship, "/dock"]) @@ -29,7 +30,7 @@ dock ship = do Left e -> return $ Left e Right (NavMessage n) -> do let s = ship{SpaceTraders.Model.Ship.nav=n} - updateShip s + setShip s return $ Right s myShips :: SpaceTradersT (APIResponse [Ship]) @@ -43,8 +44,8 @@ myShips = do Left e -> return $ Left e Right (APIMessage r (Just p')) -> do mapM_ setShip r - if (limit p' * page p' < total p') then listShips' (nextPage p') - else Right <$> getShips + if limit p' * page p' < total p' then listShips' (nextPage p') + else Right <$> getShips _ -> undefined orbit :: Ship -> SpaceTradersT (APIResponse Ship) @@ -55,5 +56,5 @@ orbit ship = do Left e -> return $ Left e Right (NavMessage n) -> do let s = ship{SpaceTraders.Model.Ship.nav=n} - updateShip s + setShip s return $ Right s diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs index eb15b4d..e2690ac 100644 --- a/haskell/src/SpaceTraders/APIClient/Systems.hs +++ b/haskell/src/SpaceTraders/APIClient/Systems.hs @@ -1,24 +1,22 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Systems ( initSystems ) where -import Control.Exception -import Network.HTTP.Simple +import Control.Exception +import Network.HTTP.Simple -import SpaceTraders -import SpaceTraders.APIClient.Client -import SpaceTraders.APIClient.Pagination -import SpaceTraders.Database.Systems -import SpaceTraders.Model.System(System) +import SpaceTraders +import SpaceTraders.APIClient.Client +import SpaceTraders.APIClient.Pagination +import SpaceTraders.Database.Systems +import SpaceTraders.Model.System (System) initSystems :: SpaceTradersT (APIResponse [System]) initSystems = do s <- getSystems - listSystems' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0} + listSystems' Pagination{limit=20, page=(length s `div` 20) + 1, total=0} where listSystems' :: Pagination -> SpaceTradersT (APIResponse [System]) listSystems' p = do @@ -27,6 +25,6 @@ initSystems = do Left e -> throw e Right (APIMessage r (Just p')) -> do addSystems r - if (limit p' * page p' < total p') then listSystems' (nextPage p') - else Right <$> getSystems + if limit p' * page p' < total p' then listSystems' (nextPage p') + else Right <$> getSystems _ -> undefined diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs index 6641cf8..be3dbd2 100644 --- a/haskell/src/SpaceTraders/Automation/Init.hs +++ b/haskell/src/SpaceTraders/Automation/Init.hs @@ -5,23 +5,24 @@ module SpaceTraders.Automation.Init , initST ) where -import Control.Exception -import Control.Monad.Reader -import qualified Database.SQLite.Simple as S -import qualified Data.Text as T -import System.Directory +import Control.Exception +import Control.Monad.Error.Class +import Control.Monad.Reader +import qualified Data.Text as T +import qualified Database.SQLite.Simple as S +import System.Directory -import SpaceTraders -import SpaceTraders.APIClient.Agent -import SpaceTraders.APIClient.Client -import SpaceTraders.APIClient.Contracts -import SpaceTraders.APIClient.Errors -import SpaceTraders.APIClient.Ships -import SpaceTraders.Database -import SpaceTraders.Database.Agents -import SpaceTraders.Database.Contracts -import SpaceTraders.Database.Ships -import SpaceTraders.Database.Tokens +import SpaceTraders +import SpaceTraders.APIClient.Agent +import SpaceTraders.APIClient.Client +import SpaceTraders.APIClient.Contracts +import SpaceTraders.APIClient.Errors +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 () deinitST env = do @@ -30,7 +31,7 @@ deinitST env = do initST :: IO Env initST = do conn <- open - t <- runReaderT getToken conn `catch` handleNoToken conn + t <- runReaderT getToken conn `catchError` handleNoToken conn env <- newEnv conn (tokenReq t) ma <- runReaderT getAgent conn -- We compare the agent state in the database ma' <- runSpaceTradersT myAgent env -- with the one on the servers @@ -42,21 +43,21 @@ initST = do _ <- runReaderT myContracts env -- refresh contracts _ <- runReaderT myShips env -- refresh ships runReaderT (setAgent ma'') conn -- store the fresh agent state - return $ env + return env where - handleNoToken :: S.Connection -> SomeException -> IO T.Text + handleNoToken :: S.Connection -> IOException -> IO T.Text handleNoToken conn _ = newEnv conn defaultReq >>= runReaderT registerST -registerST :: SpaceTradersT (T.Text) +registerST :: SpaceTradersT T.Text registerST = do - r <- register "ADYXAX-HS" "COSMIC" + r <- register "ADYXAX-HS-6" "COSMIC" case r of Right r' -> do let t = token r' addToken t - addAgent $ agent r' - addContract $ contract r' - addShip $ ship r' + setAgent $ agent r' + setContract $ contract r' + setShip $ ship r' return t Left e' -> throw e' 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 diff --git a/haskell/src/SpaceTraders/Model/Agent.hs b/haskell/src/SpaceTraders/Model/Agent.hs index 01c08a0..a03d47f 100644 --- a/haskell/src/SpaceTraders/Model/Agent.hs +++ b/haskell/src/SpaceTraders/Model/Agent.hs @@ -1,19 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Agent ( Agent(..) ) where -import Data.Aeson -import GHC.Generics -import qualified Data.Text as T +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics -data Agent = Agent { accountId :: T.Text - , credits :: Integer +data Agent = Agent { accountId :: T.Text + , credits :: Integer --, faction :: Faction - , headquarters :: T.Text + , headquarters :: T.Text , startingFaction :: T.Text - , symbol :: T.Text + , symbol :: T.Text } deriving (Eq, FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/Cargo.hs b/haskell/src/SpaceTraders/Model/Cargo.hs index 126fc63..232627c 100644 --- a/haskell/src/SpaceTraders/Model/Cargo.hs +++ b/haskell/src/SpaceTraders/Model/Cargo.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Cargo ( Cargo(..) ) where -import Data.Aeson -import GHC.Generics +import Data.Aeson +import GHC.Generics -import SpaceTraders.Model.Inventory(Inventory) +import SpaceTraders.Model.Inventory (Inventory) -data Cargo = Cargo { capacity :: Int +data Cargo = Cargo { capacity :: Int , inventory :: [Inventory] - , units :: Int + , units :: Int } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/Fuel.hs b/haskell/src/SpaceTraders/Model/Fuel.hs index ca17ebb..99c4709 100644 --- a/haskell/src/SpaceTraders/Model/Fuel.hs +++ b/haskell/src/SpaceTraders/Model/Fuel.hs @@ -1,21 +1,20 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Fuel ( Consumed(..) , Fuel(..) ) where -import Data.Aeson -import Data.Time -import GHC.Generics +import Data.Aeson +import Data.Time +import GHC.Generics -data Consumed = Consumed { amount :: Int +data Consumed = Consumed { amount :: Int , timestamp :: UTCTime } deriving (FromJSON, Generic, Show, ToJSON) data Fuel = Fuel { capacity :: Int , consumed :: Consumed - , current :: Int + , current :: Int } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/Inventory.hs b/haskell/src/SpaceTraders/Model/Inventory.hs index db74ddb..4faea52 100644 --- a/haskell/src/SpaceTraders/Model/Inventory.hs +++ b/haskell/src/SpaceTraders/Model/Inventory.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Inventory ( Inventory(..) ) where -import Data.Aeson -import GHC.Generics -import qualified Data.Text as T +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics data Inventory = Inventory { description :: T.Text - , name :: T.Text - , symbol :: T.Text - , units :: Int + , name :: T.Text + , symbol :: T.Text + , units :: Int } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/Nav.hs b/haskell/src/SpaceTraders/Model/Nav.hs index 1c23ca1..8550836 100644 --- a/haskell/src/SpaceTraders/Model/Nav.hs +++ b/haskell/src/SpaceTraders/Model/Nav.hs @@ -1,20 +1,19 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Nav ( Nav(..) ) where -import Data.Aeson -import GHC.Generics -import qualified Data.Text as T +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics -import SpaceTraders.Model.Route +import SpaceTraders.Model.Route -data Nav = Nav { flightMode :: T.Text - , route :: Route - , status :: T.Text - , systemSymbol :: T.Text +data Nav = Nav { flightMode :: T.Text + , route :: Route + , status :: T.Text + , systemSymbol :: T.Text , waypointSymbol :: T.Text } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/Ship.hs b/haskell/src/SpaceTraders/Model/Ship.hs index 2ec54f1..522276c 100644 --- a/haskell/src/SpaceTraders/Model/Ship.hs +++ b/haskell/src/SpaceTraders/Model/Ship.hs @@ -1,34 +1,33 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module SpaceTraders.Model.Ship ( Ship(..) ) where -import Data.Aeson -import GHC.Generics -import qualified Data.Text as T +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics -import SpaceTraders.Model.Cargo -import SpaceTraders.Model.Fuel -import SpaceTraders.Model.Nav +import SpaceTraders.Model.Cargo +import SpaceTraders.Model.Fuel +import SpaceTraders.Model.Nav -data Ship = Ship { cargo :: Cargo +data Ship = Ship { cargo :: Cargo , cooldown :: Cooldown --, crew :: Crew --, engine :: Engine --, frame :: Frame - , fuel :: Fuel + , fuel :: Fuel --, modules :: [Module] --, mounts :: [Mount] - , nav :: Nav + , nav :: Nav --, reactor :: Reactor --, registration :: Registration - , symbol :: T.Text + , symbol :: T.Text } deriving (FromJSON, Generic, Show, ToJSON) -data Cooldown = Cooldown { shipSymbol :: T.Text - , totalSeconds :: Int +data Cooldown = Cooldown { shipSymbol :: T.Text + , totalSeconds :: Int , remainingSeconds :: Int } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Model/System.hs b/haskell/src/SpaceTraders/Model/System.hs index 0092ef5..a673b56 100644 --- a/haskell/src/SpaceTraders/Model/System.hs +++ b/haskell/src/SpaceTraders/Model/System.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.Model.System ( System(..) ) where -import Data.Aeson -import qualified Data.Text as T -import GHC.Generics +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics -import SpaceTraders.Model.Waypoint(Waypoint) +import SpaceTraders.Model.Waypoint (Waypoint) data System = System { sectorSymbol :: T.Text - , symbol :: T.Text - , systemType :: T.Text - , x :: Int - , y :: Int - , waypoints :: [Waypoint] + , symbol :: T.Text + , systemType :: T.Text + , x :: Int + , y :: Int + , waypoints :: [Waypoint] --, factions :: [Faction] } deriving (Generic, Show) instance FromJSON System where diff --git a/haskell/src/SpaceTraders/Model/Waypoint.hs b/haskell/src/SpaceTraders/Model/Waypoint.hs index d80dc7a..9f0776c 100644 --- a/haskell/src/SpaceTraders/Model/Waypoint.hs +++ b/haskell/src/SpaceTraders/Model/Waypoint.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.Model.Waypoint ( Waypoint(..) ) where -import Data.Aeson -import qualified Data.Text as T -import GHC.Generics +import Data.Aeson +import qualified Data.Text as T +import GHC.Generics -data Waypoint = Waypoint { orbits :: Maybe T.Text - , symbol :: T.Text +data Waypoint = Waypoint { orbits :: Maybe T.Text + , symbol :: T.Text , waypointType :: T.Text - , x :: Int - , y :: Int + , x :: Int + , y :: Int } deriving (Generic, Show) instance FromJSON Waypoint where parseJSON = withObject "Waypoint" $ \o -> diff --git a/haskell/src/SpaceTraders/Utils.hs b/haskell/src/SpaceTraders/Utils.hs index 2f54a81..d7eef46 100644 --- a/haskell/src/SpaceTraders/Utils.hs +++ b/haskell/src/SpaceTraders/Utils.hs @@ -9,18 +9,18 @@ module SpaceTraders.Utils , 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 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 Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Database.SQLite.Simple as S -import SpaceTraders +import SpaceTraders count :: (HasDatabaseConn env, MonadFail m, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m Int count q t = do @@ -43,16 +43,16 @@ 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 +one_ q = head <$> query_ q 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 + return $ mapMaybe (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 + return $ mapMaybe (decodeText . head) ret |