[haskell] Add a SpaceTradersT and handle server reset api message

6 files changed, 110 insertions, 31 deletions

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