From 7e27a0a7eada373780a9757fd89f70d4d911d69a Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Fri, 22 Mar 2024 01:13:34 +0100
Subject: [haskell] refactoring

---
 haskell/src/SpaceTraders/APIClient/Agent.hs      | 39 ++++++++++--------
 haskell/src/SpaceTraders/APIClient/Client.hs     | 50 ++++++++++++------------
 haskell/src/SpaceTraders/APIClient/Contracts.hs  | 16 ++++----
 haskell/src/SpaceTraders/APIClient/Errors.hs     | 31 +++++++--------
 haskell/src/SpaceTraders/APIClient/Pagination.hs |  9 ++---
 haskell/src/SpaceTraders/APIClient/Ships.hs      | 35 +++++++++--------
 haskell/src/SpaceTraders/APIClient/Systems.hs    | 22 +++++------
 haskell/src/SpaceTraders/Automation/Init.hs      | 49 +++++++++++------------
 haskell/src/SpaceTraders/Database.hs             | 18 ++++-----
 haskell/src/SpaceTraders/Database/Agents.hs      | 28 ++++++-------
 haskell/src/SpaceTraders/Database/Contracts.hs   | 33 ++++++----------
 haskell/src/SpaceTraders/Database/Ships.hs       | 33 ++++++----------
 haskell/src/SpaceTraders/Database/Systems.hs     | 12 +++---
 haskell/src/SpaceTraders/Database/Tokens.hs      | 12 +++---
 haskell/src/SpaceTraders/Model/Agent.hs          | 17 ++++----
 haskell/src/SpaceTraders/Model/Cargo.hs          | 13 +++---
 haskell/src/SpaceTraders/Model/Fuel.hs           | 13 +++---
 haskell/src/SpaceTraders/Model/Inventory.hs      | 15 ++++---
 haskell/src/SpaceTraders/Model/Nav.hs            | 19 +++++----
 haskell/src/SpaceTraders/Model/Ship.hs           | 27 ++++++-------
 haskell/src/SpaceTraders/Model/System.hs         | 21 +++++-----
 haskell/src/SpaceTraders/Model/Waypoint.hs       | 17 ++++----
 haskell/src/SpaceTraders/Utils.hs                | 26 ++++++------
 23 files changed, 266 insertions(+), 289 deletions(-)

(limited to 'haskell/src/SpaceTraders')

diff --git a/haskell/src/SpaceTraders/APIClient/Agent.hs b/haskell/src/SpaceTraders/APIClient/Agent.hs
index 7b367f6..cdd04e6 100644
--- a/haskell/src/SpaceTraders/APIClient/Agent.hs
+++ b/haskell/src/SpaceTraders/APIClient/Agent.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Agent
@@ -8,28 +8,33 @@ 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           Control.Monad.Reader
+import           Data.Aeson
+import qualified Data.Text                     as T
+import           GHC.Generics
+import           Network.HTTP.Simple
 
-import SpaceTraders
-import SpaceTraders.APIClient.Client
-import SpaceTraders.Model.Agent(Agent)
-import SpaceTraders.Model.Ship(Ship)
-import SpaceTraders.Model.Contract
+import           SpaceTraders
+import           SpaceTraders.APIClient.Client
+import           SpaceTraders.Database.Agents
+import           SpaceTraders.Model.Agent      (Agent)
+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
+                                       , symbol  :: T.Text
                                        } deriving (ToJSON, Generic, Show)
-data RegisterMessage = RegisterMessage { agent :: Agent
+data RegisterMessage = RegisterMessage { agent    :: Agent
                                        , contract :: Contract
-                                       , ship :: Ship
-                                       , token :: T.Text
+                                       , ship     :: Ship
+                                       , token    :: T.Text
                                        } deriving (FromJSON, Generic, Show)
 
 register :: (HasRequest env, MonadIO m, MonadReader env m) => T.Text -> T.Text -> m (APIResponse RegisterMessage)
diff --git a/haskell/src/SpaceTraders/APIClient/Client.hs b/haskell/src/SpaceTraders/APIClient/Client.hs
index 9229813..7f28fde 100644
--- a/haskell/src/SpaceTraders/APIClient/Client.hs
+++ b/haskell/src/SpaceTraders/APIClient/Client.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings  #-}
 
 module SpaceTraders.APIClient.Client
   ( APIMessage(..)
@@ -11,27 +11,27 @@ module SpaceTraders.APIClient.Client
   , tokenReq
   ) where
 
-import Control.Concurrent.Thread.Delay
-import Control.Monad
-import Control.Monad.Reader
-import Data.Aeson
-import Data.IORef
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Network.HTTP.Simple
-import Network.HTTP.Types.Status
-import System.Directory
-import System.Environment
-import System.Posix.Process
+import           Control.Concurrent.Thread.Delay
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.Aeson
+import           Data.IORef
+import qualified Data.Text                         as T
+import qualified Data.Text.Encoding                as T
+import           Network.HTTP.Simple
+import           Network.HTTP.Types.Status
+import           System.Directory
+import           System.Environment
+import           System.Posix.Process
 
-import SpaceTraders
-import SpaceTraders.APIClient.Errors
-import SpaceTraders.APIClient.Pagination
-import SpaceTraders.Utils
+import           SpaceTraders
+import           SpaceTraders.APIClient.Errors
+import           SpaceTraders.APIClient.Pagination
+import           SpaceTraders.Utils
 
-data FromJSON a => APIMessage a = APIMessage { messageData :: a
-                                             , messagePagination :: Maybe Pagination
-                                             } deriving (Show)
+data APIMessage a = APIMessage { messageData       :: a
+                               , messagePagination :: Maybe Pagination
+                               } deriving (Show)
 instance FromJSON a => FromJSON (APIMessage a) where
   parseJSON = withObject "APIMessage" $ \o ->
     APIMessage <$> o .: "data"
@@ -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
@@ -54,7 +54,7 @@ send :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => (Request -
 send requestBuilder = do
   response <- sendPaginated Nothing requestBuilder
   case response of
-    Left e -> return $ Left e
+    Left e                 -> return $ Left e
     Right (APIMessage d _) -> return $ Right d
 
 sendPaginated :: (FromJSON a, HasRequest env, MonadIO m, MonadReader env m) => Maybe Pagination -> (Request -> Request) -> m (APIPaginatedResponse a)
@@ -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"
diff --git a/haskell/src/SpaceTraders/APIClient/Contracts.hs b/haskell/src/SpaceTraders/APIClient/Contracts.hs
index a62eb26..9c5bf02 100644
--- a/haskell/src/SpaceTraders/APIClient/Contracts.hs
+++ b/haskell/src/SpaceTraders/APIClient/Contracts.hs
@@ -1,18 +1,16 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Contracts
   ( myContracts
   ) where
 
-import Network.HTTP.Simple
+import           Network.HTTP.Simple
 
-import SpaceTraders
-import SpaceTraders.APIClient.Client
-import SpaceTraders.APIClient.Pagination
-import SpaceTraders.Database.Contracts
-import SpaceTraders.Model.Contract(Contract)
+import           SpaceTraders
+import           SpaceTraders.APIClient.Client
+import           SpaceTraders.APIClient.Pagination
+import           SpaceTraders.Database.Contracts
+import           SpaceTraders.Model.Contract       (Contract)
 
 myContracts :: SpaceTradersT (APIResponse [Contract])
 myContracts = do
@@ -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
diff --git a/haskell/src/SpaceTraders/APIClient/Errors.hs b/haskell/src/SpaceTraders/APIClient/Errors.hs
index 2b74784..eb87daa 100644
--- a/haskell/src/SpaceTraders/APIClient/Errors.hs
+++ b/haskell/src/SpaceTraders/APIClient/Errors.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Errors
@@ -8,11 +8,11 @@ module SpaceTraders.APIClient.Errors
   , ResetHappened(..)
   ) where
 
-import Control.Exception
-import Data.Aeson
-import Data.Time
-import qualified Data.Text as T
-import GHC.Generics
+import           Control.Exception
+import           Data.Aeson
+import qualified Data.Text         as T
+import           Data.Time
+import           GHC.Generics
 
 data APIError = APIError Int T.Text Value
               | APIRateLimit RateLimit
@@ -27,16 +27,15 @@ instance FromJSON APIError where
     case code of
       401 -> APIResetHappened <$> parseJSON d
       429 -> APIRateLimit <$> parseJSON d
-      _ -> APIError <$> pure code
-                    <*> e .: "message"
-                    <*> pure d
+      _ -> APIError code <$> e .: "message"
+                         <*> pure d
 
-data RateLimit = RateLimit { limitBurst :: Int
+data RateLimit = RateLimit { limitBurst     :: Int
                            , limitPerSecond :: Int
-                           , rateLimitType :: T.Text
-                           , remaining :: Int
-                           , reset :: UTCTime
-                           , retryAfter :: Double
+                           , rateLimitType  :: T.Text
+                           , remaining      :: Int
+                           , reset          :: UTCTime
+                           , retryAfter     :: Double
                            } deriving Show
 instance FromJSON RateLimit where
   parseJSON = withObject "RateLimit" $ \o ->
@@ -47,6 +46,6 @@ instance FromJSON RateLimit where
               <*> o .: "reset"
               <*> o .: "retryAfter"
 
-data ResetHappened = ResetHappened { actual :: T.Text
+data ResetHappened = ResetHappened { actual   :: T.Text
                                    , expected :: T.Text
                                    } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/APIClient/Pagination.hs b/haskell/src/SpaceTraders/APIClient/Pagination.hs
index bb9bcd1..e6a2d44 100644
--- a/haskell/src/SpaceTraders/APIClient/Pagination.hs
+++ b/haskell/src/SpaceTraders/APIClient/Pagination.hs
@@ -1,17 +1,16 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.APIClient.Pagination
   ( Pagination(..)
   , nextPage
   ) where
 
-import Data.Aeson
-import GHC.Generics
+import           Data.Aeson
+import           GHC.Generics
 
 data Pagination = Pagination { limit :: Int
-                             , page :: Int
+                             , page  :: Int
                              , total :: Int
                              } deriving (FromJSON, Generic, Show)
 
diff --git a/haskell/src/SpaceTraders/APIClient/Ships.hs b/haskell/src/SpaceTraders/APIClient/Ships.hs
index 87c5ecb..4ce9371 100644
--- a/haskell/src/SpaceTraders/APIClient/Ships.hs
+++ b/haskell/src/SpaceTraders/APIClient/Ships.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Ships
@@ -8,19 +8,20 @@ module SpaceTraders.APIClient.Ships
   , orbit
   ) where
 
-import Data.Aeson.Types
-import qualified Data.Text.Encoding as T
-import GHC.Generics
-import Network.HTTP.Simple
+import           Data.Aeson.Types
+import qualified Data.Text.Encoding                as T
+import           GHC.Generics
+import           Network.HTTP.Simple
 
-import SpaceTraders
-import SpaceTraders.APIClient.Client
-import SpaceTraders.APIClient.Pagination
-import SpaceTraders.Database.Ships
-import SpaceTraders.Model.Nav
-import SpaceTraders.Model.Ship
+import           SpaceTraders
+import           SpaceTraders.APIClient.Client
+import           SpaceTraders.APIClient.Pagination
+import           SpaceTraders.Database.Ships
+import           SpaceTraders.Model.Nav
+import           SpaceTraders.Model.Ship
+
+newtype NavMessage = NavMessage { nav :: Nav } deriving (FromJSON, Generic, Show)
 
-data 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,8 +44,8 @@ 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')
-                                             else Right <$> getShips
+          if limit p' * page p' < total p' then listShips' (nextPage p')
+                                           else Right <$> getShips
         _ -> undefined
 
 orbit :: Ship -> SpaceTradersT (APIResponse Ship)
@@ -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
diff --git a/haskell/src/SpaceTraders/APIClient/Systems.hs b/haskell/src/SpaceTraders/APIClient/Systems.hs
index eb15b4d..e2690ac 100644
--- a/haskell/src/SpaceTraders/APIClient/Systems.hs
+++ b/haskell/src/SpaceTraders/APIClient/Systems.hs
@@ -1,24 +1,22 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.APIClient.Systems
   ( initSystems
   ) where
 
-import Control.Exception
-import Network.HTTP.Simple
+import           Control.Exception
+import           Network.HTTP.Simple
 
-import SpaceTraders
-import SpaceTraders.APIClient.Client
-import SpaceTraders.APIClient.Pagination
-import SpaceTraders.Database.Systems
-import SpaceTraders.Model.System(System)
+import           SpaceTraders
+import           SpaceTraders.APIClient.Client
+import           SpaceTraders.APIClient.Pagination
+import           SpaceTraders.Database.Systems
+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')
-                                             else Right <$> getSystems
+          if limit p' * page p' < total p' then listSystems' (nextPage p')
+                                           else Right <$> getSystems
         _ -> undefined
diff --git a/haskell/src/SpaceTraders/Automation/Init.hs b/haskell/src/SpaceTraders/Automation/Init.hs
index 6641cf8..be3dbd2 100644
--- a/haskell/src/SpaceTraders/Automation/Init.hs
+++ b/haskell/src/SpaceTraders/Automation/Init.hs
@@ -5,23 +5,24 @@ module SpaceTraders.Automation.Init
   , initST
   ) 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           Control.Exception
+import           Control.Monad.Error.Class
+import           Control.Monad.Reader
+import qualified Data.Text                        as T
+import qualified Database.SQLite.Simple           as S
+import           System.Directory
 
-import SpaceTraders
-import SpaceTraders.APIClient.Agent
-import SpaceTraders.APIClient.Client
-import SpaceTraders.APIClient.Contracts
-import SpaceTraders.APIClient.Errors
-import SpaceTraders.APIClient.Ships
-import SpaceTraders.Database
-import SpaceTraders.Database.Agents
-import SpaceTraders.Database.Contracts
-import SpaceTraders.Database.Ships
-import SpaceTraders.Database.Tokens
+import           SpaceTraders
+import           SpaceTraders.APIClient.Agent
+import           SpaceTraders.APIClient.Client
+import           SpaceTraders.APIClient.Contracts
+import           SpaceTraders.APIClient.Errors
+import           SpaceTraders.APIClient.Ships
+import           SpaceTraders.Database
+import           SpaceTraders.Database.Agents
+import           SpaceTraders.Database.Contracts
+import           SpaceTraders.Database.Ships
+import           SpaceTraders.Database.Tokens
 
 deinitST :: Env -> IO ()
 deinitST env = do
@@ -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'
-      addContract $ contract r'
-      addShip $ ship r'
+      setAgent $ agent r'
+      setContract $ contract r'
+      setShip $ ship r'
       return t
     Left e' -> throw e'
 
diff --git a/haskell/src/SpaceTraders/Database.hs b/haskell/src/SpaceTraders/Database.hs
index 66ff893..0166da9 100644
--- a/haskell/src/SpaceTraders/Database.hs
+++ b/haskell/src/SpaceTraders/Database.hs
@@ -1,24 +1,24 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module SpaceTraders.Database
   ( close
   , open
   ) where
 
-import Control.Exception
-import qualified Data.ByteString as B
-import Data.FileEmbed
+import           Control.Exception
+import qualified Data.ByteString        as B
+import           Data.FileEmbed
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as T
 import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
 
 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
diff --git a/haskell/src/SpaceTraders/Database/Agents.hs b/haskell/src/SpaceTraders/Database/Agents.hs
index 49ae11f..d596d79 100644
--- a/haskell/src/SpaceTraders/Database/Agents.hs
+++ b/haskell/src/SpaceTraders/Database/Agents.hs
@@ -1,24 +1,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Agents
-  ( addAgent
-  , getAgent
+  ( getAgent
   , setAgent
   ) where
 
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import           Control.Monad.Error.Class
+import           Control.Monad.Reader
+import           Data.Aeson
+import qualified Database.SQLite.Simple    as S
 
-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))
+import           SpaceTraders
+import           SpaceTraders.Model.Agent
+import           SpaceTraders.Utils
 
 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 agent = execute "UPDATE agents SET data = json(?);" (S.Only (encode agent))
+setAgent :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Agent -> m ()
+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))
diff --git a/haskell/src/SpaceTraders/Database/Contracts.hs b/haskell/src/SpaceTraders/Database/Contracts.hs
index 20170ba..7cebc37 100644
--- a/haskell/src/SpaceTraders/Database/Contracts.hs
+++ b/haskell/src/SpaceTraders/Database/Contracts.hs
@@ -1,31 +1,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Contracts
-  ( addContract
-  , getContracts
+  ( getContracts
   , setContract
-  , updateContract
   ) where
 
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import           Control.Monad.Error.Class
+import           Control.Monad.Reader
+import           Data.Aeson
+import qualified Database.SQLite.Simple      as S
 
-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))
+import           SpaceTraders
+import           SpaceTraders.Model.Contract
+import           SpaceTraders.Utils
 
 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 contract = do
-  c <- count "SELECT count(id) FROM contracts WHERE data->>'contractId' = ?;" (S.Only $ contractId contract)
-  if c == 0 then addContract contract
-            else updateContract 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)
+setContract :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Contract -> m ()
+setContract contract = updateContract `catchError` addContract
+  where
+    addContract _ = execute "INSERT INTO contracts(data) VALUES (json(?));" (S.Only (encode contract))
+    updateContract = execute "UPDATE contracts SET data = json(?) WHERE data->>'contractId' = ?;" (encode contract, contractId contract)
diff --git a/haskell/src/SpaceTraders/Database/Ships.hs b/haskell/src/SpaceTraders/Database/Ships.hs
index 5a2ab7c..eabf429 100644
--- a/haskell/src/SpaceTraders/Database/Ships.hs
+++ b/haskell/src/SpaceTraders/Database/Ships.hs
@@ -1,31 +1,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Database.Ships
-  ( addShip
-  , getShips
+  ( getShips
   , setShip
-  , updateShip
   ) where
 
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import           Control.Monad.Error.Class
+import           Control.Monad.Reader
+import           Data.Aeson
+import qualified Database.SQLite.Simple    as S
 
-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)
+import           SpaceTraders
+import           SpaceTraders.Model.Ship
+import           SpaceTraders.Utils
 
 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 ship = do
-  c <- count "SELECT count(id) FROM ships WHERE data->>'symbol' = ?;" (S.Only $ symbol ship)
-  if c == 0 then addShip ship
-            else updateShip 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)
+setShip :: (HasDatabaseConn env, MonadError e m, MonadIO m, MonadReader env m) => Ship -> m ()
+setShip ship = updateShip `catchError` addShip
+  where
+    addShip _ = execute "INSERT INTO ships(data) VALUES (json(?));" (S.Only $ encode ship)
+    updateShip = execute "UPDATE ships SET data = json(?) WHERE data->>'symbol' = ?;" (encode ship, symbol ship)
diff --git a/haskell/src/SpaceTraders/Database/Systems.hs b/haskell/src/SpaceTraders/Database/Systems.hs
index 07749be..7c43caf 100644
--- a/haskell/src/SpaceTraders/Database/Systems.hs
+++ b/haskell/src/SpaceTraders/Database/Systems.hs
@@ -5,13 +5,13 @@ module SpaceTraders.Database.Systems
   , getSystems
   ) where
 
-import Control.Monad.Reader
-import Data.Aeson
-import qualified Database.SQLite.Simple as S
+import           Control.Monad.Reader
+import           Data.Aeson
+import qualified Database.SQLite.Simple    as S
 
-import SpaceTraders
-import SpaceTraders.Model.System
-import SpaceTraders.Utils
+import           SpaceTraders
+import           SpaceTraders.Model.System
+import           SpaceTraders.Utils
 
 addSystems :: (HasDatabaseConn env, MonadIO m, MonadReader env m) => [System] -> m ()
 addSystems systems = do
diff --git a/haskell/src/SpaceTraders/Database/Tokens.hs b/haskell/src/SpaceTraders/Database/Tokens.hs
index e99e49e..0a29a55 100644
--- a/haskell/src/SpaceTraders/Database/Tokens.hs
+++ b/haskell/src/SpaceTraders/Database/Tokens.hs
@@ -1,21 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 
 module SpaceTraders.Database.Tokens
   ( addToken
   , getToken
   ) where
 
-import Control.Monad.Reader
+import           Control.Monad.Reader
+import qualified Data.Text              as T
 import qualified Database.SQLite.Simple as S
-import qualified Data.Text as T
 
-import SpaceTraders
+import           SpaceTraders
+import           SpaceTraders.Utils
 
 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)
+addToken value = execute "INSERT INTO tokens(data) VALUES (?);" (S.Only value)
 
 getToken :: (HasDatabaseConn env, MonadFail m, MonadIO m, MonadReader env m) => m T.Text
 getToken = do
diff --git a/haskell/src/SpaceTraders/Model/Agent.hs b/haskell/src/SpaceTraders/Model/Agent.hs
index 01c08a0..a03d47f 100644
--- a/haskell/src/SpaceTraders/Model/Agent.hs
+++ b/haskell/src/SpaceTraders/Model/Agent.hs
@@ -1,19 +1,18 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Agent
   ( Agent(..)
   ) where
 
-import Data.Aeson
-import GHC.Generics
-import qualified Data.Text as T
+import           Data.Aeson
+import qualified Data.Text    as T
+import           GHC.Generics
 
-data Agent = Agent { accountId :: T.Text
-                   , credits :: Integer
+data Agent = Agent { accountId       :: T.Text
+                   , credits         :: Integer
                    --, faction :: Faction
-                   , headquarters :: T.Text
+                   , headquarters    :: T.Text
                    , startingFaction :: T.Text
-                   , symbol :: T.Text
+                   , symbol          :: T.Text
                    } deriving (Eq, FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/Cargo.hs b/haskell/src/SpaceTraders/Model/Cargo.hs
index 126fc63..232627c 100644
--- a/haskell/src/SpaceTraders/Model/Cargo.hs
+++ b/haskell/src/SpaceTraders/Model/Cargo.hs
@@ -1,17 +1,16 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Cargo
   ( Cargo(..)
   ) where
 
-import Data.Aeson
-import GHC.Generics
+import           Data.Aeson
+import           GHC.Generics
 
-import SpaceTraders.Model.Inventory(Inventory)
+import           SpaceTraders.Model.Inventory (Inventory)
 
-data Cargo = Cargo { capacity :: Int
+data Cargo = Cargo { capacity  :: Int
                    , inventory :: [Inventory]
-                   , units :: Int
+                   , units     :: Int
                    } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/Fuel.hs b/haskell/src/SpaceTraders/Model/Fuel.hs
index ca17ebb..99c4709 100644
--- a/haskell/src/SpaceTraders/Model/Fuel.hs
+++ b/haskell/src/SpaceTraders/Model/Fuel.hs
@@ -1,21 +1,20 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Fuel
   ( Consumed(..)
   , Fuel(..)
   ) where
 
-import Data.Aeson
-import Data.Time
-import GHC.Generics
+import           Data.Aeson
+import           Data.Time
+import           GHC.Generics
 
-data Consumed = Consumed { amount :: Int
+data Consumed = Consumed { amount    :: Int
                          , timestamp :: UTCTime
                          } deriving (FromJSON, Generic, Show, ToJSON)
 
 data Fuel = Fuel { capacity :: Int
                  , consumed :: Consumed
-                 , current :: Int
+                 , current  :: Int
                  } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/Inventory.hs b/haskell/src/SpaceTraders/Model/Inventory.hs
index db74ddb..4faea52 100644
--- a/haskell/src/SpaceTraders/Model/Inventory.hs
+++ b/haskell/src/SpaceTraders/Model/Inventory.hs
@@ -1,17 +1,16 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Inventory
   ( Inventory(..)
   ) where
 
-import Data.Aeson
-import GHC.Generics
-import qualified Data.Text as T
+import           Data.Aeson
+import qualified Data.Text    as T
+import           GHC.Generics
 
 data Inventory = Inventory { description :: T.Text
-                           , name :: T.Text
-                           , symbol :: T.Text
-                           , units :: Int
+                           , name        :: T.Text
+                           , symbol      :: T.Text
+                           , units       :: Int
                            } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/Nav.hs b/haskell/src/SpaceTraders/Model/Nav.hs
index 1c23ca1..8550836 100644
--- a/haskell/src/SpaceTraders/Model/Nav.hs
+++ b/haskell/src/SpaceTraders/Model/Nav.hs
@@ -1,20 +1,19 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Nav
   ( Nav(..)
   ) where
 
-import Data.Aeson
-import GHC.Generics
-import qualified Data.Text as T
+import           Data.Aeson
+import qualified Data.Text                as T
+import           GHC.Generics
 
-import SpaceTraders.Model.Route
+import           SpaceTraders.Model.Route
 
-data Nav = Nav { flightMode :: T.Text
-               , route :: Route
-               , status :: T.Text
-               , systemSymbol :: T.Text
+data Nav = Nav { flightMode     :: T.Text
+               , route          :: Route
+               , status         :: T.Text
+               , systemSymbol   :: T.Text
                , waypointSymbol :: T.Text
                } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/Ship.hs b/haskell/src/SpaceTraders/Model/Ship.hs
index 2ec54f1..522276c 100644
--- a/haskell/src/SpaceTraders/Model/Ship.hs
+++ b/haskell/src/SpaceTraders/Model/Ship.hs
@@ -1,34 +1,33 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric  #-}
 
 module SpaceTraders.Model.Ship
   ( Ship(..)
   ) where
 
-import Data.Aeson
-import GHC.Generics
-import qualified Data.Text as T
+import           Data.Aeson
+import qualified Data.Text                as T
+import           GHC.Generics
 
-import SpaceTraders.Model.Cargo
-import SpaceTraders.Model.Fuel
-import SpaceTraders.Model.Nav
+import           SpaceTraders.Model.Cargo
+import           SpaceTraders.Model.Fuel
+import           SpaceTraders.Model.Nav
 
-data Ship = Ship { cargo :: Cargo
+data Ship = Ship { cargo    :: Cargo
                  , cooldown :: Cooldown
                  --, crew :: Crew
                  --, engine :: Engine
                  --, frame :: Frame
-                 , fuel :: Fuel
+                 , fuel     :: Fuel
                  --, modules :: [Module]
                  --, mounts :: [Mount]
-                 , nav :: Nav
+                 , nav      :: Nav
                  --, reactor :: Reactor
                  --, registration :: Registration
-                 , symbol :: T.Text
+                 , symbol   :: T.Text
                  } deriving (FromJSON, Generic, Show, ToJSON)
 
-data Cooldown = Cooldown { shipSymbol :: T.Text
-                         , totalSeconds :: Int
+data Cooldown = Cooldown { shipSymbol       :: T.Text
+                         , totalSeconds     :: Int
                          , remainingSeconds :: Int
                          } deriving (FromJSON, Generic, Show, ToJSON)
diff --git a/haskell/src/SpaceTraders/Model/System.hs b/haskell/src/SpaceTraders/Model/System.hs
index 0092ef5..a673b56 100644
--- a/haskell/src/SpaceTraders/Model/System.hs
+++ b/haskell/src/SpaceTraders/Model/System.hs
@@ -1,23 +1,22 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.System
   ( System(..)
   ) where
 
-import Data.Aeson
-import qualified Data.Text as T
-import GHC.Generics
+import           Data.Aeson
+import qualified Data.Text                   as T
+import           GHC.Generics
 
-import SpaceTraders.Model.Waypoint(Waypoint)
+import           SpaceTraders.Model.Waypoint (Waypoint)
 
 data System = System { sectorSymbol :: T.Text
-                     , symbol :: T.Text
-                     , systemType :: T.Text
-                     , x :: Int
-                     , y :: Int
-                     , waypoints :: [Waypoint]
+                     , symbol       :: T.Text
+                     , systemType   :: T.Text
+                     , x            :: Int
+                     , y            :: Int
+                     , waypoints    :: [Waypoint]
                      --, factions :: [Faction]
                      } deriving (Generic, Show)
 instance FromJSON System where
diff --git a/haskell/src/SpaceTraders/Model/Waypoint.hs b/haskell/src/SpaceTraders/Model/Waypoint.hs
index d80dc7a..9f0776c 100644
--- a/haskell/src/SpaceTraders/Model/Waypoint.hs
+++ b/haskell/src/SpaceTraders/Model/Waypoint.hs
@@ -1,20 +1,19 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module SpaceTraders.Model.Waypoint
   ( Waypoint(..)
   ) where
 
-import Data.Aeson
-import qualified Data.Text as T
-import GHC.Generics
+import           Data.Aeson
+import qualified Data.Text    as T
+import           GHC.Generics
 
-data Waypoint = Waypoint { orbits :: Maybe T.Text
-                         , symbol :: T.Text
+data Waypoint = Waypoint { orbits       :: Maybe T.Text
+                         , symbol       :: T.Text
                          , waypointType :: T.Text
-                         , x :: Int
-                         , y :: Int
+                         , x            :: Int
+                         , y            :: Int
                          } deriving (Generic, Show)
 instance FromJSON Waypoint where
   parseJSON = withObject "Waypoint" $ \o ->
diff --git a/haskell/src/SpaceTraders/Utils.hs b/haskell/src/SpaceTraders/Utils.hs
index 2f54a81..d7eef46 100644
--- a/haskell/src/SpaceTraders/Utils.hs
+++ b/haskell/src/SpaceTraders/Utils.hs
@@ -9,18 +9,18 @@ module SpaceTraders.Utils
   , query_
   ) where
 
-import Control.Monad.Reader
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Builder as B
+import           Control.Monad.Reader
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.ByteString          as B
+import qualified Data.ByteString.Builder  as B
 import qualified Data.ByteString.Internal as B
-import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Database.SQLite.Simple as S
+import           Data.Maybe
+import qualified Data.Text                as T
+import qualified Data.Text.Encoding       as T
+import qualified Database.SQLite.Simple   as S
 
-import SpaceTraders
+import           SpaceTraders
 
 count :: (HasDatabaseConn env, MonadFail m, MonadReader env m, MonadIO m, S.ToRow t) => S.Query -> t -> m Int
 count q t = do
@@ -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
-- 
cgit v1.2.3