Provide detailed logging for any db errors caused internally by postgrest

postgrest.cabal

@@ -37,6 +37,7 @@ executable postgrest
                      , case-insensitive
                      , scientific, time
                      , aeson >= 0.8, network >= 2.6
+                     , aeson-pretty >= 0.7 && < 0.8
                      , bytestring, text, split, string-conversions
                      , stringsearch
                      , containers, unordered-containers

src/PostgREST/Main.hs

@@ -1,39 +1,41 @@
 module Main where
 
 
+import           PostgREST.App
+import           PostgREST.Config                     (AppConfig (..),
+                                                       minimumPgVersion,
+                                                       prettyVersion,
+                                                       readOptions)
+import           PostgREST.Error                      (errResponse, PgError)
+import           PostgREST.Middleware
 import           PostgREST.PgStructure
 import           PostgREST.Types
-import           Network.Wai
-
-import           PostgREST.App
-import           PostgREST.Error                      (errResponse)
-import           PostgREST.Middleware
 
 import           Control.Monad                        (unless)
 import           Control.Monad.IO.Class               (liftIO)
+import           Data.Aeson.Encode.Pretty             (encodePretty)
 import           Data.Functor.Identity
 import           Data.Monoid                          ((<>))
 import           Data.String.Conversions              (cs)
 import           Data.Text                            (Text)
 import qualified Hasql                                as H
 import qualified Hasql.Postgres                       as P
+import           Network.Wai
 import           Network.Wai.Handler.Warp             hiding (Connection)
 import           Network.Wai.Middleware.RequestLogger (logStdout)
-
 import           System.IO                            (BufferMode (..),
                                                        hSetBuffering, stderr,
                                                        stdin, stdout)
 
-import           PostgREST.Config                     (AppConfig (..),
-                                                       prettyVersion,
-                                                       readOptions,
-                                                       minimumPgVersion)
 
 isServerVersionSupported :: H.Session P.Postgres IO Bool
 isServerVersionSupported = do
   Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]
   return $ read (cs row) >= minimumPgVersion
 
+hasqlError :: PgError -> IO a
+hasqlError = error . cs . encodePretty
+
 main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
@@ -61,15 +63,17 @@ main = do
   pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
 
   supportedOrError <- H.session pool isServerVersionSupported
-  either (fail . show)
+  either hasqlError
     (\supported ->
       unless supported $
-        fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
+        error "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
     ) supportedOrError
 
-  Right authenticator <- H.session pool $ do
-    Identity (role :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SELECT SESSION_USER|]
+  roleOrError <- H.session pool $ do
+    Identity (role :: Text) <- H.tx Nothing $ H.singleEx
+      [H.stmt|SELECT SESSION_USER|]
     return role
+  authenticator <- either hasqlError return roleOrError
 
   let txSettings = Just (H.ReadCommitted, Just True)
   metadata <- H.session pool $ H.tx txSettings $ do
@@ -79,15 +83,15 @@ main = do
     keys <- allPrimaryKeys
     return (tabs, rels, cols, keys)
 
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (tabs, rels, cols, keys) ->
+  dbstructure <- either hasqlError
+    (\(tabs, rels, cols, keys) ->
       return DbStructure {
           tables=tabs
         , columns=cols
         , relations=rels
         , primaryKeys=keys
         }
+    ) metadata
 
   runSettings appSettings $ middle $ \ req respond -> do
     body <- strictRequestBody req