From 13e8a11e83dbb5e90e9d01311fa9165de3352677 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Tue, 22 Oct 2024 18:55:15 -0500 Subject: [PATCH] HTML for ServerError; drop mock database effect handler --- HELPS.cabal | 3 ++- src/Core.hs | 22 ++-------------------- src/Database.hs | 23 +---------------------- src/Logger.hs | 1 + src/Main.hs | 8 -------- src/Utility.hs | 28 ++++++++++++++++++++++++++++ src/Views.hs | 7 +++++++ 7 files changed, 41 insertions(+), 51 deletions(-) create mode 100644 src/Utility.hs diff --git a/HELPS.cabal b/HELPS.cabal index 90a2f1e..b5d3693 100644 --- a/HELPS.cabal +++ b/HELPS.cabal @@ -60,6 +60,7 @@ executable Main Handlers Logger Routes + Utility Views build-depends: HELPS @@ -68,4 +69,4 @@ library import: global hs-source-dirs: src - exposed-modules: Core, Database, Handlers, Logger, Routes, Views, Main + exposed-modules: Core, Database, Handlers, Logger, Main, Routes, Utility, Views diff --git a/src/Core.hs b/src/Core.hs index 82392ae..7aea187 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -1,7 +1,5 @@ module Core where -import Control.Exception (IOException) -import Control.Monad.Catch (catch) import Data.Aeson (FromJSON, ToJSON) import Data.Pool (Pool) import qualified Data.Text as T @@ -11,10 +9,10 @@ import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow) import Database.PostgreSQL.Simple.ToField (ToField, toField) import Database.PostgreSQL.Simple.ToRow (ToRow, toRow) import Effectful -import Effectful.Error.Static (Error, throwError) +import Effectful.Error.Static (Error) import Effectful.Reader.Static (Reader) import GHC.Generics (Generic) -import Servant hiding ((:>), throwError) +import Servant hiding ((:>)) import Servant.HTML.Lucid -- @@ -67,19 +65,3 @@ data LogLevel = Info | Warning | Error instance ToField LogLevel where toField level = toField (T.pack (show level)) - --- --- Utility --- -liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a --- Lift IO into Eff and catch IOExceptions -liftIOE m = liftIO m `catch` \(e::IOException) -> do - -- Log IOExceptions to stdout - liftIO $ putStrLn $ "ERROR Exception: " ++ show e - -- Throw a custom Servant ServerError - throwError $ ServerError - { errHTTPCode = 500 - , errReasonPhrase = "Internal Server Error" - , errBody = "This incident will be investigated." - , errHeaders = [] - } diff --git a/src/Database.hs b/src/Database.hs index 500c70b..07213d3 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -1,6 +1,7 @@ module Database where import Core +import Utility import Control.Exception (IOException) import Data.Aeson (ToJSON) @@ -70,28 +71,6 @@ runDatabaseIO = interpret $ \_ -> \case => (Pool Connection) -> (Connection -> IO a) -> Eff es a liftWithPool p f = liftIOE $ withResource p f -runDatabaseDebug :: DatabaseExeEffects es - => Eff (Database : es) a -> Eff es a -runDatabaseDebug = interpret $ \_ -> \case - DatabaseInit -> do - liftIOE $ putStrLn "Mocked setup of the database" - DatabaseRead (statement, values) -> do - liftIOE $ putStrLn - $ "Mocked a READ database operation with statement:\n" - ++ show statement - ++ "\nValues:\n" - ++ show values - pure [] - DatabaseRead_ statement -> do - liftIOE $ putStrLn "Mocked a READ database operation on all users" - pure [] - DatabaseWrite (statement, values) -> do - liftIOE $ putStrLn - $ "Mocked a WRITE database operation with statement:\n" - ++ show statement - ++ "\nValues:\n" - ++ show values - createConnectionPool :: ByteString -> IO (Pool Connection) createConnectionPool connectString = newPool $ defaultPoolConfig (connectPostgreSQL connectString) diff --git a/src/Logger.hs b/src/Logger.hs index f0bf187..9e75fdd 100644 --- a/src/Logger.hs +++ b/src/Logger.hs @@ -2,6 +2,7 @@ module Logger where import Core import Database +import Utility import Data.Time (getCurrentTime, UTCTime) import Effectful diff --git a/src/Main.hs b/src/Main.hs index 6b91241..61abc45 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -47,14 +47,6 @@ runAppEff env = runEff . runLoggerPSQL . inject -runAppDebug :: AppEnv -> AppEff a -> IO (Either ServerError a) -runAppDebug env = runEff - . runErrorNoCallStack - . runReader env - . runDatabaseDebug - . runLoggerConsole - . inject - port :: Int port = 8080 diff --git a/src/Utility.hs b/src/Utility.hs new file mode 100644 index 0000000..0b2db83 --- /dev/null +++ b/src/Utility.hs @@ -0,0 +1,28 @@ +module Utility where + +import qualified Views as V + +import Control.Exception (IOException) +import Control.Monad.Catch (catch) +import Effectful +import Effectful.Error.Static (Error, throwError) +import Lucid (renderBS) +import Servant ( ServerError(..) + , errHTTPCode + , errReasonPhrase + , errBody + , errHeaders + ) + +liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a +-- Lift IO into Eff and catch IOExceptions +liftIOE m = liftIO m `catch` \(e::IOException) -> do + -- Log IOExceptions to stdout + liftIO $ putStrLn $ "ERROR Exception: " ++ show e + -- Throw a custom Servant ServerError + throwError $ ServerError + { errHTTPCode = 500 + , errReasonPhrase = "Internal Server Error" + , errBody = renderBS V.internalServerError + , errHeaders = [] + } diff --git a/src/Views.hs b/src/Views.hs index cd3ebb0..e6abd52 100644 --- a/src/Views.hs +++ b/src/Views.hs @@ -32,3 +32,10 @@ userHtml user = div_ [] $ do warning :: String -> Html () warning s = p_ [class_ "warning"] (toHtml s) + +internalServerError :: Html () +internalServerError = baseDoc $ do + div_ [ style_ "text-align: center; margin: 3% 0 0 0;" ] $ do + h1_ "500 INTERNAL SERVER ERROR" + p_ "This issue is probably our fault. \ + \ Please try again shortly or contact us for help."