[haskell] Implemented contract

6 files changed, 82 insertions, 5 deletions

diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs
index 32aa908..08e412d 100644
--- a/haskell/app/Main.hs
+++ b/haskell/app/Main.hs
@@ -9,6 +9,7 @@ import qualified Data.Text as T
 import SpaceTraders.APIClient.Agent
 import SpaceTraders.Database
 import SpaceTraders.Database.Agents
+import SpaceTraders.Database.Contracts
 import SpaceTraders.Database.Tokens
 
 main :: IO ()
@@ -25,6 +26,7 @@ main = do
       case r of
         Right r' -> do
           setAgent conn $ agent r'
+          addContract conn $ contract r'
           let t = token r'
           setToken conn $ t
           return t
diff --git a/haskell/package.yaml b/haskell/package.yaml
index 8023a22..c464ad9 100644
--- a/haskell/package.yaml
+++ b/haskell/package.yaml
@@ -23,6 +23,7 @@ dependencies:
 - http-types
 - sqlite-simple
 - text
+- time
 - raw-strings-qq
 
 ghc-options:
diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs
index 997d1e5..6728baf 100644
--- a/haskell/src/SpaceTraders/APIClient/Agent.hs
+++ b/haskell/src/SpaceTraders/APIClient/Agent.hs
@@ -15,16 +15,18 @@ import Network.HTTP.Simple
 
 import SpaceTraders.APIClient.Client
 import SpaceTraders.Model.Agent
+import SpaceTraders.Model.Contract
 
 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
+data RegisterRequest = RegisterRequest { faction :: T.Text
+                                       , symbol :: T.Text
                                        } deriving (ToJSON, Generic, Show)
-data RegisterMessage = RegisterMessage { token :: T.Text
-                                       , agent :: Agent
+data RegisterMessage = RegisterMessage { agent :: Agent
+                                       , contract :: Contract
+                                       , token :: T.Text
                                        } deriving (FromJSON, Generic, Show)
 
 register :: T.Text -> T.Text -> IO (Either APIError RegisterMessage)
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index 5be7389..48cd65b 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 
 module SpaceTraders.Database.Agents
   ( setAgent
diff --git a/haskell/src/SpaceTraders/Database/Contracts.hs b/haskell/src/SpaceTraders/Database/Contracts.hs
new file mode 100644
index 0000000..1ef5d6d
--- /dev/null
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.Database.Contracts
+  ( addContract
+  ) where
+
+import Data.Aeson
+import qualified Database.SQLite.Simple as S
+
+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))
diff --git a/haskell/src/SpaceTraders/Model/Contract.hs b/haskell/src/SpaceTraders/Model/Contract.hs
new file mode 100644
index 0000000..fd7a70b
--- /dev/null
+++ b/haskell/src/SpaceTraders/Model/Contract.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SpaceTraders.Model.Contract
+  ( Contract(..)
+  , Delivery(..)
+  , Payment(..)
+  , Terms(..)
+  ) where
+
+import Control.Monad
+import Data.Aeson
+import Data.Time
+import GHC.Generics
+import qualified Data.Text as T
+
+data Contract = Contract { accepted :: Bool
+                         , contractId :: T.Text
+                         , contractType :: T.Text
+                         , expiration :: UTCTime
+                         , deadlineToAccept :: UTCTime
+                         , factionSymbol :: T.Text
+                         , fulfilled :: Bool
+                         , terms :: Terms
+                         } deriving (Generic, Show)
+instance FromJSON Contract where
+  parseJSON (Object o) = Contract <$> o .: "accepted"
+                                  <*> o .: "id"
+                                  <*> o .: "type"
+                                  <*> o .: "expiration"
+                                  <*> o .: "deadlineToAccept"
+                                  <*> o .: "factionSymbol"
+                                  <*> o .: "fulfilled"
+                                  <*> o .: "terms"
+  parseJSON _ = mzero
+instance ToJSON Contract where
+  toEncoding (Contract a i ty e d fa fu te) = pairs ( "accepted" .= a
+                                                   <> "id" .= i
+                                                   <> "type" .= ty
+                                                   <> "expiration" .= e
+                                                   <> "deadlineToAccept" .= d
+                                                   <> "factionSymbol" .= fa
+                                                   <> "fulfilled" .= fu
+                                                   <> "terms" .= te )
+
+data Delivery = Delivery { destinationSymbol :: T.Text
+                         , tradeSymbol :: T.Text
+                         , unitsFulfilled :: Int
+                         , unitsRequired :: Int
+                         } deriving (FromJSON, Generic, Show, ToJSON)
+
+data Payment = Payment { onAccepted :: Int
+                       , onFulfilled :: Int
+                       } deriving (FromJSON, Generic, Show, ToJSON)
+
+data Terms = Terms { deadline :: UTCTime
+                   , deliver :: [Delivery]
+                   , payment :: Payment
+                   } deriving (FromJSON, Generic, Show, ToJSON)