1
0
Fork 0

[haskell] refactoring

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

View file

@ -1,11 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import SpaceTraders
import SpaceTraders.Automation.Init
import SpaceTraders.APIClient.Agent
import SpaceTraders.APIClient.Contracts
import SpaceTraders.APIClient.Ships
import SpaceTraders.APIClient.Systems
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 ()

View file

@ -1,6 +1,3 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders
( SpaceTradersT
, microSinceEpoch

View file

@ -10,18 +10,23 @@ module SpaceTraders.APIClient.Agent
import Control.Monad.Reader
import Data.Aeson
import GHC.Generics
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.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

View file

@ -29,7 +29,7 @@ import SpaceTraders.APIClient.Errors
import SpaceTraders.APIClient.Pagination
import SpaceTraders.Utils
data FromJSON a => APIMessage a = APIMessage { messageData :: a
data APIMessage a = APIMessage { messageData :: a
, messagePagination :: Maybe Pagination
} deriving (Show)
instance FromJSON a => FromJSON (APIMessage a) where
@ -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
@ -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"

View file

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Contracts
@ -12,7 +10,7 @@ import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Contracts
import SpaceTraders.Model.Contract(Contract)
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

View file

@ -10,8 +10,8 @@ module SpaceTraders.APIClient.Errors
import Control.Exception
import Data.Aeson
import Data.Time
import qualified Data.Text as T
import Data.Time
import GHC.Generics
data APIError = APIError Int T.Text Value
@ -27,8 +27,7 @@ instance FromJSON APIError where
case code of
401 -> APIResetHappened <$> parseJSON d
429 -> APIRateLimit <$> parseJSON d
_ -> APIError <$> pure code
<*> e .: "message"
_ -> APIError code <$> e .: "message"
<*> pure d
data RateLimit = RateLimit { limitBurst :: Int

View file

@ -1,6 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Pagination
( Pagination(..)

View file

@ -20,7 +20,8 @@ import SpaceTraders.Database.Ships
import SpaceTraders.Model.Nav
import SpaceTraders.Model.Ship
data NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show)
newtype 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,7 +44,7 @@ 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')
if limit p' * page p' < total p' then listShips' (nextPage p')
else Right <$> getShips
_ -> undefined
@ -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

View file

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.APIClient.Systems
@ -13,12 +11,12 @@ import SpaceTraders
import SpaceTraders.APIClient.Client
import SpaceTraders.APIClient.Pagination
import SpaceTraders.Database.Systems
import SpaceTraders.Model.System(System)
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')
if limit p' * page p' < total p' then listSystems' (nextPage p')
else Right <$> getSystems
_ -> undefined

View file

@ -6,9 +6,10 @@ module SpaceTraders.Automation.Init
) where
import Control.Exception
import Control.Monad.Error.Class
import Control.Monad.Reader
import qualified Database.SQLite.Simple as S
import qualified Data.Text as T
import qualified Database.SQLite.Simple as S
import System.Directory
import SpaceTraders
@ -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'

View file

@ -10,15 +10,15 @@ module SpaceTraders.Database
import Control.Exception
import qualified Data.ByteString as B
import Data.FileEmbed
import qualified Database.SQLite.Simple as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Database.SQLite.Simple as S
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

View file

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Agents
( addAgent
, getAgent
( getAgent
, setAgent
) where
import Control.Monad.Error.Class
import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
@ -14,11 +14,11 @@ 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))
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))

View file

@ -1,12 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Contracts
( addContract
, getContracts
( getContracts
, setContract
, updateContract
) where
import Control.Monad.Error.Class
import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
@ -15,17 +14,11 @@ 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))
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)

View file

@ -1,12 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Database.Ships
( addShip
, getShips
( getShips
, setShip
, updateShip
) where
import Control.Monad.Error.Class
import Control.Monad.Reader
import Data.Aeson
import qualified Database.SQLite.Simple as S
@ -15,17 +14,11 @@ 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)
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)

View file

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module SpaceTraders.Database.Tokens
( addToken
@ -7,15 +6,14 @@ module SpaceTraders.Database.Tokens
) where
import Control.Monad.Reader
import qualified Database.SQLite.Simple as S
import qualified Data.Text as T
import qualified Database.SQLite.Simple as S
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

View file

@ -1,14 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Agent
( Agent(..)
) where
import Data.Aeson
import GHC.Generics
import qualified Data.Text as T
import GHC.Generics
data Agent = Agent { accountId :: T.Text
, credits :: Integer

View file

@ -1,6 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Cargo
( Cargo(..)
@ -9,7 +8,7 @@ module SpaceTraders.Model.Cargo
import Data.Aeson
import GHC.Generics
import SpaceTraders.Model.Inventory(Inventory)
import SpaceTraders.Model.Inventory (Inventory)
data Cargo = Cargo { capacity :: Int
, inventory :: [Inventory]

View file

@ -1,6 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Fuel
( Consumed(..)

View file

@ -1,14 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Inventory
( Inventory(..)
) where
import Data.Aeson
import GHC.Generics
import qualified Data.Text as T
import GHC.Generics
data Inventory = Inventory { description :: T.Text
, name :: T.Text

View file

@ -1,14 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Nav
( Nav(..)
) where
import Data.Aeson
import GHC.Generics
import qualified Data.Text as T
import GHC.Generics
import SpaceTraders.Model.Route

View file

@ -1,14 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module SpaceTraders.Model.Ship
( Ship(..)
) where
import Data.Aeson
import GHC.Generics
import qualified Data.Text as T
import GHC.Generics
import SpaceTraders.Model.Cargo
import SpaceTraders.Model.Fuel

View file

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
@ -10,7 +9,7 @@ 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

View file

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

View file

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

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