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

WIP: Trap postgres errors in middleware

Browse Source 
Fixes #39
This commit is contained in:
Joe Nelson
2014-10-08 14:58:38 -07:00
parent 68d0a38806
commit 527d51670c
5 changed files with 97 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+1
View File
@@ -36,6 +36,7 @@ executable dbapi
, PgStructure , PgStructure
, PgQuery , PgQuery
, RangeQuery , RangeQuery
, Middleware
hs-source-dirs: src hs-source-dirs: src
Test-Suite spec Test-Suite spec
src/Dbapi.hs
+59 -67
View File
@@ -5,7 +5,6 @@ module Dbapi where
import Types (SqlRow, getRow) import Types (SqlRow, getRow)
import Control.Exception (try)
import Control.Monad (join) import Control.Monad (join)
import Control.Exception.Base (bracket_) import Control.Exception.Base (bracket_)
import Control.Arrow ((***)) import Control.Arrow ((***))
@@ -35,7 +34,6 @@ import Data.String.Conversions (cs)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Database.HDBC.PostgreSQL (Connection) import Database.HDBC.PostgreSQL (Connection)
import Database.HDBC.Types (SqlError, seErrorMsg)
import PgStructure (printTables, printColumns, primaryKeyColumns, import PgStructure (printTables, printColumns, primaryKeyColumns,
columns, Column(colName)) columns, Column(colName))
@@ -94,7 +92,7 @@ app conn anonymous req respond = do
MalformedAuth -> MalformedAuth ->
respond $ responseLBS status400 [] "Malformed basic auth header" respond $ responseLBS status400 [] "Malformed basic auth header"
LoginFailed -> LoginFailed ->
respond $ responseLBS status403 [] "Invalid username or password" respond $ responseLBS status401 [] "Invalid username or password"
LoginSuccess role -> LoginSuccess role ->
bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond
NoCredentials -> NoCredentials ->
@@ -102,73 +100,70 @@ app conn anonymous req respond = do
appWithRole :: Connection -> Application appWithRole :: Connection -> Application
appWithRole conn req respond = do appWithRole conn req respond =
r <- try $ respond =<< case (path, verb) of
case (path, verb) of ([], _) ->
([], _) -> responseLBS status200 [jsonContentType] <$> printTables ver conn
responseLBS status200 [jsonContentType] <$> printTables ver conn
([table], "OPTIONS") -> ([table], "OPTIONS") ->
responseLBS status200 [jsonContentType, allOrigins] <$> responseLBS status200 [jsonContentType, allOrigins] <$>
printColumns ver (cs table) conn printColumns ver (cs table) conn
([table], "GET") -> ([table], "GET") ->
if range == Just emptyRange if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error" then return $ responseLBS status416 [] "HTTP Range error"
else do else do
r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
let canonical = urlEncodeVars $ sort $ let canonical = urlEncodeVars $ sort $
map (join (***) cs) $ map (join (***) cs) $
parseSimpleQuery $ parseSimpleQuery $
rawQueryString req rawQueryString req
return $ addHeaders [ return $ addHeaders [
("Content-Location", ("Content-Location",
"/" <> cs table <> "?" <> cs canonical "/" <> cs table <> "?" <> cs canonical
)] r )] r
([table], "POST") -> ([table], "POST") ->
jsonBodyAction req (\row -> do jsonBodyAction req (\row -> do
allvals <- insert ver table row conn allvals <- insert ver table row conn
keys <- primaryKeyColumns ver (cs table) conn keys <- primaryKeyColumns ver (cs table) conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201 return $ responseLBS status201
[ jsonContentType [ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params) , (hLocation, "/" <> cs table <> "?" <> cs params)
] "" ] ""
) )
([table], "PUT") -> ([table], "PUT") ->
jsonBodyAction req (\row -> do jsonBodyAction req (\row -> do
keys <- primaryKeyColumns ver (cs table) conn keys <- primaryKeyColumns ver (cs table) conn
let specifiedKeys = map (cs . fst) qq let specifiedKeys = map (cs . fst) qq
if S.fromList keys /= S.fromList specifiedKeys if S.fromList keys /= S.fromList specifiedKeys
then return $ responseLBS status405 [] then return $ responseLBS status405 []
"You must speficy all and only primary keys as params" "You must speficy all and only primary keys as params"
else else
if isJust cRange if isJust cRange
then return $ responseLBS status400 [] then return $ responseLBS status400 []
"Content-Range is not allowed in PUT request" "Content-Range is not allowed in PUT request"
else do else do
cols <- columns ver (cs table) conn cols <- columns ver (cs table) conn
let colNames = S.fromList $ map (cs . colName) cols let colNames = S.fromList $ map (cs . colName) cols
let specifiedCols = S.fromList $ map fst $ getRow row let specifiedCols = S.fromList $ map fst $ getRow row
if colNames == specifiedCols then do if colNames == specifiedCols then do
allvals <- upsert ver table row qq conn allvals <- upsert ver table row qq conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201 return $ responseLBS status201
[ jsonContentType [ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params) , (hLocation, "/" <> cs table <> "?" <> cs params)
] "" ] ""
else return $ if S.null colNames then responseLBS status404 [] "" else return $ if S.null colNames then responseLBS status404 [] ""
else responseLBS status400 [] else responseLBS status400 []
"You must specify all columns in PUT request" "You must specify all columns in PUT request"
) )
(_, _) -> (_, _) ->
return $ responseLBS status404 [] "" return $ responseLBS status404 [] ""
respond $ either sqlErrorHandler id r
where where
path = pathInfo req path = pathInfo req
@@ -232,9 +227,6 @@ requestedVersion hdrs =
accept = cs <$> lookup hAccept hdrs :: Maybe String accept = cs <$> lookup hAccept hdrs :: Maybe String
verStr = (=~ verRegex) <$> accept :: Maybe [[String]] verStr = (=~ verRegex) <$> accept :: Maybe [[String]]
sqlErrorHandler :: SqlError -> Response
sqlErrorHandler e =
responseLBS status400 [] $ cs (seErrorMsg e)
addHeaders :: ResponseHeaders -> Response -> Response addHeaders :: ResponseHeaders -> Response -> Response
addHeaders hdrs (ResponseFile s headers fp m) = addHeaders hdrs (ResponseFile s headers fp m) =
src/Main.hs
+2 -1
View File
@@ -4,6 +4,7 @@
module Main where module Main where
import Dbapi import Dbapi
import Middleware (reportPgErrors)
import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Handler.Warp hiding (Connection)
import Database.HDBC.PostgreSQL (connectPostgreSQL') import Database.HDBC.PostgreSQL (connectPostgreSQL')
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
@@ -40,7 +41,7 @@ main = do
Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
conn <- connectPostgreSQL' dburi 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 where
describe = progDesc "create a REST API to an existing Postgres database" describe = progDesc "create a REST API to an existing Postgres database"
src/Middleware.hs
+33
View File
@@ -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
+2 -3
View File
@@ -13,12 +13,11 @@ spec :: Spec
spec = around appWithFixture $ spec = around appWithFixture $
describe "authorization" $ do describe "authorization" $ do
it "hides tables that anonymous does not own" $ it "hides tables that anonymous does not own" $
-- TODO: should be 404 get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404
get "/authors_only" `shouldRespondWith` 400
it "indicates login failure" $ do it "indicates login failure" $ do
let auth = authHeader "dbapi_test_author_a" "fakefake" let auth = authHeader "dbapi_test_author_a" "fakefake"
request methodGet "/authors_only" [auth] "" request methodGet "/authors_only" [auth] ""
`shouldRespondWith` 403 `shouldRespondWith` 401
it "allows users with permissions to see their tables" $ do it "allows users with permissions to see their tables" $ do
let auth = authHeader "dbapi_test_author_a" "" let auth = authHeader "dbapi_test_author_a" ""
request methodGet "/authors_only" [auth] "" request methodGet "/authors_only" [auth] ""