diff options
| -rw-r--r-- | .gitignore | 14 | ||||
| -rw-r--r-- | haskell/Setup.hs | 2 | ||||
| -rw-r--r-- | haskell/app/Main.hs | 31 | ||||
| -rw-r--r-- | haskell/package.yaml | 62 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/APIClient/Agent.hs | 34 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/APIClient/Client.hs | 69 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/Database.hs | 56 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/Database/Agents.hs | 14 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/Database/Tokens.hs | 18 | ||||
| -rw-r--r-- | haskell/src/SpaceTraders/Model/Agent.hs | 22 | ||||
| -rw-r--r-- | haskell/stack.yaml | 67 | ||||
| -rw-r--r-- | haskell/test/Spec.hs | 2 |
12 files changed, 389 insertions, 2 deletions
@@ -1,3 +1,13 @@ +*.db +*.db-shm +*.db-wal + +dist* +*.hi +*.o +*.cabal +.stack-work/ +stack.yaml.lock +*~ + node_modules -spacetraders.db -test.db diff --git a/haskell/Setup.hs b/haskell/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/haskell/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs new file mode 100644 index 0000000..32aa908 --- /dev/null +++ b/haskell/app/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +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.Database +import SpaceTraders.Database.Agents +import SpaceTraders.Database.Tokens + +main :: IO () +main = do + conn <- open + t <- getToken conn `catch` registerNow conn + ma <- myAgent t + print ma + 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' + let t = token r' + setToken conn $ t + return t + Left e' -> throwIO e' diff --git a/haskell/package.yaml b/haskell/package.yaml new file mode 100644 index 0000000..8023a22 --- /dev/null +++ b/haskell/package.yaml @@ -0,0 +1,62 @@ +name: spacetraders +version: 0.1.0.0 +github: "adyxax/spacetraders" +license: EUPL-1.2 +author: "Julien Dessaux" +maintainer: "julien.dessaux@adyxax.org" +copyright: "2023 Julien Dessaux" + +extra-source-files: +- README.md +- CHANGELOG.md + +synopsis: My spacetraders.io game client implementation +category: Games + +description: Please see the README on GitHub at <https://github.com/adyxax/spacetraders#readme> + +dependencies: +- aeson +- base >= 4.7 && < 5 +- bytestring +- http-conduit +- http-types +- sqlite-simple +- text +- raw-strings-qq + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src + +executables: + spacetraders-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - spacetraders + +tests: + spacetraders-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - spacetraders diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs new file mode 100644 index 0000000..997d1e5 --- /dev/null +++ b/haskell/src/SpaceTraders/APIClient/Agent.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.APIClient.Agent + ( RegisterMessage(..) + , myAgent + , register + ) where + +import Data.Aeson +import GHC.Generics +import qualified Data.Text as T +import Network.HTTP.Simple + +import SpaceTraders.APIClient.Client +import SpaceTraders.Model.Agent + +myAgent :: T.Text -> IO (Either APIError Agent) +myAgent t = send $ setRequestPath "/v2/my/agent" + $ tokenReq t + +data RegisterRequest = RegisterRequest { symbol :: T.Text + , faction :: T.Text + } deriving (ToJSON, Generic, Show) +data RegisterMessage = RegisterMessage { token :: T.Text + , agent :: Agent + } deriving (FromJSON, Generic, Show) + +register :: T.Text -> T.Text -> IO (Either APIError RegisterMessage) +register s f = send $ setRequestPath "/v2/register" + $ setRequestMethod "POST" + $ setRequestBodyJSON RegisterRequest{symbol = s, faction = f} + $ defaultReq diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs new file mode 100644 index 0000000..e4744aa --- /dev/null +++ b/haskell/src/SpaceTraders/APIClient/Client.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.APIClient.Client + ( APIError(..) + , APIMessage(..) + , defaultReq + , fromJSONValue + , send + , tokenReq + ) where + +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Simple +import Network.HTTP.Types.Status + +data APIError = APIError { apiErrorCode :: Int + , apiErrorMessage :: T.Text + } deriving Show +instance Exception APIError +instance FromJSON APIError where + parseJSON (Object o) = do + e <- o .: "error" + APIError <$> e .: "code" + <*> e .: "message" + parseJSON _ = mzero + +data APIMessage = APIMessage { data_ :: Value } deriving (Show) +instance FromJSON APIMessage where + parseJSON (Object o) = APIMessage <$> o .: "data" + parseJSON _ = mzero + +defaultReq :: Request +defaultReq = setRequestHost "api.spacetraders.io" + $ setRequestPort 443 + $ setRequestSecure True + $ setRequestHeader "Content-Type" ["application/json"] + $ defaultRequest + +tokenReq :: T.Text -> Request +tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] + $ defaultReq + +fromJSONValue :: FromJSON a => Value -> Either String a +fromJSONValue = parseEither parseJSON + +send :: FromJSON a => Request -> IO (Either APIError a) +send 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{apiErrorCode = -1000, apiErrorMessage = T.pack $ concat ["Error decoding JSON APIMessage: ", e]} + Right r -> case fromJSONValue (data_ r) of + Left e -> return $ Left APIError{apiErrorCode = -1001, apiErrorMessage = T.pack $ concat ["Error decoding JSON message contents: ", e]} + Right m -> return $ Right m + else case eitherDecode body of + Left e -> return $ Left APIError{apiErrorCode = -status, apiErrorMessage = T.pack $ concat ["Error decoding JSON APIError: ", e, ". Got HTTP body: ", show body]} + Right e -> return $ Left e + +--handleAPIError :: SomeException -> IO (Maybe RegisterMessage) +--handleAPIError e = do +-- print e +-- return Nothing diff --git a/haskell/src/SpaceTraders/Database.hs b/haskell/src/SpaceTraders/Database.hs new file mode 100644 index 0000000..fdc32d3 --- /dev/null +++ b/haskell/src/SpaceTraders/Database.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module SpaceTraders.Database + ( close + , open + ) where + +import Control.Exception +import qualified Database.SQLite.Simple as S +import Text.RawString.QQ + +migrations :: [S.Query] +migrations = [ + [r|CREATE TABLE schema_version ( + version INTEGER NOT NULL + ); + |], + [r|CREATE TABLE tokens ( + id INTEGER PRIMARY KEY, + data TEXT NOT NULL + ); + |], + [r|CREATE TABLE agents ( + id INTEGER PRIMARY KEY, + data TEXT NOT NULL + ); + |], + [r|CREATE TABLE contracts ( + id INTEGER PRIMARY KEY, + data TEXT NOT NULL + ); + |]] + +close :: S.Connection -> IO () +close conn = S.close conn + +open :: IO S.Connection +open = do + conn <- S.open "spacetraders.db" + S.execute_ conn "PRAGMA foreign_keys = ON;" + S.execute_ conn "PRAGMA journal_mode = WAL;" + S.withTransaction conn $ do + version <- getSchemaVersion conn `catch` defaultVersion + mapM_ (S.execute_ conn) $ 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 + +getSchemaVersion :: S.Connection -> IO Int +getSchemaVersion conn = do + [[v]] <- S.query_ conn "SELECT version FROM schema_version;" + return v + +defaultVersion :: SomeException -> IO Int +defaultVersion _ = return 0 diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs new file mode 100644 index 0000000..5be7389 --- /dev/null +++ b/haskell/src/SpaceTraders/Database/Agents.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module SpaceTraders.Database.Agents + ( setAgent + ) where + +import Data.Aeson +import qualified Database.SQLite.Simple as S + +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)) diff --git a/haskell/src/SpaceTraders/Database/Tokens.hs b/haskell/src/SpaceTraders/Database/Tokens.hs new file mode 100644 index 0000000..b907609 --- /dev/null +++ b/haskell/src/SpaceTraders/Database/Tokens.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module SpaceTraders.Database.Tokens + ( getToken + , setToken + ) where + +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 + +setToken :: S.Connection -> T.Text -> IO () +setToken conn value = S.execute conn "INSERT INTO tokens(data) VALUES (?);" (S.Only value) diff --git a/haskell/src/SpaceTraders/Model/Agent.hs b/haskell/src/SpaceTraders/Model/Agent.hs new file mode 100644 index 0000000..be97ac4 --- /dev/null +++ b/haskell/src/SpaceTraders/Model/Agent.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SpaceTraders.Model.Agent + ( Agent(accountId, credits, headquarters) + , agentSymbol + ) where + +import Data.Aeson +import GHC.Generics +import qualified Data.Text as T + +data Agent = Agent { accountId :: T.Text + , credits :: Integer + , headquarters :: T.Text + , startingFaction :: T.Text + , symbol :: T.Text + } deriving (FromJSON, Generic, Show, ToJSON) + +agentSymbol :: Agent -> T.Text +agentSymbol = symbol diff --git a/haskell/stack.yaml b/haskell/stack.yaml new file mode 100644 index 0000000..d84c077 --- /dev/null +++ b/haskell/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# 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/0.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.9" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/haskell/test/Spec.hs b/haskell/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/haskell/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" |