WIP: Trap postgres errors in middleware

Fixes #39

dbapi.cabal

@@ -36,6 +36,7 @@ executable dbapi
                      , PgStructure
                      , PgQuery
                      , RangeQuery
+                     , Middleware
   hs-source-dirs:      src
 
 Test-Suite spec

src/Dbapi.hs

@@ -5,7 +5,6 @@ module Dbapi where
 
 import Types (SqlRow, getRow)
 
-import Control.Exception (try)
 import Control.Monad (join)
 import Control.Exception.Base (bracket_)
 import Control.Arrow ((***))
@@ -35,7 +34,6 @@ import Data.String.Conversions (cs)
 import qualified Data.CaseInsensitive as CI
 
 import Database.HDBC.PostgreSQL (Connection)
-import Database.HDBC.Types (SqlError, seErrorMsg)
 import PgStructure (printTables, printColumns, primaryKeyColumns,
                     columns, Column(colName))
 
@@ -94,7 +92,7 @@ app conn anonymous req respond = do
     MalformedAuth ->
       respond $ responseLBS status400 [] "Malformed basic auth header"
     LoginFailed ->
-      respond $ responseLBS status403 [] "Invalid username or password"
+      respond $ responseLBS status401 [] "Invalid username or password"
     LoginSuccess role ->
       bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond
     NoCredentials ->
@@ -102,9 +100,8 @@ app conn anonymous req respond = do
 
 
 appWithRole :: Connection -> Application
-appWithRole conn req respond = do
-  r <- try $
-    case (path, verb) of
+appWithRole conn req respond =
+  respond =<< case (path, verb) of
     ([], _) ->
       responseLBS status200 [jsonContentType] <$> printTables ver conn
 
@@ -168,8 +165,6 @@ appWithRole conn req respond = do
     (_, _) ->
       return $ responseLBS status404 [] ""
 
-  respond $ either sqlErrorHandler id r
-
   where
     path   = pathInfo req
     verb   = requestMethod req
@@ -232,9 +227,6 @@ requestedVersion hdrs =
         accept = cs <$> lookup hAccept hdrs :: Maybe String
         verStr = (=~ verRegex) <$> accept :: Maybe [[String]]
 
-sqlErrorHandler :: SqlError -> Response
-sqlErrorHandler e =
-  responseLBS status400 [] $ cs (seErrorMsg e)
 
 addHeaders :: ResponseHeaders -> Response -> Response
 addHeaders hdrs (ResponseFile    s headers fp m) =

src/Main.hs

@@ -4,6 +4,7 @@
 
 module Main where
 import Dbapi
+import Middleware (reportPgErrors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
@@ -40,7 +41,7 @@ main = do
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
   conn <- connectPostgreSQL' dburi
-  runTLS tls settings $ gzip def $ cors corsPolicy $ app conn (cs $ configAnonRole conf)
+  runTLS tls settings $ gzip def $ cors corsPolicy $ reportPgErrors $ app conn (cs $ configAnonRole conf)
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Middleware where
+
+import Data.Aeson
+
+import Network.HTTP.Types.Header (hContentType)
+import Network.HTTP.Types.Status (status400)
+import Database.HDBC.Types (SqlError(..))
+import Control.Exception (catchJust)
+import Network.Wai
+
+
+instance ToJSON SqlError where
+  toJSON t = object [
+      "error" .= object [
+          "code"    .= seNativeError t
+        , "message" .= seErrorMsg t
+        , "state"   .= seState t
+      ]
+    ]
+
+reportPgErrors :: Middleware
+reportPgErrors app req respond =
+  catchJust isPgException (app req respond) (
+      respond . responseLBS status400 [(hContentType, "application/json")]
+              . encode
+    )
+
+  where
+    isPgException :: SqlError -> Maybe SqlError
+    isPgException = Just

test/Feature/AuthSpec.hs

@@ -13,12 +13,11 @@ spec :: Spec
 spec = around appWithFixture $
   describe "authorization" $ do
     it "hides tables that anonymous does not own" $
-      -- TODO: should be 404
-      get "/authors_only" `shouldRespondWith` 400
+      get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404
     it "indicates login failure" $ do
       let auth = authHeader "dbapi_test_author_a" "fakefake"
       request methodGet "/authors_only" [auth] ""
-        `shouldRespondWith` 403
+        `shouldRespondWith` 401
     it "allows users with permissions to see their tables" $ do
       let auth = authHeader "dbapi_test_author_a" ""
       request methodGet "/authors_only" [auth] ""