adyxax/spacetraders
1
0
Fork 0
Code Issues Activity

[haskell] refactoring

Browse source
This commit is contained in:
Julien Dessaux 2024-03-22 01:13:34 +01:00
parent d668eac4a6
commit 7e27a0a7ea
Signed by: adyxax
GPG key ID: F92E51B86E07177E
26 changed files with 289 additions and 311 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
haskell/app/Main.hs
View file

@ -1,11 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where module Main (main) where
import SpaceTraders import SpaceTraders
import SpaceTraders.Automation.Init import SpaceTraders.APIClient.Agent
import SpaceTraders.APIClient.Ships import SpaceTraders.APIClient.Contracts
import SpaceTraders.APIClient.Systems import SpaceTraders.APIClient.Ships
import SpaceTraders.Automation.Init
main :: IO () main :: IO ()
main = do main = do
@ -15,7 +14,11 @@ main = do
where where
main' :: SpaceTradersT () main' :: SpaceTradersT ()
main' = do main' = do
_ <- initSystems -- refresh our core objects
_ <- myAgent
_ <- myContracts
(Right ships) <- myShips -- work around to fetch the initial probe (Right ships) <- myShips -- work around to fetch the initial probe
_ <- orbit (head ships) let cmdShip = head ships
(Right t) <- orbit cmdShip
liftIO $ print t
return () return ()

19
haskell/src/SpaceTraders.hs
View file

@ -1,6 +1,3 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders module SpaceTraders
( SpaceTradersT ( SpaceTradersT
, microSinceEpoch , microSinceEpoch
@ -16,13 +13,13 @@ module SpaceTraders
, liftIO , liftIO
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
import Data.IORef import Data.IORef
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import qualified Database.SQLite.Simple as S import qualified Database.SQLite.Simple as S
import Network.HTTP.Simple import Network.HTTP.Simple
type SpaceTradersT a = ReaderT Env IO a type SpaceTradersT a = ReaderT Env IO a
@ -39,9 +36,9 @@ microSinceEpoch = do
t <- getCurrentTime t <- getCurrentTime
return $ floor . (1e6 *) . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds t return $ floor . (1e6 *) . nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds t
data Env = Env { envConn :: S.Connection data Env = Env { envConn :: S.Connection
, envLastAPICall :: IORef Integer , envLastAPICall :: IORef Integer
, envRequest :: Request } , envRequest :: Request }
class HasDatabaseConn a where class HasDatabaseConn a where
getConn :: a -> S.Connection getConn :: a -> S.Connection

39
haskell/src/SpaceTraders/APIClient/Agent.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Agent module SpaceTraders.APIClient.Agent
@ -8,28 +8,33 @@ module SpaceTraders.APIClient.Agent
, register , register
) where ) where
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson import Data.Aeson
import GHC.Generics import qualified Data.Text as T
import qualified Data.Text as T import GHC.Generics
import Network.HTTP.Simple import Network.HTTP.Simple
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Client import SpaceTraders.APIClient.Client
import SpaceTraders.Model.Agent(Agent) import SpaceTraders.Database.Agents
import SpaceTraders.Model.Ship(Ship) import SpaceTraders.Model.Agent (Agent)
import SpaceTraders.Model.Contract import SpaceTraders.Model.Contract
import SpaceTraders.Model.Ship (Ship)
myAgent :: SpaceTradersT (APIResponse Agent) 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 data RegisterRequest = RegisterRequest { faction :: T.Text
, symbol :: T.Text , symbol :: T.Text
} deriving (ToJSON, Generic, Show) } deriving (ToJSON, Generic, Show)
data RegisterMessage = RegisterMessage { agent :: Agent data RegisterMessage = RegisterMessage { agent :: Agent
, contract :: Contract , contract :: Contract
, ship :: Ship , ship :: Ship
, token :: T.Text , token :: T.Text
} deriving (FromJSON, Generic, Show) } deriving (FromJSON, Generic, Show)
register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage) register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage)

50
haskell/src/SpaceTraders/APIClient/Client.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Client module SpaceTraders.APIClient.Client
( APIMessage(..) ( APIMessage(..)
@ -11,27 +11,27 @@ module SpaceTraders.APIClient.Client
, tokenReq , tokenReq
) where ) where
import Control.Concurrent.Thread.Delay import Control.Concurrent.Thread.Delay
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson import Data.Aeson
import Data.IORef import Data.IORef
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import Network.HTTP.Simple import Network.HTTP.Simple
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.Posix.Process import System.Posix.Process
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Errors import SpaceTraders.APIClient.Errors
import SpaceTraders.APIClient.Pagination import SpaceTraders.APIClient.Pagination
import SpaceTraders.Utils import SpaceTraders.Utils
data FromJSON a => APIMessage a = APIMessage { messageData :: a data APIMessage a = APIMessage { messageData :: a
, messagePagination :: Maybe Pagination , messagePagination :: Maybe Pagination
} deriving (Show) } deriving (Show)
instance FromJSON a => FromJSON (APIMessage a) where instance FromJSON a => FromJSON (APIMessage a) where
parseJSON = withObject "APIMessage" $ \o -> parseJSON = withObject "APIMessage" $ \o ->
APIMessage <$> o .: "data" APIMessage <$> o .: "data"
@ -45,7 +45,7 @@ defaultReq = setRequestHost "api.spacetraders.io"
$ setRequestPort 443 $ setRequestPort 443
$ setRequestSecure True $ setRequestSecure True
$ setRequestHeader "Content-Type" ["application/json"] $ setRequestHeader "Content-Type" ["application/json"]
$ defaultRequest defaultRequest
tokenReq :: T.Text -> Request tokenReq :: T.Text -> Request
tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] defaultReq 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 send requestBuilder = do
response <- sendPaginated Nothing requestBuilder response <- sendPaginated Nothing requestBuilder
case response of case response of
Left e -> return $ Left e Left e -> return $ Left e
Right (APIMessage d _) -> return $ Right d Right (APIMessage d _) -> return $ Right d
sendPaginated :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Maybe Pagination -> (Request -> Request) -> m (APIPaginatedResponse a) 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 let request = requestBuilder $ getRequest env
request' = case pagination of request' = case pagination of
Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)] Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
$ request request
Nothing -> request Nothing -> request
sendPaginated' request' sendPaginated' request'
where where
@ -82,12 +82,12 @@ sendPaginated pagination requestBuilder = do
body = getResponseBody response body = getResponseBody response
if status >= 200 && status <= 299 if status >= 200 && status <= 299
then case eitherDecode body of 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 Right r -> return $ Right r
else case eitherDecode body of 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 Left e -> return . Left $ APIError (-status) (T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body]) Null
Right (APIRateLimit r) -> do Right (APIRateLimit r) -> do
liftIO $ delay (1_000_000 * (round $ retryAfter r)) liftIO $ delay (1_000_000 * round (retryAfter r))
sendPaginated' request sendPaginated' request
Right (APIResetHappened _) -> liftIO $ do Right (APIResetHappened _) -> liftIO $ do
removeFile "spacetraders.db" removeFile "spacetraders.db"

16
haskell/src/SpaceTraders/APIClient/Contracts.hs
View file

@ -1,18 +1,16 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Contracts module SpaceTraders.APIClient.Contracts
( myContracts ( myContracts
) where ) where
import Network.HTTP.Simple import Network.HTTP.Simple
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Client import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Contracts import SpaceTraders.Database.Contracts
import SpaceTraders.Model.Contract(Contract) import SpaceTraders.Model.Contract (Contract)
myContracts :: SpaceTradersT (APIResponse [Contract]) myContracts :: SpaceTradersT (APIResponse [Contract])
myContracts = do myContracts = do
@ -25,6 +23,6 @@ myContracts = do
Left e -> return $ Left e Left e -> return $ Left e
Right (APIMessage r (Just p')) -> do Right (APIMessage r (Just p')) -> do
mapM_ setContract r 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 else Right <$> getContracts
_ -> undefined _ -> undefined

31
haskell/src/SpaceTraders/APIClient/Errors.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Errors module SpaceTraders.APIClient.Errors
@ -8,11 +8,11 @@ module SpaceTraders.APIClient.Errors
, ResetHappened(..) , ResetHappened(..)
) where ) where
import Control.Exception import Control.Exception
import Data.Aeson import Data.Aeson
import Data.Time import qualified Data.Text as T
import qualified Data.Text as T import Data.Time
import GHC.Generics import GHC.Generics
data APIError = APIError Int T.Text Value data APIError = APIError Int T.Text Value
| APIRateLimit RateLimit | APIRateLimit RateLimit
@ -27,16 +27,15 @@ instance FromJSON APIError where
case code of case code of
401 -> APIResetHappened <$> parseJSON d 401 -> APIResetHappened <$> parseJSON d
429 -> APIRateLimit <$> parseJSON d 429 -> APIRateLimit <$> parseJSON d
_ -> APIError <$> pure code _ -> APIError code <$> e .: "message"
<*> e .: "message" <*> pure d
<*> pure d
data RateLimit = RateLimit { limitBurst :: Int data RateLimit = RateLimit { limitBurst :: Int
, limitPerSecond :: Int , limitPerSecond :: Int
, rateLimitType :: T.Text , rateLimitType :: T.Text
, remaining :: Int , remaining :: Int
, reset :: UTCTime , reset :: UTCTime
, retryAfter :: Double , retryAfter :: Double
} deriving Show } deriving Show
instance FromJSON RateLimit where instance FromJSON RateLimit where
parseJSON = withObject "RateLimit" $ \o -> parseJSON = withObject "RateLimit" $ \o ->
@ -47,6 +46,6 @@ instance FromJSON RateLimit where
<*> o .: "reset" <*> o .: "reset"
<*> o .: "retryAfter" <*> o .: "retryAfter"
data ResetHappened = ResetHappened { actual :: T.Text data ResetHappened = ResetHappened { actual :: T.Text
, expected :: T.Text , expected :: T.Text
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

9
haskell/src/SpaceTraders/APIClient/Pagination.hs
View file

@ -1,17 +1,16 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Pagination module SpaceTraders.APIClient.Pagination
( Pagination(..) ( Pagination(..)
, nextPage , nextPage
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics import GHC.Generics
data Pagination = Pagination { limit :: Int data Pagination = Pagination { limit :: Int
, page :: Int , page :: Int
, total :: Int , total :: Int
} deriving (FromJSON, Generic, Show) } deriving (FromJSON, Generic, Show)

35
haskell/src/SpaceTraders/APIClient/Ships.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Ships module SpaceTraders.APIClient.Ships
@ -8,19 +8,20 @@ module SpaceTraders.APIClient.Ships
, orbit , orbit
) where ) where
import Data.Aeson.Types import Data.Aeson.Types
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import GHC.Generics import GHC.Generics
import Network.HTTP.Simple import Network.HTTP.Simple
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Client import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Ships import SpaceTraders.Database.Ships
import SpaceTraders.Model.Nav import SpaceTraders.Model.Nav
import SpaceTraders.Model.Ship 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 -> SpaceTradersT (APIResponse Ship)
dock ship = do dock ship = do
resp <- send $ setRequestPath (T.encodeUtf8 $ mconcat ["/v2/my/ships/", symbol ship, "/dock"]) resp <- send $ setRequestPath (T.encodeUtf8 $ mconcat ["/v2/my/ships/", symbol ship, "/dock"])
@ -29,7 +30,7 @@ dock ship = do
Left e -> return $ Left e Left e -> return $ Left e
Right (NavMessage n) -> do Right (NavMessage n) -> do
let s = ship{SpaceTraders.Model.Ship.nav=n} let s = ship{SpaceTraders.Model.Ship.nav=n}
updateShip s setShip s
return $ Right s return $ Right s
myShips :: SpaceTradersT (APIResponse [Ship]) myShips :: SpaceTradersT (APIResponse [Ship])
@ -43,8 +44,8 @@ myShips = do
Left e -> return $ Left e Left e -> return $ Left e
Right (APIMessage r (Just p')) -> do Right (APIMessage r (Just p')) -> do
mapM_ setShip r mapM_ setShip r
if (limit p' * page p' < total p') then listShips' (nextPage p') if limit p' * page p' < total p' then listShips' (nextPage p')
else Right <$> getShips else Right <$> getShips
_ -> undefined _ -> undefined
orbit :: Ship -> SpaceTradersT (APIResponse Ship) orbit :: Ship -> SpaceTradersT (APIResponse Ship)
@ -55,5 +56,5 @@ orbit ship = do
Left e -> return $ Left e Left e -> return $ Left e
Right (NavMessage n) -> do Right (NavMessage n) -> do
let s = ship{SpaceTraders.Model.Ship.nav=n} let s = ship{SpaceTraders.Model.Ship.nav=n}
updateShip s setShip s
return $ Right s return $ Right s

22
haskell/src/SpaceTraders/APIClient/Systems.hs
View file

@ -1,24 +1,22 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Systems module SpaceTraders.APIClient.Systems
( initSystems ( initSystems
) where ) where
import Control.Exception import Control.Exception
import Network.HTTP.Simple import Network.HTTP.Simple
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Client import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Systems import SpaceTraders.Database.Systems
import SpaceTraders.Model.System(System) import SpaceTraders.Model.System (System)
initSystems :: SpaceTradersT (APIResponse [System]) initSystems :: SpaceTradersT (APIResponse [System])
initSystems = do initSystems = do
s <- getSystems 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 where
listSystems' :: Pagination -> SpaceTradersT (APIResponse [System]) listSystems' :: Pagination -> SpaceTradersT (APIResponse [System])
listSystems' p = do listSystems' p = do
@ -27,6 +25,6 @@ initSystems = do
Left e -> throw e Left e -> throw e
Right (APIMessage r (Just p')) -> do Right (APIMessage r (Just p')) -> do
addSystems r addSystems r
if (limit p' * page p' < total p') then listSystems' (nextPage p') if limit p' * page p' < total p' then listSystems' (nextPage p')
else Right <$> getSystems else Right <$> getSystems
_ -> undefined _ -> undefined

49
haskell/src/SpaceTraders/Automation/Init.hs
View file

@ -5,23 +5,24 @@ module SpaceTraders.Automation.Init
, initST , initST
) where ) where
import Control.Exception import Control.Exception
import Control.Monad.Reader import Control.Monad.Error.Class
import qualified Database.SQLite.Simple as S import Control.Monad.Reader
import qualified Data.Text as T import qualified Data.Text as T
import System.Directory import qualified Database.SQLite.Simple as S
import System.Directory
import SpaceTraders import SpaceTraders
import SpaceTraders.APIClient.Agent import SpaceTraders.APIClient.Agent
import SpaceTraders.APIClient.Client import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Contracts import SpaceTraders.APIClient.Contracts
import SpaceTraders.APIClient.Errors import SpaceTraders.APIClient.Errors
import SpaceTraders.APIClient.Ships import SpaceTraders.APIClient.Ships
import SpaceTraders.Database import SpaceTraders.Database
import SpaceTraders.Database.Agents import SpaceTraders.Database.Agents
import SpaceTraders.Database.Contracts import SpaceTraders.Database.Contracts
import SpaceTraders.Database.Ships import SpaceTraders.Database.Ships
import SpaceTraders.Database.Tokens import SpaceTraders.Database.Tokens
deinitST :: Env -> IO () deinitST :: Env -> IO ()
deinitST env = do deinitST env = do
@ -30,7 +31,7 @@ deinitST env = do
initST :: IO Env initST :: IO Env
initST = do initST = do
conn <- open conn <- open
t <- runReaderT getToken conn `catch` handleNoToken conn t <- runReaderT getToken conn `catchError` handleNoToken conn
env <- newEnv conn (tokenReq t) env <- newEnv conn (tokenReq t)
ma <- runReaderT getAgent conn -- We compare the agent state in the database ma <- runReaderT getAgent conn -- We compare the agent state in the database
ma' <- runSpaceTradersT myAgent env -- with the one on the servers ma' <- runSpaceTradersT myAgent env -- with the one on the servers
@ -42,21 +43,21 @@ initST = do
_ <- runReaderT myContracts env -- refresh contracts _ <- runReaderT myContracts env -- refresh contracts
_ <- runReaderT myShips env -- refresh ships _ <- runReaderT myShips env -- refresh ships
runReaderT (setAgent ma'') conn -- store the fresh agent state runReaderT (setAgent ma'') conn -- store the fresh agent state
return $ env return env
where where
handleNoToken :: S.Connection -> SomeException -> IO T.Text handleNoToken :: S.Connection -> IOException -> IO T.Text
handleNoToken conn _ = newEnv conn defaultReq >>= runReaderT registerST handleNoToken conn _ = newEnv conn defaultReq >>= runReaderT registerST
registerST :: SpaceTradersT (T.Text) registerST :: SpaceTradersT T.Text
registerST = do registerST = do
r <- register "ADYXAX-HS" "COSMIC" r <- register "ADYXAX-HS-6" "COSMIC"
case r of case r of
Right r' -> do Right r' -> do
let t = token r' let t = token r'
addToken t addToken t
addAgent $ agent r' setAgent $ agent r'
addContract $ contract r' setContract $ contract r'
addShip $ ship r' setShip $ ship r'
return t return t
Left e' -> throw e' Left e' -> throw e'

18
haskell/src/SpaceTraders/Database.hs
View file

@ -1,24 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module SpaceTraders.Database module SpaceTraders.Database
( close ( close
, open , open
) where ) where
import Control.Exception import Control.Exception
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.FileEmbed 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 Database.SQLite.Simple as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
migrations :: [B.ByteString] migrations :: [B.ByteString]
migrations = [ $(embedFile "src/SpaceTraders/Database/000_init.sql") ] migrations = [ $(embedFile "src/SpaceTraders/Database/000_init.sql") ]
close :: S.Connection -> IO () close :: S.Connection -> IO ()
close conn = S.close conn close = S.close
open :: IO S.Connection open :: IO S.Connection
open = do open = do
@ -27,7 +27,7 @@ open = do
S.execute_ conn "PRAGMA journal_mode = WAL;" S.execute_ conn "PRAGMA journal_mode = WAL;"
S.withTransaction conn $ do S.withTransaction conn $ do
version <- getSchemaVersion conn `catch` defaultVersion 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 "DELETE FROM schema_version;"
S.execute conn "INSERT INTO schema_version (version) VALUES (?);" (S.Only $ length migrations) S.execute conn "INSERT INTO schema_version (version) VALUES (?);" (S.Only $ length migrations)
return conn return conn

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

@ -1,24 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Agents module SpaceTraders.Database.Agents
( addAgent ( getAgent
, getAgent
, setAgent , setAgent
) where ) where
import Control.Monad.Reader import Control.Monad.Error.Class
import Data.Aeson import Control.Monad.Reader
import qualified Database.SQLite.Simple as S import Data.Aeson
import qualified Database.SQLite.Simple as S
import SpaceTraders import SpaceTraders
import SpaceTraders.Model.Agent import SpaceTraders.Model.Agent
import SpaceTraders.Utils 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))
getAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m Agent 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 :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Agent -> m ()
setAgent agent = execute "UPDATE agents SET data = json(?);" (S.Only (encode agent)) 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))

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

@ -1,31 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Contracts module SpaceTraders.Database.Contracts
( addContract ( getContracts
, getContracts
, setContract , setContract
, updateContract
) where ) where
import Control.Monad.Reader import Control.Monad.Error.Class
import Data.Aeson import Control.Monad.Reader
import qualified Database.SQLite.Simple as S import Data.Aeson
import qualified Database.SQLite.Simple as S
import SpaceTraders import SpaceTraders
import SpaceTraders.Model.Contract import SpaceTraders.Model.Contract
import SpaceTraders.Utils 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))
getContracts :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Contract] getContracts :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Contract]
getContracts = query_ "SELECT data FROM contracts;" getContracts = query_ "SELECT data FROM contracts;"
setContract :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Contract -> m () setContract :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Contract -> m ()
setContract contract = do setContract contract = updateContract `catchError` addContract
c <- count "SELECT count(id) FROM contracts WHERE data->>'contractId' = ?;" (S.Only $ contractId contract) where
if c == 0 then addContract contract addContract _ = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
else updateContract contract updateContract = execute "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId 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)

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

@ -1,31 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Ships module SpaceTraders.Database.Ships
( addShip ( getShips
, getShips
, setShip , setShip
, updateShip
) where ) where
import Control.Monad.Reader import Control.Monad.Error.Class
import Data.Aeson import Control.Monad.Reader
import qualified Database.SQLite.Simple as S import Data.Aeson
import qualified Database.SQLite.Simple as S
import SpaceTraders import SpaceTraders
import SpaceTraders.Model.Ship import SpaceTraders.Model.Ship
import SpaceTraders.Utils 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)
getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship] getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship]
getShips = query_ "SELECT data FROM ships;" getShips = query_ "SELECT data FROM ships;"
setShip :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Ship -> m () setShip :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Ship -> m ()
setShip ship = do setShip ship = updateShip `catchError` addShip
c <- count "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship) where
if c == 0 then addShip ship addShip _ = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
else updateShip ship updateShip = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol 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)

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

@ -5,13 +5,13 @@ module SpaceTraders.Database.Systems
, getSystems , getSystems
) where ) where
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson import Data.Aeson
import qualified Database.SQLite.Simple as S import qualified Database.SQLite.Simple as S
import SpaceTraders import SpaceTraders
import SpaceTraders.Model.System import SpaceTraders.Model.System
import SpaceTraders.Utils import SpaceTraders.Utils
addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m () addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m ()
addSystems systems = do addSystems systems = do

12
haskell/src/SpaceTraders/Database/Tokens.hs
View file

@ -1,21 +1,19 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module SpaceTraders.Database.Tokens module SpaceTraders.Database.Tokens
( addToken ( addToken
, getToken , getToken
) where ) where
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Text as T
import qualified Database.SQLite.Simple as S 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 :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => T.Text -> m ()
addToken value = do addToken value = execute "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
env <- ask
liftIO $ S.execute (getConn env) "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text
getToken = do getToken = do

17
haskell/src/SpaceTraders/Model/Agent.hs
View file

@ -1,19 +1,18 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Agent module SpaceTraders.Model.Agent
( Agent(..) ( Agent(..)
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics import qualified Data.Text as T
import qualified Data.Text as T import GHC.Generics
data Agent = Agent { accountId :: T.Text data Agent = Agent { accountId :: T.Text
, credits :: Integer , credits :: Integer
--, faction :: Faction --, faction :: Faction
, headquarters :: T.Text , headquarters :: T.Text
, startingFaction :: T.Text , startingFaction :: T.Text
, symbol :: T.Text , symbol :: T.Text
} deriving (Eq, FromJSON, Generic, Show, ToJSON) } deriving (Eq, FromJSON, Generic, Show, ToJSON)

13
haskell/src/SpaceTraders/Model/Cargo.hs
View file

@ -1,17 +1,16 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Cargo module SpaceTraders.Model.Cargo
( Cargo(..) ( Cargo(..)
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics 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] , inventory :: [Inventory]
, units :: Int , units :: Int
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

13
haskell/src/SpaceTraders/Model/Fuel.hs
View file

@ -1,21 +1,20 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Fuel module SpaceTraders.Model.Fuel
( Consumed(..) ( Consumed(..)
, Fuel(..) , Fuel(..)
) where ) where
import Data.Aeson import Data.Aeson
import Data.Time import Data.Time
import GHC.Generics import GHC.Generics
data Consumed = Consumed { amount :: Int data Consumed = Consumed { amount :: Int
, timestamp :: UTCTime , timestamp :: UTCTime
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)
data Fuel = Fuel { capacity :: Int data Fuel = Fuel { capacity :: Int
, consumed :: Consumed , consumed :: Consumed
, current :: Int , current :: Int
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

15
haskell/src/SpaceTraders/Model/Inventory.hs
View file

@ -1,17 +1,16 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Inventory module SpaceTraders.Model.Inventory
( Inventory(..) ( Inventory(..)
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics import qualified Data.Text as T
import qualified Data.Text as T import GHC.Generics
data Inventory = Inventory { description :: T.Text data Inventory = Inventory { description :: T.Text
, name :: T.Text , name :: T.Text
, symbol :: T.Text , symbol :: T.Text
, units :: Int , units :: Int
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

19
haskell/src/SpaceTraders/Model/Nav.hs
View file

@ -1,20 +1,19 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Nav module SpaceTraders.Model.Nav
( Nav(..) ( Nav(..)
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics import qualified Data.Text as T
import qualified Data.Text as T import GHC.Generics
import SpaceTraders.Model.Route import SpaceTraders.Model.Route
data Nav = Nav { flightMode :: T.Text data Nav = Nav { flightMode :: T.Text
, route :: Route , route :: Route
, status :: T.Text , status :: T.Text
, systemSymbol :: T.Text , systemSymbol :: T.Text
, waypointSymbol :: T.Text , waypointSymbol :: T.Text
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

27
haskell/src/SpaceTraders/Model/Ship.hs
View file

@ -1,34 +1,33 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Ship module SpaceTraders.Model.Ship
( Ship(..) ( Ship(..)
) where ) where
import Data.Aeson import Data.Aeson
import GHC.Generics import qualified Data.Text as T
import qualified Data.Text as T import GHC.Generics
import SpaceTraders.Model.Cargo import SpaceTraders.Model.Cargo
import SpaceTraders.Model.Fuel import SpaceTraders.Model.Fuel
import SpaceTraders.Model.Nav import SpaceTraders.Model.Nav
data Ship = Ship { cargo :: Cargo data Ship = Ship { cargo :: Cargo
, cooldown :: Cooldown , cooldown :: Cooldown
--, crew :: Crew --, crew :: Crew
--, engine :: Engine --, engine :: Engine
--, frame :: Frame --, frame :: Frame
, fuel :: Fuel , fuel :: Fuel
--, modules :: [Module] --, modules :: [Module]
--, mounts :: [Mount] --, mounts :: [Mount]
, nav :: Nav , nav :: Nav
--, reactor :: Reactor --, reactor :: Reactor
--, registration :: Registration --, registration :: Registration
, symbol :: T.Text , symbol :: T.Text
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)
data Cooldown = Cooldown { shipSymbol :: T.Text data Cooldown = Cooldown { shipSymbol :: T.Text
, totalSeconds :: Int , totalSeconds :: Int
, remainingSeconds :: Int , remainingSeconds :: Int
} deriving (FromJSON, Generic, Show, ToJSON) } deriving (FromJSON, Generic, Show, ToJSON)

21
haskell/src/SpaceTraders/Model/System.hs
View file

@ -1,23 +1,22 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.System module SpaceTraders.Model.System
( System(..) ( System(..)
) where ) where
import Data.Aeson import Data.Aeson
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics import GHC.Generics
import SpaceTraders.Model.Waypoint(Waypoint) import SpaceTraders.Model.Waypoint (Waypoint)
data System = System { sectorSymbol :: T.Text data System = System { sectorSymbol :: T.Text
, symbol :: T.Text , symbol :: T.Text
, systemType :: T.Text , systemType :: T.Text
, x :: Int , x :: Int
, y :: Int , y :: Int
, waypoints :: [Waypoint] , waypoints :: [Waypoint]
--, factions :: [Faction] --, factions :: [Faction]
} deriving (Generic, Show) } deriving (Generic, Show)
instance FromJSON System where instance FromJSON System where

17
haskell/src/SpaceTraders/Model/Waypoint.hs
View file

@ -1,20 +1,19 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Waypoint module SpaceTraders.Model.Waypoint
( Waypoint(..) ( Waypoint(..)
) where ) where
import Data.Aeson import Data.Aeson
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics import GHC.Generics
data Waypoint = Waypoint { orbits :: Maybe T.Text data Waypoint = Waypoint { orbits :: Maybe T.Text
, symbol :: T.Text , symbol :: T.Text
, waypointType :: T.Text , waypointType :: T.Text
, x :: Int , x :: Int
, y :: Int , y :: Int
} deriving (Generic, Show) } deriving (Generic, Show)
instance FromJSON Waypoint where instance FromJSON Waypoint where
parseJSON = withObject "Waypoint" $ \o -> parseJSON = withObject "Waypoint" $ \o ->

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

@ -9,18 +9,18 @@ module SpaceTraders.Utils
, query_ , query_
) where ) where
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Internal as B
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Database.SQLite.Simple as S 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 :: (HasDatabaseConn env, MonadFail m, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m Int
count q t = do count q t = do
@ -43,16 +43,16 @@ int2ByteString :: Int -> B.ByteString
int2ByteString = B.pack . map B.c2w . show int2ByteString = B.pack . map B.c2w . show
one_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m b 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 :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m [b]
query q t = do query q t = do
env <- ask env <- ask
ret <- liftIO $ S.query (getConn env) q t 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_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m [b]
query_ q = do query_ q = do
env <- ask env <- ask
ret <- liftIO $ S.query_ (getConn env) q ret <- liftIO $ S.query_ (getConn env) q
return . catMaybes $ map (decodeText . head) ret return $ mapMaybe (decodeText . head) ret

7
haskell/stack.yaml
View file

@ -17,8 +17,9 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: #resolver: lts-22.13
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml resolver: lts-21.25
# url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -49,7 +50,7 @@ packages:
# extra-package-dbs: [] # extra-package-dbs: []
# Control whether we use the GHC we find on the path # Control whether we use the GHC we find on the path
# system-ghc: true system-ghc: true
# #
# Require a specific version of Stack, using version ranges # Require a specific version of Stack, using version ranges
# require-stack-version: -any # Default # require-stack-version: -any # Default