diff --git a/src/Core.hs b/src/Core.hs index 96b8120..c79581a 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -19,12 +19,13 @@ import Servant hiding ((:>), throwError) -- -- Core data types -- -type AppEff = Eff '[ Logger - , Database - , Reader AppEnv - , Error ServerError - , IOE - ] +type AppEff = + Eff '[ Logger + , Database + , Reader AppEnv + , Error ServerError + , IOE + ] data AppEnv = AppEnv { pool :: Pool Connection } diff --git a/src/Database.hs b/src/Database.hs index 14af35b..1c6af68 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -70,8 +70,8 @@ runDatabaseIO = interpret $ \_ -> \case init = do AppEnv { pool } <- ask liftWithPool pool $ \conn -> do - execute_ conn tableUsers - execute_ conn tableLogs + execute_ conn createUsersTable + 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 -tableUsers = "CREATE TABLE IF NOT EXISTS users ( \ - \id integer NOT NULL, \ - \name character varying(255) NOT NULL \ - \);" +createUsersTable :: Query +createUsersTable = "CREATE TABLE IF NOT EXISTS users ( \ + \ id SERIAL PRIMARY KEY, \ + \ name character varying(255) NOT NULL \ + \);" -tableLogs :: Query -tableLogs = "CREATE TABLE IF NOT EXISTS logs ( \ - \ id SERIAL PRIMARY KEY, \ - \ level VARCHAR(10) NOT NULL, \ - \ message TEXT NOT NULL, \ - \ timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \ - \ source VARCHAR(100), \ - \ context JSONB \ - \);" +createLogsTable :: Query +createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \ + \ id SERIAL PRIMARY KEY, \ + \ level VARCHAR(10) NOT NULL, \ + \ message TEXT NOT NULL, \ + \ timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \ + \ source VARCHAR(100), \ + \ context JSONB \ + \);" diff --git a/src/Main.hs b/src/Main.hs index 0120f7b..327e62e 100644 --- a/src/Main.hs +++ b/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 - $ rootHandler - :<|> userListHandler - :<|> userGetHandler - :<|> userPostHandler - :<|> userDeleteHandler +app env = hoistServer proxy (Handler . ExceptT . runAppEff env) handlers -transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler -transformEff env = hoistServer proxy - $ Handler - . ExceptT - . runEffStack env +handlers :: ServerT AppAPI AppEff +handlers = rootHandler + :<|> userListHandler + :<|> userGetHandler + :<|> userPostHandler + :<|> userDeleteHandler -runEffStack :: AppEnv -> AppEff a -> IO (Either ServerError a) -runEffStack env = runEff - . runErrorNoCallStack - . runReader env - . runDatabaseIO - . runLoggerPSQL +runAppEff :: AppEnv -> AppEff a -> IO (Either ServerError a) +runAppEff env = runEff + . runErrorNoCallStack + . runReader env + . runDatabaseIO + . runLoggerPSQL port :: Int port = 8080