[haskell] Refactored everything with a ReaderT pattern

4 files changed, 86 insertions, 57 deletions

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