HTML for ServerError; drop mock database effect handler

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

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      = []
-      }

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)

src/Logger.hs

@@ -2,6 +2,7 @@ module Logger where
 
 import Core
 import Database
+import Utility
 
 import Data.Time                  (getCurrentTime, UTCTime)
 import Effectful

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
 

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      = []
+      }

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."