From e084d260ff0439f04ab62eba7229309d79ed55c4 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sun, 16 Jul 2023 23:31:00 +0200 Subject: [haskell] Add a SpaceTradersT and handle server reset api message --- haskell/app/Main.hs | 37 +++++------------- haskell/package.yaml | 4 +- haskell/src/SpaceTraders.hs | 23 +++++++++++ haskell/src/SpaceTraders/APIClient/Agent.hs | 9 +++-- haskell/src/SpaceTraders/APIClient/Errors.hs | 10 +++++ haskell/src/SpaceTraders/Automation/Init.hs | 58 ++++++++++++++++++++++++++++ 6 files changed, 110 insertions(+), 31 deletions(-) create mode 100644 haskell/src/SpaceTraders.hs create mode 100644 haskell/src/SpaceTraders/Automation/Init.hs (limited to 'haskell') diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs index 38e6b0d..e22988c 100644 --- a/haskell/app/Main.hs +++ b/haskell/app/Main.hs @@ -3,36 +3,19 @@ module Main (main) where import Control.Exception -import qualified Database.SQLite.Simple as S -import qualified Data.Text as T -import SpaceTraders.APIClient.Agent +import SpaceTraders +import SpaceTraders.Automation.Init +import SpaceTraders.APIClient.Agent(myAgent) import SpaceTraders.APIClient.Systems -import SpaceTraders.Database -import SpaceTraders.Database.Agents -import SpaceTraders.Database.Contracts -import SpaceTraders.Database.Ships -import SpaceTraders.Database.Tokens main :: IO () main = do - conn <- open - t <- getToken conn `catch` registerNow conn - ma <- myAgent t + config <- initST + ma <- runSpaceTradersT myAgent config print ma - s <- listSystems t conn - print s - close conn - where - registerNow :: S.Connection -> SomeException -> IO (T.Text) - registerNow conn _ = do - r <- register "ADYXAX" "COSMIC" - case r of - Right r' -> do - setAgent conn $ agent r' - addContract conn $ contract r' - addShip conn $ ship r' - let t = token r' - setToken conn $ t - return t - Left e' -> throwIO e' + s <- listSystems (token config) (conn config) + case s of + Left e -> throwIO e + Right s' -> print $ length s' + deinitST config diff --git a/haskell/package.yaml b/haskell/package.yaml index c464ad9..567b06c 100644 --- a/haskell/package.yaml +++ b/haskell/package.yaml @@ -19,12 +19,14 @@ dependencies: - aeson - base >= 4.7 && < 5 - bytestring +- directory - http-conduit - http-types +- raw-strings-qq - sqlite-simple - text - time -- raw-strings-qq +- transformers ghc-options: - -Wall diff --git a/haskell/src/SpaceTraders.hs b/haskell/src/SpaceTraders.hs new file mode 100644 index 0000000..d93116d --- /dev/null +++ b/haskell/src/SpaceTraders.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders + ( SpaceTradersT + , runSpaceTradersT + , Config(..) + , ask + , liftIO + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Database.SQLite.Simple as S +import qualified Data.Text as T + +type SpaceTradersT a = ReaderT Config IO a + +runSpaceTradersT :: SpaceTradersT a -> Config -> IO a +runSpaceTradersT = runReaderT + +data Config = Config { conn :: S.Connection + , token :: T.Text + } diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs index 7773972..023a4f4 100644 --- a/haskell/src/SpaceTraders/APIClient/Agent.hs +++ b/haskell/src/SpaceTraders/APIClient/Agent.hs @@ -13,14 +13,17 @@ import GHC.Generics import qualified Data.Text as T import Network.HTTP.Simple +import qualified SpaceTraders as ST import SpaceTraders.APIClient.Client import SpaceTraders.Model.Agent(Agent) import SpaceTraders.Model.Ship(Ship) import SpaceTraders.Model.Contract -myAgent :: T.Text -> IO (APIResponse Agent) -myAgent t = send $ setRequestPath "/v2/my/agent" - $ tokenReq t +myAgent :: ST.SpaceTradersT (APIResponse Agent) +myAgent = do + c <- ST.ask + ST.liftIO $ send $ setRequestPath "/v2/my/agent" + $ tokenReq (ST.token c) data RegisterRequest = RegisterRequest { faction :: T.Text , symbol :: T.Text diff --git a/haskell/src/SpaceTraders/APIClient/Errors.hs b/haskell/src/SpaceTraders/APIClient/Errors.hs index a7f5d21..2b74784 100644 --- a/haskell/src/SpaceTraders/APIClient/Errors.hs +++ b/haskell/src/SpaceTraders/APIClient/Errors.hs @@ -1,17 +1,22 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module SpaceTraders.APIClient.Errors ( APIError(..) , RateLimit(..) + , ResetHappened(..) ) where import Control.Exception import Data.Aeson import Data.Time import qualified Data.Text as T +import GHC.Generics data APIError = APIError Int T.Text Value | APIRateLimit RateLimit + | APIResetHappened ResetHappened deriving Show instance Exception APIError instance FromJSON APIError where @@ -20,6 +25,7 @@ instance FromJSON APIError where code <- e .: "code" d <- e .: "data" case code of + 401 -> APIResetHappened <$> parseJSON d 429 -> APIRateLimit <$> parseJSON d _ -> APIError <$> pure code <*> e .: "message" @@ -40,3 +46,7 @@ instance FromJSON RateLimit where <*> o .: "remaining" <*> o .: "reset" <*> o .: "retryAfter" + +data ResetHappened = ResetHappened { actual :: T.Text + , expected :: T.Text + } deriving (FromJSON, Generic, Show, ToJSON) diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs new file mode 100644 index 0000000..8e90fca --- /dev/null +++ b/haskell/src/SpaceTraders/Automation/Init.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.Automation.Init + ( deinitST + , initST + ) where + +import Control.Exception +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.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 + +initST :: IO Config +initST = do + c <- open + t <- getToken c `catch` handleNoToken c + ma <- runSpaceTradersT STAA.myAgent (Config c t) + case ma of + Left (APIResetHappened _) -> wipe c + Left e -> throwIO e + _ -> return $ Config c t + where + handleNoToken :: S.Connection -> SomeException -> IO T.Text + handleNoToken c _ = register c + +register :: S.Connection -> IO (T.Text) +register c = do + r <- STAA.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 + return t + Left e' -> throwIO e' + +wipe :: S.Connection -> IO Config +wipe c = do + close c + removeFile "spacetraders.db" + conn' <- open + t <- register conn' + return $ Config conn' t -- cgit v1.2.3