From d13259f1d4d78a4fd5c5873275416516d6e7d65b Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Sat, 16 Feb 2019 09:52:57 +0300
Subject: Handle DB connection failures

Provide an error message on those. Also add an error message from
libpq when it's available.
---
 Main.hsc           | 51 +++++++++++++++++++++++++++------------------------
 example/common.xsl |  5 +++++
 2 files changed, 32 insertions(+), 24 deletions(-)

diff --git a/Main.hsc b/Main.hsc
index c8cf99b..092fbf7 100644
--- a/Main.hsc
+++ b/Main.hsc
@@ -34,9 +34,6 @@ HTTP basic authentication and PostgreSQL roles for authentication.
 
 import qualified Data.ByteString.Char8 as BS
 import Database.PostgreSQL.LibPQ
-  (getCancel, cancel, connectdb, finish, execParams, getvalue, invalidOid,
-   escapeIdentifier, resultStatus, errorMessage, Connection, Format(..),
-   ExecStatus(..))
 import Data.Maybe (mapMaybe, fromMaybe, catMaybes, fromJust)
 import System.Timeout (timeout)
 import Control.Exception (bracket, finally)
@@ -268,27 +265,33 @@ errorXML kv = xmlElem "error" " xmlns=\"urn:x-pgxhtml\"" $
 serve :: FilePath -> IO Connection -> [(BS.ByteString, BS.ByteString)] -> IO ()
 serve xsltDirectory ioc ps = case lookup "q" ps of
   Just q -> bracket ioc cancelAndClose $ \c -> do
-    formData <- parseFormUrlencoded <$> BS.getContents
-    (q', params) <- prepareQuery c formData ps q
-    r <- execParams c q'
-         (map (\p -> Just (invalidOid, p, Text)) params) Text
-    case r of
-      Just r' -> do
-        rs <- resultStatus r'
-        case rs of
-          TuplesOk -> do
-            -- TODO: add more checks and error messages
-            val <- getvalue r' 0 0
-            case val of
-              Nothing ->
-                respError 500 [("message", "Failed to read query result")]
-              Just val' -> resp 200 val'
-          CommandOk ->
-            respError 500 [("message", "The command didn't return XML")]
-          _ -> do
-            errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c
-            respError 500 $ ("exec_status", BS.pack (show rs)) : errMsg
-      Nothing -> respError 500 [("message", "Failed to execute the query")]
+    let redb n e = respError n =<<
+          (maybe e (\em' -> ("db_error", em') : e) <$> errorMessage c)
+    cStatus <- status c
+    case cStatus of
+      ConnectionOk -> do
+        formData <- parseFormUrlencoded <$> BS.getContents
+        (q', params) <- prepareQuery c formData ps q
+        r <- execParams c q'
+             (map (\p -> Just (invalidOid, p, Text)) params) Text
+        case r of
+          Just r' -> do
+            rs <- resultStatus r'
+            case rs of
+              TuplesOk -> do
+                -- TODO: add more checks and error messages
+                val <- getvalue r' 0 0
+                case val of
+                  Nothing ->
+                    redb 500 [("message", "Failed to read query result")]
+                  Just val' -> resp 200 val'
+              CommandOk ->
+                redb 500 [("message", "The command didn't return XML")]
+              _ -> do
+                errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c
+                redb 500 $ ("exec_status", BS.pack (show rs)) : errMsg
+          Nothing -> redb 500 [("message", "Failed to execute the query")]
+      _ -> redb 500 [("message", "Database connection failed")]
   _ -> respError 418 [("message", "No query is provided")]
   where
     xsltPath = xsltDirectory </>
diff --git a/example/common.xsl b/example/common.xsl
index cc10c40..15838ba 100644
--- a/example/common.xsl
+++ b/example/common.xsl
@@ -31,6 +31,11 @@
     <dd><pre><xsl:copy-of select="text()" /></pre></dd>
   </xsl:template>
 
+  <xsl:template match="pgx:db_error">
+    <dt>DB error message</dt>
+    <dd><pre><xsl:copy-of select="text()" /></pre></dd>
+  </xsl:template>
+
   <xsl:template match="pgx:exec_status">
     <dt>ExecStatus</dt>
     <dd><xsl:copy-of select="text()" /></dd>
-- 
cgit v1.2.3