Provide proper JSON details for errors

Refines HTTP codes for server vs client problems

Fixes #92
Fixes #40

src/App.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
-module App (app, sqlErrHandler, isSqlError) where
+module App (app, sqlError, isSqlError) where
 
 import Control.Monad (join)
 import Control.Arrow ((***))
@@ -28,10 +28,12 @@ import Data.Monoid
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
 
+import Auth
 import PgQuery
 import RangeQuery
 import PgStructure
-import Auth
+import PgError
+import Text.Parsec hiding (Column)
 
 app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
 app reqBody req =
@@ -88,7 +90,7 @@ app reqBody req =
 
       case user of
         Nothing -> return $ responseLBS status400 [jsonH] $
-          encode . object $ [("error", String "Failed to parse user.")]
+          encode . object $ [("message", String "Failed to parse user.")]
         Just u -> do
           _ <- addUser (cs $ userId u)
             (cs $ userPass u) (cs $ userRole u)
@@ -166,15 +168,32 @@ app reqBody req =
 
 
 isSqlError :: H.Error -> Maybe H.Error
-isSqlError (H.ErroneousResult x) = Just $ H.ErroneousResult x
+isSqlError = Just
-isSqlError _ = Nothing
+
+sqlError :: H.Error -> Response
+sqlError err =
+  let inside = case err of
+        H.CantConnect t -> t
+        H.ConnectionLost t -> t
+        H.ErroneousResult t -> t
+        H.UnexpectedResult t -> t
+        H.UnparsableTemplate t -> t
+        H.UnparsableRow t -> t
+        H.NotInTransaction -> "An operation which requires a"
+          <> "database transaction was executed without one"
+      p = parse message
+        "{\"message\": \"failed to parse exception\" }" inside in
+  either
+    (\nope ->
+      responseLBS status500
+      [(hContentType, "application/json")]
+      (cs . show $ nope))
+    (\msg ->
+      responseLBS (httpStatus msg)
+      [(hContentType, "application/json")]
+      (encode msg))
+    p
 
-sqlErrHandler :: H.Error -> IO Response
-sqlErrHandler (H.ErroneousResult err) =
-  return $ if "42P01" `isInfixOf` err
-    then responseLBS status404 [] ""
-    else responseLBS status400 [] (cs err)
-sqlErrHandler _ = error "just for debugging"
 
 rangeStatus :: Int -> Int -> Int -> Status
 rangeStatus from to total
@@ -208,19 +227,19 @@ jsonH = (hContentType, "application/json")
 handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)
               -> H.Tx H.Postgres s Response
 handleJsonObj reqBody handler = do
-  let parse = eitherDecode reqBody
+  let p = eitherDecode reqBody
-  case parse of
+  case p of
     Left err ->
       return $ responseLBS status400 [jsonH] jErr
       where
         jErr = encode . object $
-          [("error", String $ "Failed to parse JSON payload. " <> cs err)]
+          [("message", String $ "Failed to parse JSON payload. " <> cs err)]
     Right (Object o) -> handler o
     Right _ ->
       return $ responseLBS status400 [jsonH] jErr
       where
         jErr = encode . object $
-          [("error", String "Expecting a JSON object")]
+          [("message", String "Expecting a JSON object")]
 
 data TableOptions = TableOptions {
   tblOptcolumns :: [Column]

src/Main.hs

@@ -46,7 +46,7 @@ main = do
                   $ defaultSettings
       middle =
         (if configSecure conf then redirectInsecure else id)
-        . gzip def . cors corsPolicy . clientErrors
+        . gzip def . cors corsPolicy
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
       anonRole = cs $ configAnonRole conf
 
@@ -56,7 +56,7 @@ main = do
       respond =<< catchJust isSqlError
         (unlift $ H.tx Nothing
                 $ authenticated anonRole (app body) req)
-        sqlErrHandler
+        (return . sqlError)
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -3,7 +3,6 @@
 
 module Middleware where
 
---import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
 import Data.Text
@@ -12,9 +11,8 @@ import Data.Text
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
 import Data.String.Conversions(cs)
-import Control.Exception (catchJust)
 
-import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization)
+import Network.HTTP.Types.Header (hLocation, hAuthorization)
 import Network.HTTP.Types (RequestHeaders)
 import Network.HTTP.Types.Status (status400, status401, status301)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
@@ -24,8 +22,6 @@ import Network.URI (URI(..), parseURI)
 import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
-import Debug.Trace
-
 -- data Environment = Test | Production deriving (Eq)
 
 -- safeAction :: Request -> Bool
@@ -69,29 +65,6 @@ authenticated anon app req = do
      resetRole
      return res
 
--- instance ToJSON SqlError where
---   toJSON t = object [
---       "error" .= object [
---           "message" .= (cs $ sqlErrorMsg t :: String)
---         , "detail"  .= (cs $ sqlErrorDetail t :: String)
---         , "state"   .= (cs $ sqlState t :: String)
---         , "hint"    .= (cs $ sqlErrorHint t :: String)
---       ]
---     ]
-
-clientErrors :: Application -> Application
-clientErrors app req respond =
-  catchJust isPgException (app req respond) $ \err ->
-    respond $
-      responseLBS status400 [(hContentType, "application/json")] (cs $ show err)
-      -- if sqlState err == "42P01"
-      --  then responseLBS status404 [] ""
-      --  else responseLBS status400 [(hContentType, "application/json")] (encode err)
-
-  where
-    isPgException :: H.Error -> Maybe H.Error
-    isPgException x = Just (traceShow x x)
-
 
 redirectInsecure :: Application -> Application
 redirectInsecure app req respond = do

src/PgError.hs

@@ -1,38 +1,86 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module PgError (Message(..), parseMessage) where
+module PgError (Message(..), message, httpStatus) where
 
 import Text.Parsec
 import Text.Parsec.Text
 import qualified Data.Map as M
-import Data.Text
+import Text.Regex.TDFA.Text ()
+import Data.Text hiding (drop, concat, head)
+import Data.Aeson
+import Data.Maybe
+import Control.Monad (void)
 
 import Data.String.Conversions (cs)
 import Data.CaseInsensitive (CI, mk)
 
+import Network.HTTP.Types.Status
+
 data Message = Message {
     msgStatus :: Maybe Text
-  , msgCode   :: Maybe Text
+  , msgCode   :: Text
   , msgText   :: Maybe Text
   , msgHint   :: Maybe Text
-} deriving (Show)
+} deriving (Show, Eq)
 
-parseMessage :: Parser Message
+message :: Parser Message
-parseMessage = do
+message = do
-  ps <- sepBy valPair (char ';' >> optional (char ' '))
+  ps <- sepBy valPair (char ';')
   let m = M.fromList ps
   return $ Message
     (M.lookup "status" m)
-    (M.lookup "code" m)
+    (fromMaybe "" $ M.lookup "code" m)
     (M.lookup "message" m)
     (M.lookup "hint" m)
 
 valPair :: Parser (CI Text, Text)
 valPair = do
+  _ <- spaces
   name <- many1 letter
   _ <- char ':'
-  optional $ char ' '
+  spaces
-  _ <- char '"'
+  _ <- many $ char '"'
-  val <- many1 (noneOf "\"")
+  val <- manyTill anyChar $
-  _ <- char '"'
+    try
+      (void $ many (char '"') >> (
+        (void . lookAhead $ (char ';'))
+        <|> ((optional $ char '.') >> eof)
+      ))
   return (mk (cs name), cs val)
+
+
+instance ToJSON Message where
+  toJSON t = object [
+      "message" .= msgText t
+    , "code"    .= msgCode t
+    , "status"  .= msgStatus t
+    , "hint"    .= msgHint t
+    ]
+
+httpStatus :: Message -> Status
+httpStatus m =
+  let code = cs $ msgCode m :: String in
+  case code of
+    '0' : '8' : _ -> status503 -- pg connection err
+    '0' : '9' : _ -> status500 -- triggered action exception
+    '0' : 'L' : _ -> status403 -- invalid grantor
+    '0' : 'P' : _ -> status403 -- invalid role specification
+    '2' : '5' : _ -> status500 -- invalid tx state
+    '2' : '8' : _ -> status403 -- invalid auth specification
+    '2' : 'D' : _ -> status500 -- invalid tx termination
+    '3' : '8' : _ -> status500 -- external routine exception
+    '3' : '9' : _ -> status500 -- external routine invocation
+    '3' : 'B' : _ -> status500 -- savepoint exception
+    '4' : '0' : _ -> status500 -- tx rollback
+    '5' : '3' : _ -> status503 -- insufficient resources
+    '5' : '4' : _ -> status413 -- too complex
+    '5' : '5' : _ -> status500 -- obj not on prereq state
+    '5' : '7' : _ -> status500 -- operator intervention
+    '5' : '8' : _ -> status500 -- system error
+    'F' : '0' : _ -> status500 -- conf file error
+    'H' : 'V' : _ -> status500 -- foreign data wrapper error
+    'P' : '0' : _ -> status500 -- PL/pgSQL Error
+    'X' : 'X' : _ -> status500 -- internal Error
+    "42P01" -> status404 -- undefined table
+    "42501" -> status404 -- insufficient privilege
+    _ -> status400

test/Feature/AuthSpec.hs

@@ -14,7 +14,7 @@ spec :: Spec
 spec = before resetDb $ around withApp $
   describe "authorization" $ do
     it "hides tables that anonymous does not own" $
-      get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404
+      get "/authors_only" `shouldRespondWith` 404
     it "indicates login failure" $ do
       let auth = authHeader "postgrest_test_author" "fakefake"
       request methodGet "/authors_only" [auth] ""

test/Feature/InsertSpec.hs

@@ -73,7 +73,7 @@ spec = before resetDb $ around withApp $ do
       it "fails with 400 and error" $
         post "/simple_pk" "}{ x = 2"
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| {"error":"Failed to parse JSON payload. Failed reading: satisfy"} |]
+            matchBody    = Just [json| {"message":"Failed to parse JSON payload. Failed reading: satisfy"} |]
           , matchStatus  = 400
           , matchHeaders = []
           }

test/SpecHelper.hs

@@ -24,7 +24,7 @@ import qualified Data.ByteString.Char8 as BS
 import Network.Wai.Middleware.Cors (cors)
 import System.Process (readProcess)
 
-import App (app, sqlErrHandler, isSqlError)
+import App (app, sqlError, isSqlError)
 import Config (AppConfig(..), corsPolicy)
 import Middleware
 -- import Auth (addUser)
@@ -52,7 +52,7 @@ withApp perform =
         resp =<< catchJust isSqlError
           (unlift $ H.tx Nothing
                   $ authenticated anonRole (app body) req)
-          sqlErrHandler
+          (return . sqlError)
 
   where middle = cors corsPolicy
 

test/Unit/ErrorsSpec.hs

@@ -0,0 +1,41 @@
+module Unit.ErrorsSpec where
+
+import Test.Hspec
+
+import Text.Parsec
+import PgError
+import Data.Either (rights)
+
+spec :: Spec
+spec =
+  describe "Parsing Hasql errors" $ do
+    it "can handle status and code" $
+      let p = parse message "" "Status: \"foo\"; Code: \"abc\"." in
+      rights [p] `shouldBe` [
+          Message (Just "foo") "abc" Nothing Nothing
+        ]
+    it "can handle weird redundant quotes in status" $
+      let p = parse message "" "Status: \"\"foo\"\"; Code: \"abc\"." in
+      rights [p] `shouldBe` [
+          Message (Just "foo") "abc" Nothing Nothing
+        ]
+    it "can handle text and code" $
+      let p = parse message "" "Message: \"foo\"; Code: \"abc\"." in
+      rights [p] `shouldBe` [
+          Message Nothing "abc" (Just "foo") Nothing
+        ]
+    it "can handle status, text and code" $
+      let p = parse message "" "Status: \"hi\"; Message: \"foo\"; Code: \"abc\"." in
+      rights [p] `shouldBe` [
+          Message (Just "hi") "abc" (Just "foo") Nothing
+        ]
+    it "can handle unescaped quotes in message" $
+      let p = parse message "" "Status: \"hi\"; Message: \"unknown \"foo\"!\"; Code: \"abc\"." in
+      rights [p] `shouldBe` [
+          Message (Just "hi") "abc" (Just "unknown \"foo\"!") Nothing
+        ]
+    it "can handle periods in message" $
+      let p = parse message "" "Message: \"unknown \"foo\".bar\"; Code: \"42P01\"." in
+      rights [p] `shouldBe` [
+          Message Nothing "42P01" (Just "unknown \"foo\".bar") Nothing
+        ]

test/Unit/ErrorsSpec.hx

@@ -1,34 +0,0 @@
-module Unit.ErrorsSpec where
-
-import Test.Hspec
-
-import Database.HDBC (runRaw, quickQuery, fromSql, SqlError)
-import SpecHelper (dbWithSchema)
-import Middleware (withSavepoint, Environment(..))
-import PgQuery (insert)
-import Types(SqlRow(..))
-import Control.Exception(catch)
-import Control.Monad(void)
-import Network.Wai (defaultRequest, responseLBS)
-import Network.HTTP.Types.Status (ok200)
-
-spec :: Spec
-spec = let
-  dbErrApp conn _ res = do
-    _ <- insert "1" "items" (SqlRow []) conn
-    runRaw conn "select 1/0"
-    _ <- insert "1" "items" (SqlRow []) conn
-    res $ responseLBS ok200 [("Content-Type", "application/json")] "{}"
-  in around dbWithSchema $
-
-    describe "withSavepoint" $
-      it "allows partial rollback of request" $ \c -> do
-        let app = withSavepoint Test dbErrApp c
-        [[beforeCount]] <- quickQuery c "select count(*) from \"1\".items" []
-        runRaw c "set role postgrest_anonymous"
-        _ <- insert "1" "items" (SqlRow []) c
-        catch (void $ app defaultRequest (const undefined) ) $
-          \e -> let _ = (e::SqlError) in do
-          _ <- insert "1" "items" (SqlRow []) c
-          [[afterCount]] <- quickQuery c "select count(*) from \"1\".items" []
-          fromSql afterCount `shouldBe` (fromSql beforeCount::Int) + 2