summaryrefslogtreecommitdiff
path: root/haskell/src
diff options
context:
space:
mode:
Diffstat (limited to 'haskell/src')
-rw-r--r--haskell/src/SpaceTraders.hs31
-rw-r--r--haskell/src/SpaceTraders/APIClient/Agent.hs17
-rw-r--r--haskell/src/SpaceTraders/APIClient/Client.hs70
-rw-r--r--haskell/src/SpaceTraders/APIClient/Ships.hs36
-rw-r--r--haskell/src/SpaceTraders/APIClient/Systems.hs20
-rw-r--r--haskell/src/SpaceTraders/Automation/Init.hs50
-rw-r--r--haskell/src/SpaceTraders/Database/Agents.hs10
-rw-r--r--haskell/src/SpaceTraders/Database/Contracts.hs8
-rw-r--r--haskell/src/SpaceTraders/Database/Ships.hs8
-rw-r--r--haskell/src/SpaceTraders/Database/Systems.hs22
-rw-r--r--haskell/src/SpaceTraders/Database/Tokens.hs22
-rw-r--r--haskell/src/SpaceTraders/Database/Utils.hs11
12 files changed, 192 insertions, 113 deletions
diff --git a/haskell/src/SpaceTraders.hs b/haskell/src/SpaceTraders.hs
index d93116d..2a531fe 100644
--- a/haskell/src/SpaceTraders.hs
+++ b/haskell/src/SpaceTraders.hs
@@ -3,21 +3,36 @@
module SpaceTraders
( SpaceTradersT
, runSpaceTradersT
- , Config(..)
+ , Env(..)
+ , HasDatabaseConn
+ , HasRequest
, ask
+ , getConn
+ , getRequest
, liftIO
) where
import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
+import Control.Monad.Reader
import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
+import Network.HTTP.Simple
-type SpaceTradersT a = ReaderT Config IO a
+type SpaceTradersT a = ReaderT Env IO a
-runSpaceTradersT :: SpaceTradersT a -> Config -> IO a
+runSpaceTradersT :: SpaceTradersT a -> Env -> IO a
runSpaceTradersT = runReaderT
-data Config = Config { conn :: S.Connection
- , token :: T.Text
- }
+data Env = Env { envConn :: S.Connection
+ , envRequest :: Request }
+
+class HasDatabaseConn a where
+ getConn :: a -> S.Connection
+instance HasDatabaseConn S.Connection where
+ getConn = id
+instance HasDatabaseConn Env where
+ getConn = envConn
+
+class HasRequest a where
+ getRequest :: a -> Request
+instance HasRequest Env where
+ getRequest = envRequest
diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs
index 023a4f4..7b367f6 100644
--- a/haskell/src/SpaceTraders/APIClient/Agent.hs
+++ b/haskell/src/SpaceTraders/APIClient/Agent.hs
@@ -8,22 +8,20 @@ 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 qualified SpaceTraders as ST
+import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.Model.Agent(Agent)
import SpaceTraders.Model.Ship(Ship)
import SpaceTraders.Model.Contract
-myAgent :: ST.SpaceTradersT (APIResponse Agent)
-myAgent = do
- c <- ST.ask
- ST.liftIO $ send $ setRequestPath "/v2/my/agent"
- $ tokenReq (ST.token c)
+myAgent :: SpaceTradersT (APIResponse Agent)
+myAgent = send $ setRequestPath "/v2/my/agent"
data RegisterRequest = RegisterRequest { faction :: T.Text
, symbol :: T.Text
@@ -34,8 +32,7 @@ data RegisterMessage = RegisterMessage { agent :: Agent
, token :: T.Text
} deriving (FromJSON, Generic, Show)
-register :: T.Text -> T.Text -> IO (APIResponse RegisterMessage)
+register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage)
register s f = send $ setRequestPath "/v2/register"
- $ setRequestMethod "POST"
- $ setRequestBodyJSON RegisterRequest{symbol = s, faction = f}
- $ defaultReq
+ . setRequestMethod "POST"
+ . setRequestBodyJSON RegisterRequest{symbol = s, faction = f}
diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index 0f0cf27..402431f 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -8,13 +8,13 @@ module SpaceTraders.APIClient.Client
, APIResponse
, defaultReq
, fromJSONValue
- , paginatedReq
, send
, sendPaginated
, tokenReq
) where
import Control.Concurrent
+import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString as B
@@ -23,9 +23,8 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Simple
import Network.HTTP.Types.Status
-import System.Environment
-import System.Posix.Process
+import SpaceTraders
import SpaceTraders.APIClient.Errors
import SpaceTraders.APIClient.Pagination
@@ -47,45 +46,44 @@ defaultReq = setRequestHost "api.spacetraders.io"
$ setRequestHeader "Content-Type" ["application/json"]
$ defaultRequest
-paginatedReq :: T.Text -> Maybe Pagination -> Request
-paginatedReq token Nothing = setRequestQueryString [("limit", Just "20")]
- $ tokenReq token
-paginatedReq token (Just myPage) = setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
- $ tokenReq token
- where
- int2ByteString = B.pack . map B.c2w . show
-
tokenReq :: T.Text -> Request
-tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token]
- $ defaultReq
+tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] defaultReq
fromJSONValue :: FromJSON a => Value -> Either String a
fromJSONValue = parseEither parseJSON
-send :: FromJSON a => Request -> IO (APIResponse a)
-send request = do
- response <- sendPaginated request
+int2ByteString :: Int -> B.ByteString
+int2ByteString = B.pack . map B.c2w . show
+
+send :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => (Request -> Request) -> m (APIResponse a)
+send requestBuilder = do
+ response <- sendPaginated Nothing requestBuilder
case response of
Left e -> return $ Left e
Right (APIMessage d _) -> return $ Right d
-sendPaginated :: FromJSON a => Request -> IO (APIPaginatedResponse a)
-sendPaginated request = do
- response <- httpLbs request
- let status = statusCode $ getResponseStatus response
- 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
- 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
- threadDelay (1_000_000 * (round $ retryAfter r))
- sendPaginated request
- Right (APIResetHappened _) -> do
- p <- getExecutablePath
- a <- getArgs
- e <- getEnvironment
- executeFile p False a (Just e)
- Right e -> return $ Left e
+sendPaginated :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Maybe Pagination -> (Request -> Request) -> m (APIPaginatedResponse a)
+sendPaginated pagination requestBuilder = do
+ env <- ask
+ let request = requestBuilder $ getRequest env
+ request' = case pagination of
+ Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
+ $ request
+ Nothing -> request
+ sendPaginated' request'
+ where
+ sendPaginated' :: (FromJSON a, MonadIO m) => Request -> m (APIPaginatedResponse a)
+ sendPaginated' request = do
+ response <- liftIO $ httpLbs request
+ let status = statusCode $ getResponseStatus response
+ 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
+ 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 $ threadDelay (1_000_000 * (round $ retryAfter r))
+ sendPaginated' request
+ Right e -> return $ Left e
diff --git a/haskell/src/SpaceTraders/APIClient/Ships.hs b/haskell/src/SpaceTraders/APIClient/Ships.hs
new file mode 100644
index 0000000..0efbb5d
--- /dev/null
+++ b/haskell/src/SpaceTraders/APIClient/Ships.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.APIClient.Ships
+ ( listShips
+ ) where
+
+import Control.Exception
+--import qualified Data.Text as T
+--import qualified Database.SQLite.Simple as S
+import Network.HTTP.Simple
+
+import SpaceTraders
+import SpaceTraders.APIClient.Client
+import SpaceTraders.APIClient.Pagination
+--import SpaceTraders.Database.Ships
+import SpaceTraders.Model.Ship(Ship)
+import Debug.Trace
+
+listShips :: SpaceTradersT (APIResponse [Ship])
+listShips = do
+ listShips' Pagination{limit=20, page=1, total=0}
+ where
+ listShips' :: Pagination -> SpaceTradersT (APIResponse [Ship])
+ listShips' p = do
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/my/ships"
+ case resp of
+ Left e -> throw e
+ Right (APIMessage r (Just p')) -> do
+ liftIO $ traceIO $ show p'
+ --if (length r == 0 || ((page p') * (limit p')
+ --addShips conn r
+ --listShips' (nextPage p')
+ return $ Right r
+ _ -> undefined
diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs
index fca2037..2e275ee 100644
--- a/haskell/src/SpaceTraders/APIClient/Systems.hs
+++ b/haskell/src/SpaceTraders/APIClient/Systems.hs
@@ -7,28 +7,26 @@ module SpaceTraders.APIClient.Systems
) where
import Control.Exception
-import qualified Data.Text as T
-import qualified Database.SQLite.Simple as S
import Network.HTTP.Simple
+import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Systems
import SpaceTraders.Model.System(System)
-listSystems :: T.Text -> S.Connection -> IO (APIResponse [System])
-listSystems t conn = do
- s <- getSystems conn
+listSystems :: SpaceTradersT (APIResponse [System])
+listSystems = do
+ s <- getSystems
listSystems' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0}
where
- listSystems' :: Pagination -> IO (APIResponse [System])
+ listSystems' :: Pagination -> SpaceTradersT (APIResponse [System])
listSystems' p = do
- resp <- sendPaginated $ setRequestPath "/v2/systems"
- $ paginatedReq t (Just p)
+ resp <- sendPaginated (Just p) $ setRequestPath "/v2/systems"
case resp of
- Left e -> throwIO e
- Right (APIMessage [] _) -> Right <$> getSystems conn
+ Left e -> throw e
+ Right (APIMessage [] _) -> Right <$> getSystems
Right (APIMessage r (Just p')) -> do
- addSystems conn r
+ addSystems r
listSystems' (nextPage p')
_ -> undefined
diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs
index 8e90fca..2e9d8bb 100644
--- a/haskell/src/SpaceTraders/Automation/Init.hs
+++ b/haskell/src/SpaceTraders/Automation/Init.hs
@@ -6,53 +6,55 @@ module SpaceTraders.Automation.Init
) 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 SpaceTraders
-import qualified SpaceTraders.APIClient.Agent as STAA
-import SpaceTraders.APIClient.Errors
+import SpaceTraders.APIClient.Agent
+import SpaceTraders.APIClient.Client
import SpaceTraders.Database
import SpaceTraders.Database.Agents
import SpaceTraders.Database.Contracts
import SpaceTraders.Database.Ships
import SpaceTraders.Database.Tokens
-deinitST :: Config -> IO ()
-deinitST config = do
- close $ conn config
+deinitST :: Env -> IO ()
+deinitST env = do
+ close $ getConn env
-initST :: IO Config
+initST :: IO Env
initST = do
- c <- open
- t <- getToken c `catch` handleNoToken c
- ma <- runSpaceTradersT STAA.myAgent (Config c t)
+ conn <- open
+ t <- runReaderT getToken conn `catch` handleNoToken conn
+ let env = Env conn (tokenReq t)
+ ma <- runSpaceTradersT myAgent env
case ma of
- Left (APIResetHappened _) -> wipe c
+ Left (APIResetHappened _) -> wipe conn
Left e -> throwIO e
- _ -> return $ Config c t
+ _ -> return $ env
where
handleNoToken :: S.Connection -> SomeException -> IO T.Text
- handleNoToken c _ = register c
+ handleNoToken conn _ = runReaderT registerST (Env conn defaultReq)
-register :: S.Connection -> IO (T.Text)
-register c = do
- r <- STAA.register "ADYXAX" "COSMIC"
+registerST :: SpaceTradersT (T.Text)
+registerST = do
+ r <- register "ADYXAX" "COSMIC"
case r of
Right r' -> do
- setAgent c $ STAA.agent r'
- addContract c $ STAA.contract r'
- addShip c $ STAA.ship r'
- let t = STAA.token r'
- setToken c $ t
+ addAgent $ agent r'
+ addContract $ contract r'
+ addShip $ ship r'
+ let t = token r'
+ addToken t
return t
- Left e' -> throwIO e'
+ Left e' -> throw e'
-wipe :: S.Connection -> IO Config
+wipe :: S.Connection -> IO Env
wipe c = do
close c
removeFile "spacetraders.db"
conn' <- open
- t <- register conn'
- return $ Config conn' t
+ t <- runReaderT registerST (Env conn' defaultReq)
+ return $ Env conn' (tokenReq t)
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index 48cd65b..b34ca04 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -1,13 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Agents
- ( setAgent
+ ( addAgent
) where
+import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
+import SpaceTraders
import SpaceTraders.Model.Agent
-setAgent :: S.Connection -> Agent -> IO ()
-setAgent conn agent = S.execute conn "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))
+addAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
+addAgent agent = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))
diff --git a/haskell/src/SpaceTraders/Database/Contracts.hs b/haskell/src/SpaceTraders/Database/Contracts.hs
index 1ef5d6d..26c4a1f 100644
--- a/haskell/src/SpaceTraders/Database/Contracts.hs
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -4,10 +4,14 @@ module SpaceTraders.Database.Contracts
( addContract
) where
+import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
+import SpaceTraders
import SpaceTraders.Model.Contract
-addContract :: S.Connection -> Contract -> IO ()
-addContract conn contract = S.execute conn "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
+addContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
+addContract contract = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
diff --git a/haskell/src/SpaceTraders/Database/Ships.hs b/haskell/src/SpaceTraders/Database/Ships.hs
index 81c422d..95b0b5d 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -4,10 +4,14 @@ module SpaceTraders.Database.Ships
( addShip
) where
+import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
+import SpaceTraders
import SpaceTraders.Model.Ship
-addShip :: S.Connection -> Ship -> IO ()
-addShip conn ship = S.execute conn "INSERT INTO ships(data) VALUES (json(?));" (S.Only (encode ship))
+addShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
+addShip ship = do
+ env <- ask
+ liftIO $ S.execute (getConn env) "INSERT INTO ships(data) VALUES (json(?));" (S.Only (encode ship))
diff --git a/haskell/src/SpaceTraders/Database/Systems.hs b/haskell/src/SpaceTraders/Database/Systems.hs
index 5312fd0..f71508e 100644
--- a/haskell/src/SpaceTraders/Database/Systems.hs
+++ b/haskell/src/SpaceTraders/Database/Systems.hs
@@ -5,19 +5,23 @@ module SpaceTraders.Database.Systems
, getSystems
) where
+import Control.Monad.Reader
import Data.Aeson
import Data.Maybe
import qualified Database.SQLite.Simple as S
-import Data.Text.Encoding (encodeUtf8Builder)
-import Data.ByteString.Builder(toLazyByteString)
-
+import SpaceTraders
+import SpaceTraders.Database.Utils
import SpaceTraders.Model.System
-addSystems :: S.Connection -> [System] -> IO ()
-addSystems conn systems = S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems
+addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m ()
+addSystems systems = do
+ env <- ask
+ let conn = getConn env
+ liftIO $ S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems
-getSystems :: S.Connection -> IO [System]
-getSystems conn = do
- ret <- S.query_ conn "SELECT data from systems;"
- return . catMaybes $ map (decode . toLazyByteString . encodeUtf8Builder . head) ret
+getSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [System]
+getSystems = do
+ env <- ask
+ ret <- liftIO $ S.query_ (getConn env) "SELECT data from systems;"
+ return . catMaybes $ map (decodeText . head) ret
diff --git a/haskell/src/SpaceTraders/Database/Tokens.hs b/haskell/src/SpaceTraders/Database/Tokens.hs
index b907609..e99e49e 100644
--- a/haskell/src/SpaceTraders/Database/Tokens.hs
+++ b/haskell/src/SpaceTraders/Database/Tokens.hs
@@ -2,17 +2,23 @@
{-# LANGUAGE QuasiQuotes #-}
module SpaceTraders.Database.Tokens
- ( getToken
- , setToken
+ ( addToken
+ , getToken
) where
+import Control.Monad.Reader
import qualified Database.SQLite.Simple as S
import qualified Data.Text as T
-getToken :: S.Connection -> IO (T.Text)
-getToken conn = do
- [[token]] <- S.query_ conn "SELECT data FROM tokens;"
- return token
+import SpaceTraders
+
+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)
-setToken :: S.Connection -> T.Text -> IO ()
-setToken conn value = S.execute conn "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
+getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text
+getToken = do
+ env <- ask
+ [[token]] <- liftIO $ S.query_ (getConn env) "SELECT data FROM tokens;"
+ return token
diff --git a/haskell/src/SpaceTraders/Database/Utils.hs b/haskell/src/SpaceTraders/Database/Utils.hs
new file mode 100644
index 0000000..4d933bd
--- /dev/null
+++ b/haskell/src/SpaceTraders/Database/Utils.hs
@@ -0,0 +1,11 @@
+module SpaceTraders.Database.Utils
+ ( decodeText
+ ) where
+
+import Data.Aeson
+import Data.ByteString.Builder(toLazyByteString)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8Builder)
+
+decodeText :: FromJSON a => T.Text -> Maybe a
+decodeText = decode . toLazyByteString . encodeUtf8Builder
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 10:45:54 +0000