[haskell] refactoring

haskell/app/Main.hs

@@ -1,11 +1,10 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main (main) where
 
 import           SpaceTraders
-import SpaceTraders.Automation.Init
+import           SpaceTraders.APIClient.Agent
+import           SpaceTraders.APIClient.Contracts
 import           SpaceTraders.APIClient.Ships
-import SpaceTraders.APIClient.Systems
+import           SpaceTraders.Automation.Init
 
 main :: IO ()
 main = do
@@ -15,7 +14,11 @@ main = do
   where
     main' :: SpaceTradersT ()
     main' = do
-      _ <- initSystems
+      -- refresh our core objects
+      _ <- myAgent
+      _ <- myContracts
       (Right ships) <- myShips -- work around to fetch the initial probe
-      _ <- orbit (head ships)
+      let cmdShip = head ships
+      (Right t) <- orbit cmdShip
+      liftIO $ print t
       return ()

haskell/src/SpaceTraders.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module SpaceTraders
   ( SpaceTradersT
   , microSinceEpoch

haskell/src/SpaceTraders/APIClient/Agent.hs

@@ -10,18 +10,23 @@ module SpaceTraders.APIClient.Agent
 
 import           Control.Monad.Reader
 import           Data.Aeson
-import GHC.Generics
 import qualified Data.Text                     as T
+import           GHC.Generics
 import           Network.HTTP.Simple
 
 import           SpaceTraders
 import           SpaceTraders.APIClient.Client
+import           SpaceTraders.Database.Agents
 import           SpaceTraders.Model.Agent      (Agent)
-import SpaceTraders.Model.Ship(Ship)
 import           SpaceTraders.Model.Contract
+import           SpaceTraders.Model.Ship       (Ship)
 
 myAgent :: SpaceTradersT (APIResponse Agent)
-myAgent = send $ setRequestPath "/v2/my/agent"
+myAgent = do
+  a@(Right ag) <- send $ setRequestPath "/v2/my/agent"
+  setAgent ag
+  return a
+
 
 data RegisterRequest = RegisterRequest { faction :: T.Text
                                        , symbol  :: T.Text

haskell/src/SpaceTraders/APIClient/Client.hs

@@ -29,7 +29,7 @@ import SpaceTraders.APIClient.Errors
 import           SpaceTraders.APIClient.Pagination
 import           SpaceTraders.Utils
 
-data FromJSON a => APIMessage a = APIMessage { messageData :: a
+data APIMessage a = APIMessage { messageData       :: a
                                , messagePagination :: Maybe Pagination
                                } deriving (Show)
 instance FromJSON a => FromJSON (APIMessage a) where
@@ -45,7 +45,7 @@ defaultReq = setRequestHost "api.spacetraders.io"
            $ setRequestPort 443
            $ setRequestSecure True
            $ setRequestHeader "Content-Type" ["application/json"]
-           $ defaultRequest
+             defaultRequest
 
 tokenReq :: T.Text -> Request
 tokenReq token = setRequestHeader "Authorization" [T.encodeUtf8 $ "Bearer " <> token] defaultReq
@@ -63,7 +63,7 @@ sendPaginated pagination requestBuilder = do
   let request = requestBuilder $ getRequest env
       request' = case pagination of
         Just myPage -> setRequestQueryString [("limit", Just . int2ByteString $ limit myPage), ("page", Just . int2ByteString $ page myPage)]
-                                           $ request
+                                             request
         Nothing -> request
   sendPaginated' request'
   where
@@ -82,12 +82,12 @@ sendPaginated pagination requestBuilder = do
           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
+          Left e -> return . Left $ APIError (-1000) (T.pack $ "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 $ delay (1_000_000 * (round $ retryAfter r))
+            liftIO $ delay (1_000_000 * round (retryAfter r))
             sendPaginated' request
           Right (APIResetHappened _) -> liftIO $ do
             removeFile "spacetraders.db"

haskell/src/SpaceTraders/APIClient/Contracts.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Contracts
@@ -25,6 +23,6 @@ myContracts = do
         Left e -> return $ Left e
         Right (APIMessage r (Just p')) -> do
           mapM_ setContract r
-          if (limit p' * page p' < total p') then listContracts' (nextPage p')
+          if limit p' * page p' < total p' then listContracts' (nextPage p')
                                              else Right <$> getContracts
         _ -> undefined

haskell/src/SpaceTraders/APIClient/Errors.hs

@@ -10,8 +10,8 @@ module SpaceTraders.APIClient.Errors
 
 import           Control.Exception
 import           Data.Aeson
-import Data.Time
 import qualified Data.Text         as T
+import           Data.Time
 import           GHC.Generics
 
 data APIError = APIError Int T.Text Value
@@ -27,8 +27,7 @@ instance FromJSON APIError where
     case code of
       401 -> APIResetHappened <$> parseJSON d
       429 -> APIRateLimit <$> parseJSON d
-      _ -> APIError <$> pure code
+      _ -> APIError code <$> e .: "message"
-                    <*> e .: "message"
                          <*> pure d
 
 data RateLimit = RateLimit { limitBurst     :: Int

haskell/src/SpaceTraders/APIClient/Pagination.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Pagination
   ( Pagination(..)

haskell/src/SpaceTraders/APIClient/Ships.hs

@@ -20,7 +20,8 @@ import SpaceTraders.Database.Ships
 import           SpaceTraders.Model.Nav
 import           SpaceTraders.Model.Ship
 
-data NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show)
+newtype NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show)
+
 dock :: Ship -> SpaceTradersT (APIResponse Ship)
 dock ship = do
   resp <- send $ setRequestPath (T.encodeUtf8 $ mconcat ["/v2/my/ships/", symbol ship, "/dock"])
@@ -29,7 +30,7 @@ dock ship = do
     Left e -> return $ Left e
     Right (NavMessage n) -> do
       let s = ship{SpaceTraders.Model.Ship.nav=n}
-      updateShip s
+      setShip s
       return $ Right s
 
 myShips :: SpaceTradersT (APIResponse [Ship])
@@ -43,7 +44,7 @@ myShips = do
         Left e -> return $ Left e
         Right (APIMessage r (Just p')) -> do
           mapM_ setShip r
-          if (limit p' * page p' < total p') then listShips' (nextPage p')
+          if limit p' * page p' < total p' then listShips' (nextPage p')
                                            else Right <$> getShips
         _ -> undefined
 
@@ -55,5 +56,5 @@ orbit ship = do
     Left e -> return $ Left e
     Right (NavMessage n) -> do
       let s = ship{SpaceTraders.Model.Ship.nav=n}
-      updateShip s
+      setShip s
       return $ Right s

haskell/src/SpaceTraders/APIClient/Systems.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Systems
@@ -18,7 +16,7 @@ import SpaceTraders.Model.System(System)
 initSystems :: SpaceTradersT (APIResponse [System])
 initSystems = do
   s <- getSystems
-  listSystems' Pagination{limit=20, page=((length s) `div` 20) + 1, total=0}
+  listSystems' Pagination{limit=20, page=(length s `div` 20) + 1, total=0}
   where
     listSystems' :: Pagination -> SpaceTradersT (APIResponse [System])
     listSystems' p = do
@@ -27,6 +25,6 @@ initSystems = do
         Left e -> throw e
         Right (APIMessage r (Just p')) -> do
           addSystems r
-          if (limit p' * page p' < total p') then listSystems' (nextPage p')
+          if limit p' * page p' < total p' then listSystems' (nextPage p')
                                            else Right <$> getSystems
         _ -> undefined

haskell/src/SpaceTraders/Automation/Init.hs

@@ -6,9 +6,10 @@ module SpaceTraders.Automation.Init
   ) where
 
 import           Control.Exception
+import           Control.Monad.Error.Class
 import           Control.Monad.Reader
-import qualified Database.SQLite.Simple as S
 import qualified Data.Text                        as T
+import qualified Database.SQLite.Simple           as S
 import           System.Directory
 
 import           SpaceTraders
@@ -30,7 +31,7 @@ deinitST env = do
 initST :: IO Env
 initST = do
   conn <- open
-  t <- runReaderT getToken conn `catch` handleNoToken conn
+  t <- runReaderT getToken conn `catchError` handleNoToken conn
   env <- newEnv conn (tokenReq t)
   ma <- runReaderT getAgent conn -- We compare the agent state in the database
   ma' <- runSpaceTradersT myAgent env -- with the one on the servers
@@ -42,21 +43,21 @@ initST = do
         _ <- runReaderT myContracts env -- refresh contracts
         _ <- runReaderT myShips env -- refresh ships
         runReaderT (setAgent ma'') conn -- store the fresh agent state
-      return $ env
+      return env
   where
-    handleNoToken :: S.Connection -> SomeException -> IO T.Text
+    handleNoToken :: S.Connection -> IOException -> IO T.Text
     handleNoToken conn _ = newEnv conn defaultReq >>= runReaderT registerST
 
-registerST :: SpaceTradersT (T.Text)
+registerST :: SpaceTradersT T.Text
 registerST = do
-  r <- register "ADYXAX-HS" "COSMIC"
+  r <- register "ADYXAX-HS-6" "COSMIC"
   case r of
     Right r' -> do
       let t = token r'
       addToken t
-      addAgent $ agent r'
+      setAgent $ agent r'
-      addContract $ contract r'
+      setContract $ contract r'
-      addShip $ ship r'
+      setShip $ ship r'
       return t
     Left e' -> throw e'
 

haskell/src/SpaceTraders/Database.hs

@@ -10,15 +10,15 @@ module SpaceTraders.Database
 import           Control.Exception
 import qualified Data.ByteString        as B
 import           Data.FileEmbed
-import qualified Database.SQLite.Simple as S
 import qualified Data.Text              as T
 import qualified Data.Text.Encoding     as T
+import qualified Database.SQLite.Simple as S
 
 migrations :: [B.ByteString]
 migrations = [ $(embedFile "src/SpaceTraders/Database/000_init.sql") ]
 
 close :: S.Connection -> IO ()
-close conn = S.close conn
+close = S.close
 
 open :: IO S.Connection
 open = do
@@ -27,7 +27,7 @@ open = do
   S.execute_ conn "PRAGMA journal_mode = WAL;"
   S.withTransaction conn $ do
     version <- getSchemaVersion conn `catch` defaultVersion
-    mapM_ (S.execute_ conn) $ S.Query <$> (filter (/= "\n") . concat . map ((T.splitOn ";") . T.decodeUtf8) $ drop version migrations)
+    mapM_ (S.execute_ conn) $ S.Query <$> concatMap (filter (/= "\n") . T.splitOn ";" . T.decodeUtf8) (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

haskell/src/SpaceTraders/Database/Agents.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Agents
-  ( addAgent
+  ( getAgent
-  , getAgent
   , setAgent
   ) where
 
+import           Control.Monad.Error.Class
 import           Control.Monad.Reader
 import           Data.Aeson
 import qualified Database.SQLite.Simple    as S
@@ -14,11 +14,11 @@ import SpaceTraders
 import           SpaceTraders.Model.Agent
 import           SpaceTraders.Utils
 
-addAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
-addAgent agent = execute "INSERT INTO agents(data) VALUES (json(?));" (S.Only (encode agent))
-
 getAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m Agent
-getAgent = one_ "SELECT data FROM agents";
+getAgent = one_ "SELECT data FROM agents"; -- we only support one agent at a time
 
-setAgent :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Agent -> m ()
+setAgent :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Agent -> m ()
-setAgent agent = execute "UPDATE agents SET data = json(?);" (S.Only (encode agent))
+setAgent agent = updateAgent `catchError` addAgent
+  where
+    addAgent _ = execute "INSERT INTO agents(data) VALUES (json(?));" (S.Only $ encode agent)
+    updateAgent = execute "UPDATE agents SET data = json(?);" (S.Only (encode agent))

haskell/src/SpaceTraders/Database/Contracts.hs

@@ -1,12 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Contracts
-  ( addContract
+  ( getContracts
-  , getContracts
   , setContract
-  , updateContract
   ) where
 
+import           Control.Monad.Error.Class
 import           Control.Monad.Reader
 import           Data.Aeson
 import qualified Database.SQLite.Simple      as S
@@ -15,17 +14,11 @@ import SpaceTraders
 import           SpaceTraders.Model.Contract
 import           SpaceTraders.Utils
 
-addContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
-addContract contract = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
-
 getContracts :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Contract]
 getContracts = query_ "SELECT data FROM contracts;"
 
-setContract :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Contract -> m ()
+setContract :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Contract -> m ()
-setContract contract = do
+setContract contract = updateContract `catchError` addContract
-  c <- count "SELECT count(id) FROM contracts WHERE data->>'contractId' = ?;" (S.Only $ contractId contract)
+  where
-  if c == 0 then addContract contract
+    addContract _ = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
-            else updateContract contract
+    updateContract = execute "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId contract)
-
-updateContract :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Contract -> m ()
-updateContract contract = execute "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId contract)

haskell/src/SpaceTraders/Database/Ships.hs

@@ -1,12 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Ships
-  ( addShip
+  ( getShips
-  , getShips
   , setShip
-  , updateShip
   ) where
 
+import           Control.Monad.Error.Class
 import           Control.Monad.Reader
 import           Data.Aeson
 import qualified Database.SQLite.Simple    as S
@@ -15,17 +14,11 @@ import SpaceTraders
 import           SpaceTraders.Model.Ship
 import           SpaceTraders.Utils
 
-addShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
-addShip ship = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
-
 getShips :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => m [Ship]
 getShips = query_ "SELECT data FROM ships;"
 
-setShip :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => Ship -> m ()
+setShip :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Ship -> m ()
-setShip ship = do
+setShip ship = updateShip `catchError` addShip
-  c <- count "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship)
+  where
-  if c == 0 then addShip ship
+    addShip _ = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
-            else updateShip ship
+    updateShip = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
-
-updateShip :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => Ship -> m ()
-updateShip ship = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)

haskell/src/SpaceTraders/Database/Tokens.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 
 module SpaceTraders.Database.Tokens
   ( addToken
@@ -7,15 +6,14 @@ module SpaceTraders.Database.Tokens
   ) where
 
 import           Control.Monad.Reader
-import qualified Database.SQLite.Simple as S
 import qualified Data.Text              as T
+import qualified Database.SQLite.Simple as S
 
 import           SpaceTraders
+import           SpaceTraders.Utils
 
 addToken :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => T.Text -> m ()
-addToken value = do
+addToken value = execute "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
-  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

haskell/src/SpaceTraders/Model/Agent.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Agent
   ( Agent(..)
   ) where
 
 import           Data.Aeson
-import GHC.Generics
 import qualified Data.Text    as T
+import           GHC.Generics
 
 data Agent = Agent { accountId       :: T.Text
                    , credits         :: Integer

haskell/src/SpaceTraders/Model/Cargo.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Cargo
   ( Cargo(..)

haskell/src/SpaceTraders/Model/Fuel.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Fuel
   ( Consumed(..)

haskell/src/SpaceTraders/Model/Inventory.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Inventory
   ( Inventory(..)
   ) where
 
 import           Data.Aeson
-import GHC.Generics
 import qualified Data.Text    as T
+import           GHC.Generics
 
 data Inventory = Inventory { description :: T.Text
                            , name        :: T.Text

haskell/src/SpaceTraders/Model/Nav.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Nav
   ( Nav(..)
   ) where
 
 import           Data.Aeson
-import GHC.Generics
 import qualified Data.Text                as T
+import           GHC.Generics
 
 import           SpaceTraders.Model.Route
 

haskell/src/SpaceTraders/Model/Ship.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Ship
   ( Ship(..)
   ) where
 
 import           Data.Aeson
-import GHC.Generics
 import qualified Data.Text                as T
+import           GHC.Generics
 
 import           SpaceTraders.Model.Cargo
 import           SpaceTraders.Model.Fuel

haskell/src/SpaceTraders/Model/System.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 

haskell/src/SpaceTraders/Model/Waypoint.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 

haskell/src/SpaceTraders/Utils.hs

@@ -43,16 +43,16 @@ int2ByteString :: Int -> B.ByteString
 int2ByteString = B.pack . map B.c2w . show
 
 one_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m b
-one_ q = query_ q >>= pure . head
+one_ q = head <$> query_ q
 
 query :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m [b]
 query q t = do
   env <- ask
   ret <- liftIO $ S.query (getConn env) q t
-  return . catMaybes $ map (decodeText . head) ret
+  return $ mapMaybe (decodeText . head) ret
 
 query_ :: (FromJSON b, HasDatabaseConn env, MonadReader env m, MonadIO m) => S.Query -> m [b]
 query_ q = do
   env <- ask
   ret <- liftIO $ S.query_ (getConn env) q
-  return . catMaybes $ map (decodeText . head) ret
+  return $ mapMaybe (decodeText . head) ret

haskell/stack.yaml

@@ -17,8 +17,9 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
+#resolver: lts-22.13
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml
+resolver: lts-21.25
+#  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/14.yaml
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -49,7 +50,7 @@ packages:
 # extra-package-dbs: []
 
 # Control whether we use the GHC we find on the path
-# system-ghc: true
+system-ghc: true
 #
 # Require a specific version of Stack, using version ranges
 # require-stack-version: -any # Default