From c4550f97b0c1a4827b49c4113e23ee37c54bfa87 Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Sun, 13 Jul 2014 11:09:44 -0700
Subject: [PATCH] Report sql errors to client

---
 Main.hs | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/Main.hs b/Main.hs
index e8c77ece2..42758aedb 100644
--- a/Main.hs
+++ b/Main.hs
@@ -3,8 +3,10 @@
 module Main where
 
 import Control.Applicative
+import Control.Exception (try)
 
 import Database.HDBC.PostgreSQL (connectPostgreSQL)
+import Database.HDBC.Types (SqlError, seErrorMsg)
 
 import Network.Wai
 import Network.Wai.Handler.Warp hiding (Connection)
@@ -14,6 +16,9 @@ import Network.HTTP.Types.Method
 
 import Options.Applicative hiding (columns)
 
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Char8 as BS
+
 import PgStructure (printTables, printColumns)
 import PgQuery     (selectWhere)
 
@@ -45,7 +50,7 @@ main = do
 
 app ::  AppConfig -> Application
 app config req respond = do
-  r <-
+  r <- try $
     case path of
       []      -> responseLBS status200 [json] <$> (printTables =<< conn)
       [table] -> responseLBS status200 [json] <$>
@@ -54,7 +59,7 @@ app config req respond = do
                   else selectWhere table qq =<< conn )
       _       -> return $ responseLBS status404 [] ""
 
-  respond r
+  respond $ either sqlErrorHandler id r
 
   where
     path = pathInfo req
@@ -62,3 +67,7 @@ app config req respond = do
     json = (hContentType, "application/json")
     conn = connectPostgreSQL $ configDbUri config
     qq   = queryString req
+
+sqlErrorHandler :: SqlError -> Response
+sqlErrorHandler e =
+  responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)]