[haskell] Refactored everything with a ReaderT pattern

haskell/app/Main.hs

@@ -3,19 +3,34 @@
 module Main (main) where
 
 import Control.Exception
+import System.Environment
+import System.Posix.Process
 
 import SpaceTraders
 import SpaceTraders.Automation.Init
 import SpaceTraders.APIClient.Agent(myAgent)
+import SpaceTraders.APIClient.Client
+import SpaceTraders.APIClient.Ships
 import SpaceTraders.APIClient.Systems
 
 main :: IO ()
 main = do
-  config <- initST
-  ma <- runSpaceTradersT myAgent config
-  print ma
-  s <- listSystems (token config) (conn config)
+  env <- initST
+  ma <- runSpaceTradersT myAgent env
+  case ma of
+   Left (APIResetHappened _) -> do
+     p <- getExecutablePath
+     a <- getArgs
+     e <- getEnvironment
+     executeFile p False a (Just e)
+   Left e -> throwIO e
+   Right ma' -> print ma'
+  s <- runSpaceTradersT listSystems env
   case s of
     Left e -> throwIO e
     Right s' -> print $ length s'
-  deinitST config
+  ships <- runSpaceTradersT listShips env
+  case ships of
+    Left e -> throwIO e
+    Right s' -> print $ s'
+  deinitST env

haskell/package.yaml

@@ -22,11 +22,11 @@ dependencies:
 - directory
 - http-conduit
 - http-types
+- mtl
 - raw-strings-qq
 - sqlite-simple
 - text
 - time
-- transformers
 - unix
 
 ghc-options:

haskell/src/SpaceTraders.hs

@@ -3,21 +3,36 @@
 module SpaceTraders
   ( SpaceTradersT
   , runSpaceTradersT
-  , Config(..)
+  , Env(..)
+  , HasDatabaseConn
+  , HasRequest
   , ask
+  , getConn
+  , getRequest
   , liftIO
   ) where
 
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
+import Control.Monad.Reader
 import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
+import Network.HTTP.Simple
 
-type SpaceTradersT a = ReaderT Config IO a
+type SpaceTradersT a = ReaderT Env IO a
 
-runSpaceTradersT :: SpaceTradersT a -> Config -> IO a
+runSpaceTradersT :: SpaceTradersT a -> Env -> IO a
 runSpaceTradersT = runReaderT
 
-data Config = Config { conn :: S.Connection
-                     , token :: T.Text
-                     }
+data Env = Env { envConn :: S.Connection
+               , envRequest :: Request }
+
+class HasDatabaseConn a where
+  getConn :: a -> S.Connection
+instance HasDatabaseConn S.Connection where
+  getConn = id
+instance HasDatabaseConn Env where
+  getConn = envConn
+
+class HasRequest a where
+  getRequest :: a -> Request
+instance HasRequest Env where
+  getRequest = envRequest

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}

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

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

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

haskell/src/SpaceTraders/Automation/Init.hs

@@ -6,53 +6,55 @@ module SpaceTraders.Automation.Init
   ) where
 
 import Control.Exception
+import Control.Monad.Reader
 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.APIClient.Agent
+import SpaceTraders.APIClient.Client
 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
+deinitST :: Env -> IO ()
+deinitST env = do
+  close $ getConn env
 
-initST :: IO Config
+initST :: IO Env
 initST = do
-  c <- open
-  t <- getToken c `catch` handleNoToken c
-  ma <- runSpaceTradersT STAA.myAgent (Config c t)
+  conn <- open
+  t <- runReaderT getToken conn `catch` handleNoToken conn
+  let env = Env conn (tokenReq t)
+  ma <- runSpaceTradersT myAgent env
   case ma of
-    Left (APIResetHappened _) -> wipe c
+    Left (APIResetHappened _) -> wipe conn
     Left e -> throwIO e
-    _ -> return $ Config c t
+    _ -> return $ env
   where
     handleNoToken :: S.Connection -> SomeException -> IO T.Text
-    handleNoToken c _ = register c
+    handleNoToken conn _ = runReaderT registerST (Env conn defaultReq)
 
-register :: S.Connection -> IO (T.Text)
-register c = do
-  r <- STAA.register "ADYXAX" "COSMIC"
+registerST :: SpaceTradersT (T.Text)
+registerST = do
+  r <- 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
+      addAgent $ agent r'
+      addContract $ contract r'
+      addShip $ ship r'
+      let t = token r'
+      addToken t
       return t
-    Left e' -> throwIO e'
+    Left e' -> throw e'
 
-wipe :: S.Connection -> IO Config
+wipe :: S.Connection -> IO Env
 wipe c = do
       close c
       removeFile "spacetraders.db"
       conn' <- open
-      t <- register conn'
-      return $ Config conn' t
+      t <- runReaderT registerST (Env conn' defaultReq)
+      return $ Env conn' (tokenReq t)

haskell/src/SpaceTraders/Database/Agents.hs

@@ -1,13 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Agents
-  ( setAgent
+  ( addAgent
   ) where
 
+import Control.Monad.Reader
 import Data.Aeson
 import qualified Database.SQLite.Simple as S
 
+import SpaceTraders
 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))
+addAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
+addAgent agent = do
+  env <- ask
+  liftIO $ S.execute (getConn env) "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))

haskell/src/SpaceTraders/Database/Contracts.hs

@@ -4,10 +4,14 @@ module SpaceTraders.Database.Contracts
   ( addContract
   ) where
 
+import Control.Monad.Reader
 import Data.Aeson
 import qualified Database.SQLite.Simple as S
 
+import SpaceTraders
 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))
+addContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
+addContract contract = do
+  env <- ask
+  liftIO $ S.execute (getConn env) "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))

haskell/src/SpaceTraders/Database/Ships.hs

@@ -4,10 +4,14 @@ module SpaceTraders.Database.Ships
   ( addShip
   ) where
 
+import Control.Monad.Reader
 import Data.Aeson
 import qualified Database.SQLite.Simple as S
 
+import SpaceTraders
 import SpaceTraders.Model.Ship
 
-addShip :: S.Connection -> Ship -> IO ()
-addShip conn ship = S.execute conn "INSERT INTO ships(data) VALUES (json(?));" (S.Only (encode ship))
+addShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
+addShip ship = do
+  env <- ask
+  liftIO $ S.execute (getConn env) "INSERT INTO ships(data) VALUES (json(?));" (S.Only (encode ship))

haskell/src/SpaceTraders/Database/Systems.hs

@@ -5,19 +5,23 @@ module SpaceTraders.Database.Systems
   , getSystems
   ) where
 
+import Control.Monad.Reader
 import Data.Aeson
 import Data.Maybe
 import qualified Database.SQLite.Simple as S
 
-import Data.Text.Encoding (encodeUtf8Builder)
-import Data.ByteString.Builder(toLazyByteString)
-
+import SpaceTraders
+import SpaceTraders.Database.Utils
 import SpaceTraders.Model.System
 
-addSystems :: S.Connection -> [System] -> IO ()
-addSystems conn systems = S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems
+addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m ()
+addSystems systems = do
+  env <- ask
+  let conn = getConn env
+  liftIO $ S.withTransaction conn $ S.executeMany conn "INSERT INTO systems(data) VALUES (json(?));" $ S.Only <$> map encode systems
 
-getSystems :: S.Connection -> IO [System]
-getSystems conn = do
-  ret <- S.query_ conn "SELECT data from systems;"
-  return . catMaybes $ map (decode . toLazyByteString . encodeUtf8Builder . head) ret
+getSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [System]
+getSystems = do
+  env <- ask
+  ret <- liftIO $ S.query_ (getConn env) "SELECT data from systems;"
+  return . catMaybes $ map (decodeText . head) ret

haskell/src/SpaceTraders/Database/Tokens.hs

@@ -2,17 +2,23 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 module SpaceTraders.Database.Tokens
-  ( getToken
-  , setToken
+  ( addToken
+  , getToken
   ) where
 
+import Control.Monad.Reader
 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
+import SpaceTraders
 
-setToken :: S.Connection -> T.Text -> IO ()
-setToken conn value = S.execute conn "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
+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)
+
+getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text
+getToken = do
+  env <- ask
+  [[token]] <- liftIO $ S.query_ (getConn env) "SELECT data FROM tokens;"
+  return token

haskell/src/SpaceTraders/Database/Utils.hs

@@ -0,0 +1,11 @@
+module SpaceTraders.Database.Utils
+  ( decodeText
+  ) where
+
+import Data.Aeson
+import Data.ByteString.Builder(toLazyByteString)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8Builder)
+
+decodeText :: FromJSON a => T.Text -> Maybe a
+decodeText = decode . toLazyByteString . encodeUtf8Builder