Use SERIAL for users id field; general cleanup

src/Core.hs

@@ -19,12 +19,13 @@ import Servant hiding                       ((:>), throwError)
 --
 -- Core data types
 --
-type AppEff = Eff '[ Logger
+type AppEff = 
-                   , Database
+  Eff '[ Logger
-                   , Reader AppEnv
+       , Database
-                   , Error ServerError
+       , Reader AppEnv
-                   , IOE
+       , Error ServerError
-                   ]
+       , IOE
+       ]
 
 data AppEnv = AppEnv { pool :: Pool Connection }
 

src/Database.hs

@@ -70,8 +70,8 @@ runDatabaseIO = interpret $ \_ -> \case
     init = do
       AppEnv { pool } <- ask
       liftWithPool pool $ \conn -> do
-        execute_ conn tableUsers
+        execute_ conn createUsersTable
-        execute_ conn tableLogs
+        execute_ conn createLogsTable
         pure ()
 
     read :: (ToField a, FromRow b, DatabaseExeEffects es)
@@ -112,18 +112,18 @@ writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
 deleteUser :: UserId -> (Query, UserId)
 deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)
 
-tableUsers :: Query
+createUsersTable :: Query
-tableUsers = "CREATE TABLE IF NOT EXISTS users ( \
+createUsersTable = "CREATE TABLE IF NOT EXISTS users ( \
-                \id integer NOT NULL, \
+                   \  id SERIAL PRIMARY KEY, \
-                \name character varying(255) NOT NULL \
+                   \  name character varying(255) NOT NULL \
-              \);"
+                   \);"
 
-tableLogs :: Query
+createLogsTable :: Query
-tableLogs = "CREATE TABLE IF NOT EXISTS logs ( \
+createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \
-              \  id SERIAL PRIMARY KEY, \
+                  \  id SERIAL PRIMARY KEY, \
-              \  level VARCHAR(10) NOT NULL, \
+                  \  level VARCHAR(10) NOT NULL, \
-              \  message TEXT NOT NULL, \
+                  \  message TEXT NOT NULL, \
-              \  timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \
+                  \  timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \
-              \  source VARCHAR(100), \
+                  \  source VARCHAR(100), \
-              \  context JSONB \
+                  \  context JSONB \
-             \);"
+                  \);"

src/Main.hs

@@ -20,31 +20,27 @@ import qualified Servant        as S
 --
 main :: IO ()
 main = do
-  pool <- createConnectionPool
+  pool   <- createConnectionPool 
   let env = AppEnv { pool = pool }
-  runEffStack env $ databaseInit
+  runAppEff env $ databaseInit
   run port . serve proxy $ app env
 
 app :: AppEnv -> Server AppAPI
-app env = transformEff env
+app env = hoistServer proxy (Handler . ExceptT . runAppEff env) handlers
-        $ rootHandler
-     :<|> userListHandler
-     :<|> userGetHandler
-     :<|> userPostHandler
-     :<|> userDeleteHandler
 
-transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler
+handlers :: ServerT AppAPI AppEff
-transformEff env = hoistServer proxy
+handlers = rootHandler
-  $ Handler
+      :<|> userListHandler
-  . ExceptT
+      :<|> userGetHandler
-  . runEffStack env
+      :<|> userPostHandler
+      :<|> userDeleteHandler
 
-runEffStack :: AppEnv -> AppEff a -> IO (Either ServerError a)
+runAppEff :: AppEnv -> AppEff a -> IO (Either ServerError a)
-runEffStack env = runEff
+runAppEff env = runEff
-  . runErrorNoCallStack
+              . runErrorNoCallStack
-  . runReader env
+              . runReader env
-  . runDatabaseIO
+              . runDatabaseIO
-  . runLoggerPSQL
+              . runLoggerPSQL
 
 port :: Int
 port = 8080