summaryrefslogtreecommitdiff
path: root/haskell/src/SpaceTraders
diff options
context:
space:
mode:
authorJulien Dessaux2024-03-22 01:13:34 +0100
committerJulien Dessaux2024-03-27 15:21:37 +0100
commit7e27a0a7eada373780a9757fd89f70d4d911d69a (patch)
tree8b660bde99d5f9b4ae4f9e9caea4b51f19931dbe /haskell/src/SpaceTraders
parent[node] begin the great typescript rewrite (diff)
downloadspacetraders-7e27a0a7eada373780a9757fd89f70d4d911d69a.tar.gz
spacetraders-7e27a0a7eada373780a9757fd89f70d4d911d69a.tar.bz2
spacetraders-7e27a0a7eada373780a9757fd89f70d4d911d69a.zip
[haskell] refactoring
Diffstat (limited to '')
-rw-r--r--haskell/src/SpaceTraders.hs19
-rw-r--r--haskell/src/SpaceTraders/APIClient/Agent.hs39
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs50
-rw-r--r--haskell/src/SpaceTraders/APIClient/Contracts.hs16
-rw-r--r--haskell/src/SpaceTraders/APIClient/Errors.hs31
-rw-r--r--haskell/src/SpaceTraders/APIClient/Pagination.hs9
-rw-r--r--haskell/src/SpaceTraders/APIClient/Ships.hs35
-rw-r--r--haskell/src/SpaceTraders/APIClient/Systems.hs22
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs49
-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
-rw-r--r--haskell/src/SpaceTraders/Model/Agent.hs17
-rw-r--r--haskell/src/SpaceTraders/Model/Cargo.hs13
-rw-r--r--haskell/src/SpaceTraders/Model/Fuel.hs13
-rw-r--r--haskell/src/SpaceTraders/Model/Inventory.hs15
-rw-r--r--haskell/src/SpaceTraders/Model/Nav.hs19
-rw-r--r--haskell/src/SpaceTraders/Model/Ship.hs27
-rw-r--r--haskell/src/SpaceTraders/Model/System.hs21
-rw-r--r--haskell/src/SpaceTraders/Model/Waypoint.hs17
-rw-r--r--haskell/src/SpaceTraders/Utils.hs26
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