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 _ = Nothing
+isSqlError = Just
+
+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
-  case parse of
+  let p = eitherDecode reqBody
+  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
-parseMessage = do
-  ps <- sepBy valPair (char ';' >> optional (char ' '))
+message :: Parser Message
+message = do
+  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 ' '
-  _ <- char '"'
-  val <- many1 (noneOf "\"")
-  _ <- char '"'
+  spaces
+  _ <- many $ char '"'
+  val <- manyTill anyChar $
+    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