jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Provide proper JSON details for errors

Browse Source 
Refines HTTP codes for server vs client problems

Fixes #92
Fixes #40
This commit is contained in:
Joe Nelson
2014-12-21 19:34:21 -08:00
parent 07b039370d
commit f689ce684a
9 changed files with 142 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/App.hs
+34 -15
View File
@@ -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
+2 -2
View File
@@ -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
+1 -28
View File
@@ -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
+60 -12
View File
@@ -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
test/Feature/AuthSpec.hs
+1 -1
View File
@@ -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
+1 -1
View File
@@ -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
+2 -2
View File
@@ -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
+41
View File
@@ -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
-34
View File
@@ -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