From f689ce684a92c1537daf70dea09b213a6cd4da72 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 21 Dec 2014 13:31:24 -0800 Subject: [PATCH] Provide proper JSON details for errors Refines HTTP codes for server vs client problems Fixes #92 Fixes #40 --- src/App.hs | 49 ++++++++++++++++++-------- src/Main.hs | 4 +-- src/Middleware.hs | 29 +-------------- src/PgError.hs | 72 +++++++++++++++++++++++++++++++------- test/Feature/AuthSpec.hs | 2 +- test/Feature/InsertSpec.hs | 2 +- test/SpecHelper.hs | 4 +-- test/Unit/ErrorsSpec.hs | 41 ++++++++++++++++++++++ test/Unit/ErrorsSpec.hx | 34 ------------------ 9 files changed, 142 insertions(+), 95 deletions(-) create mode 100644 test/Unit/ErrorsSpec.hs delete mode 100644 test/Unit/ErrorsSpec.hx diff --git a/src/App.hs b/src/App.hs index f3b273950..06f4b0586 100644 --- a/src/App.hs +++ b/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] diff --git a/src/Main.hs b/src/Main.hs index cf9cf6b28..edded4718 100644 --- a/src/Main.hs +++ b/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" diff --git a/src/Middleware.hs b/src/Middleware.hs index ccbb51ca4..df963f7aa 100644 --- a/src/Middleware.hs +++ b/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 diff --git a/src/PgError.hs b/src/PgError.hs index 25d94c16a..3f7db9506 100644 --- a/src/PgError.hs +++ b/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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 8b2c562e7..cc2753788 100644 --- a/test/Feature/AuthSpec.hs +++ b/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] "" diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index d767d40df..efc9625b1 100644 --- a/test/Feature/InsertSpec.hs +++ b/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 = [] } diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 7d21c2c4c..47f85a458 100644 --- a/test/SpecHelper.hs +++ b/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 diff --git a/test/Unit/ErrorsSpec.hs b/test/Unit/ErrorsSpec.hs new file mode 100644 index 000000000..c29524848 --- /dev/null +++ b/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 + ] diff --git a/test/Unit/ErrorsSpec.hx b/test/Unit/ErrorsSpec.hx deleted file mode 100644 index 2d165d6e9..000000000 --- a/test/Unit/ErrorsSpec.hx +++ /dev/null @@ -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