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
import SpaceTraders
import SpaceTraders.Automation.Init
import SpaceTraders.APIClient.Ships
import SpaceTraders.APIClient.Systems
import SpaceTraders
import SpaceTraders.APIClient.Agent
import SpaceTraders.APIClient.Contracts
import SpaceTraders.APIClient.Ships
import SpaceTraders.Automation.Init
main :: IO ()
main = do
@ -15,7 +14,11 @@ main = do
where
main' :: SpaceTradersT ()
main' = do
_ <- initSystems
-- refresh our core objects
_ <- myAgent
_ <- myContracts
(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 ()

19
haskell/src/SpaceTraders.hs
View file

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

7
haskell/stack.yaml
View file

@ -17,8 +17,9 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml
#resolver: lts-22.13
resolver: lts-21.25
# url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
@ -49,7 +50,7 @@ packages:
# extra-package-dbs: []
# 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-stack-version: -any # Default