From 4af96da5670566c111fa5c7dac9572eaac021a4b Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Tue, 18 Jul 2023 00:02:33 +0200 Subject: [haskell] Refactored everything with a ReaderT pattern --- haskell/app/Main.hs | 25 +++++++-- haskell/package.yaml | 2 +- haskell/src/SpaceTraders.hs | 31 +++++++++--- haskell/src/SpaceTraders/APIClient/Agent.hs | 17 +++---- haskell/src/SpaceTraders/APIClient/Client.hs | 70 +++++++++++++------------- haskell/src/SpaceTraders/APIClient/Ships.hs | 36 +++++++++++++ haskell/src/SpaceTraders/APIClient/Systems.hs | 20 ++++---- haskell/src/SpaceTraders/Automation/Init.hs | 50 +++++++++--------- haskell/src/SpaceTraders/Database/Agents.hs | 10 ++-- haskell/src/SpaceTraders/Database/Contracts.hs | 8 ++- haskell/src/SpaceTraders/Database/Ships.hs | 8 ++- haskell/src/SpaceTraders/Database/Systems.hs | 22 ++++---- haskell/src/SpaceTraders/Database/Tokens.hs | 22 +++++--- haskell/src/SpaceTraders/Database/Utils.hs | 11 ++++ 14 files changed, 213 insertions(+), 119 deletions(-) create mode 100644 haskell/src/SpaceTraders/APIClient/Ships.hs create mode 100644 haskell/src/SpaceTraders/Database/Utils.hs (limited to 'haskell') diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs index e22988c..1b2ccec 100644 --- a/haskell/app/Main.hs +++ b/haskell/app/Main.hs @@ -3,19 +3,34 @@ module Main (main) where import Control.Exception +import System.Environment +import System.Posix.Process import SpaceTraders import SpaceTraders.Automation.Init import SpaceTraders.APIClient.Agent(myAgent) +import SpaceTraders.APIClient.Client +import SpaceTraders.APIClient.Ships import SpaceTraders.APIClient.Systems main :: IO () main = do - config <- initST - ma <- runSpaceTradersT myAgent config - print ma - s <- listSystems (token config) (conn config) + env <- initST + ma <- runSpaceTradersT myAgent env + case ma of + Left (APIResetHappened _) -> do + p <- getExecutablePath + a <- getArgs + e <- getEnvironment + executeFile p False a (Just e) + Left e -> throwIO e + Right ma' -> print ma' + s <- runSpaceTradersT listSystems env case s of Left e -> throwIO e Right s' -> print $ length s' - deinitST config + ships <- runSpaceTradersT listShips env + case ships of + Left e -> throwIO e + Right s' -> print $ s' + deinitST env diff --git a/haskell/package.yaml b/haskell/package.yaml index 8ecfa55..5f62014 100644 --- a/haskell/package.yaml +++ b/haskell/package.yaml @@ -22,11 +22,11 @@ dependencies: - directory - http-conduit - http-types +- mtl - raw-strings-qq - sqlite-simple - text - time -- transformers - unix ghc-options: 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 -- cgit v1.2.3