diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.10.0 +version: 0.2.11.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -27,21 +27,21 @@ default-language: Haskell2010 build-depends: base >=4.6 && <5 , postgrest - , hasql == 0.7.3.1, hasql-backend == 0.4.1 - , hasql-postgres == 0.10.3.1 + , hasql >= 0.7.3 && < 0.8 + , hasql-backend >= 0.4.1 && < 0.5 + , hasql-postgres >= 0.10.4 && < 0.11 , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 , HTTP, convertible, http-types , case-insensitive , scientific, time - , aeson, network >= 2.6 + , aeson >= 0.8, network >= 2.6 , bytestring, text, split, string-conversions , stringsearch , containers, unordered-containers , optparse-applicative == 0.11.* , regex-base, regex-tdfa - , regex-tdfa-text , Ranged-sets , transformers, MissingH , bcrypt >= 0.0.6, base64-string @@ -63,25 +63,24 @@ default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes build-depends: base >=4.6 && <5 - , hasql == 0.7.3.1, hasql-backend == 0.4.1 - , hasql-postgres == 0.10.3.1 - , warp >= 3.0.2, wai >= 3.0.1 + , hasql, hasql-backend + , hasql-postgres + , warp, wai , wai-extra, wai-cors - , wai-middleware-static >= 0.6.0 + , wai-middleware-static , HTTP, convertible, http-types , case-insensitive , scientific, time - , aeson, network >= 2.6 + , aeson, network , bytestring, text, split, string-conversions , stringsearch , containers, unordered-containers - , optparse-applicative == 0.11.* + , optparse-applicative , regex-base, regex-tdfa - , regex-tdfa-text , Ranged-sets , transformers, MissingH - , bcrypt >= 0.0.6, base64-string - , network-uri >= 2.6 + , bcrypt, base64-string + , network-uri , resource-pool , blaze-builder , vector @@ -118,10 +117,10 @@ , PostgREST.RangeQuery , Spec , SpecHelper - Build-Depends: base, hspec >= 2.1.2, QuickCheck - , hspec-wai >= 0.5.0, hspec-wai-json - , hasql == 0.7.3.1, hasql-backend == 0.4.1 - , hasql-postgres == 0.10.3.1 + Build-Depends: base, hspec == 2.1.*, QuickCheck + , hspec-wai, hspec-wai-json + , hasql, hasql-backend + , hasql-postgres , warp, wai , packdeps, hlint , HTTP, convertible @@ -136,7 +135,6 @@ , regex-base , string-conversions , http-media, regex-tdfa - , regex-tdfa-text , Ranged-sets , transformers, MissingH, split , bcrypt, base64-string diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,22 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} -module PostgREST.App (app, sqlError, isSqlError) where +module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept) where import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative -import Data.Text hiding (map) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text hiding (map, find) +import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import qualified Data.HashMap.Strict as M import Data.String.Conversions (cs) import Data.CaseInsensitive (original) -import Data.List (sortBy) +import Data.List (sortBy, find) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS import qualified Blaze.ByteString.Builder as BB import qualified Data.Csv as CSV @@ -25,6 +26,7 @@ import Network.HTTP.Types.URI (parseSimpleQuery) import Network.HTTP.Base (urlEncodeVars) import Network.Wai +import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Internal (Response(..)) import Data.Aeson @@ -50,9 +52,9 @@ return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do - let t = QualifiedTable schema (cs table) - cols <- columns t - pkey <- map cs <$> primaryKeyColumns t + let qt = qualify table + cols <- columns qt + pkey <- map cs <$> primaryKeyColumns qt return $ responseLBS status200 [jsonH, allOrigins] $ encode (TableOptions cols pkey) @@ -60,21 +62,21 @@ if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else do - let qt = QualifiedTable schema (cs table) - let select = B.Stmt "select " V.empty True <> + let qt = qualify table + from = fromMaybe 0 $ rangeOffset <$> range + select = B.Stmt "select " V.empty True <> parentheticT ( - whereT qq $ countRows qt + whereT qt qq $ countRows qt ) <> commaq <> ( - asJsonWithCount + bodyForAccept contentType qt . limitT range . orderT (orderParse qq) - . whereT qq + . whereT qt qq $ selectStar qt ) row <- H.maybeEx select let (tableTotal, queryTotal, body) = fromMaybe (0, 0, Just "" :: Maybe Text) row - from = fromMaybe 0 $ rangeOffset <$> range to = from+queryTotal-1 contentRange = contentRangeH from to tableTotal status = rangeStatus from to tableTotal @@ -84,7 +86,7 @@ . parseSimpleQuery $ rawQueryString req return $ responseLBS status - [jsonH, contentRange, + [contentTypeH, contentRange, ("Content-Location", "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical @@ -127,10 +129,10 @@ encode . object $ [("message", String "Failed authentication.")] ([table], "POST") -> do - let qt = QualifiedTable schema (cs table) - echoRequested = lookup "Prefer" hdrs == Just "return=representation" + let qt = qualify table + echoRequested = lookupHeader "Prefer" == Just "return=representation" parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) - parsed = if lookup "Content-Type" hdrs == Just "text/csv" + parsed = if lookupHeader "Content-Type" == Just csvMT then do rows <- CSV.decode CSV.NoHeader reqBody if V.null rows then Left "CSV requires header" @@ -161,9 +163,25 @@ ] $ if echoRequested then encode obj else "" return $ multipart status201 responses + (["rpc", proc], "POST") -> do + let qi = QualifiedIdentifier schema (cs proc) + exists <- doesProcExist schema proc + if exists + then do + let call = B.Stmt "select " V.empty True <> + asJson (callProc qi $ fromMaybe M.empty (decode reqBody)) + body :: Maybe (Identity Text) <- H.maybeEx call + return $ responseLBS status200 [jsonH] + (cs $ fromMaybe "[]" $ runIdentity <$> body) + else return $ responseLBS status404 [] "" + + -- check that proc exists + -- check that arg names are all specified + -- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT + ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do - let qt = QualifiedTable schema (cs table) + let qt = qualify table primaryKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq if S.fromList primaryKeys /= S.fromList specifiedKeys @@ -176,7 +194,7 @@ then do let vals = M.elems obj H.unitEx $ iffNotT - (whereT qq $ update qt cols vals) + (whereT qt qq $ update qt cols vals) (insertSelect qt cols vals) return $ responseLBS status204 [ jsonH ] "" @@ -187,9 +205,9 @@ ([table], "PATCH") -> handleJsonObj reqBody $ \obj -> do - let qt = QualifiedTable schema (cs table) + let qt = qualify table up = returningStarT - . whereT qq + . whereT qt qq $ update qt (map cs $ M.keys obj) (M.elems obj) patch = withT up "t" $ B.Stmt "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" @@ -199,17 +217,17 @@ let (queryTotal, body) = fromMaybe (0 :: Int, Just "" :: Maybe Text) row r = contentRangeH 0 (queryTotal-1) queryTotal - echoRequested = lookup "Prefer" hdrs == Just "return=representation" + echoRequested = lookupHeader "Prefer" == Just "return=representation" s = case () of _ | queryTotal == 0 -> status404 | echoRequested -> status200 | otherwise -> status204 return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else "" ([table], "DELETE") -> do - let qt = QualifiedTable schema (cs table) - let del = countT + let qt = qualify table + del = countT . returningStarT - . whereT qq + . whereT qt qq $ deleteFrom qt row <- H.maybeEx del let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row @@ -221,15 +239,20 @@ return $ responseLBS status404 [] "" where - path = pathInfo req - verb = requestMethod req - qq = queryString req - hdrs = requestHeaders req - schema = requestedSchema (cs $ configV1Schema conf) hdrs + path = pathInfo req + verb = requestMethod req + qq = queryString req + qualify = QualifiedIdentifier schema + hdrs = requestHeaders req + lookupHeader = flip lookup hdrs + accept = lookupHeader hAccept + schema = requestedSchema (cs $ configV1Schema conf) accept authenticator = cs $ configDbUser conf - jwtSecret = cs $ configJwtSecret conf - range = rangeRequested hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + jwtSecret = cs $ configJwtSecret conf + range = rangeRequested hdrs + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + contentType = fromMaybe "application/json" $ contentTypeForAccept accept + contentTypeH = (hContentType, contentType) sqlError :: t sqlError = undefined @@ -253,18 +276,40 @@ <> cs (show total) ) -requestedSchema :: Text -> RequestHeaders -> Text -requestedSchema v1schema hdrs = +requestedSchema :: Text -> Maybe BS.ByteString -> Text +requestedSchema v1schema accept = case verStr of - Just [[_, ver]] -> if ver == "1" then v1schema else ver + Just [[_, ver]] -> if ver == "1" then v1schema else cs ver _ -> v1schema - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = cs <$> lookup hAccept hdrs :: Maybe Text - verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] + where verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString + verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] + +jsonMT :: BS.ByteString +jsonMT = "application/json" + +csvMT :: BS.ByteString +csvMT = "text/csv" + jsonH :: Header -jsonH = (hContentType, "application/json") +jsonH = (hContentType, jsonMT) + +contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString +contentTypeForAccept accept + | isNothing accept || hasJson = Just jsonMT + | hasCsv = Just csvMT + | otherwise = Nothing + where + Just acceptH = accept + findInAccept = flip find $ parseHttpAccept acceptH + hasJson = isJust $ findInAccept $ BS.isPrefixOf jsonMT + hasCsv = isJust $ findInAccept $ BS.isPrefixOf csvMT + +bodyForAccept :: BS.ByteString -> QualifiedIdentifier -> StatementT +bodyForAccept contentType table + | contentType == csvMT = asCsvWithCount table + | otherwise = asJsonWithCount -- defaults to JSON handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response) -> H.Tx P.Postgres s Response diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -53,14 +53,11 @@ checkPass = (. cs) . validatePassword . cs setRole :: Text -> H.Tx P.Postgres s () -setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True - -resetRole :: H.Tx P.Postgres s () -resetRole = H.unitEx [H.stmt|reset role|] +setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True setUserId :: Text -> H.Tx P.Postgres s () setUserId uid = if uid /= "" then - H.unitEx $ B.Stmt ("set user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True + H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True else resetUserId @@ -90,12 +87,12 @@ Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid) _ -> LoginFailed _ -> LoginFailed - where + where maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value) maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value) claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input - + tokenJWT :: Text -> Text -> Text -> Text tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet where diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} module Main where import Paths_postgrest (version) @@ -10,21 +11,30 @@ import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) import Network.Wai (strictRequestBody) -import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) -import Network.Wai.Middleware.Gzip (gzip, def) -import Network.Wai.Middleware.Static (staticPolicy, only) import Network.Wai.Middleware.RequestLogger (logStdout) import Data.List (intercalate) import Data.Version (versionBranch) +import Data.Functor.Identity +import Data.Text(Text) import qualified Hasql as H import qualified Hasql.Postgres as P import Options.Applicative hiding (columns) -import PostgREST.Config (AppConfig(..), argParser, corsPolicy) +import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..)) +import PostgREST.Config (AppConfig(..), argParser) + +isServerVersionSupported = do + Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|] + return $ read (cs row) >= 90200 + main :: IO () main = do + hSetBuffering stdout LineBuffering + hSetBuffering stdin LineBuffering + hSetBuffering stderr NoBuffering + let opts = info (helper <*> argParser) $ fullDesc <> progDesc ( @@ -51,19 +61,19 @@ appSettings = setPort port . setServerName (cs $ "postgrest/" <> prettyVersion) $ defaultSettings - middle = logStdout - . (if configSecure conf then redirectInsecure else id) - . gzip def . cors corsPolicy - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + middle = logStdout . defaultMiddle (configSecure conf) poolSettings <- maybe (fail "Improper session settings") return $ H.poolSettings (fromIntegral $ configPool conf) 30 pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings + resOrError <- H.session pool isServerVersionSupported + either (fail . show) (\supported -> unless supported $ fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0") resOrError + runSettings appSettings $ middle $ \req respond -> do body <- strictRequestBody req - resOrError <- liftIO $ H.session pool $ H.tx Nothing $ + resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ authenticated conf (app conf body) req either (respond . errResponse) respond resOrError diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,7 +3,7 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import Data.Text -- import Data.Pool(withResource, Pool) @@ -12,15 +12,19 @@ import qualified Hasql.Postgres as P import Data.String.Conversions(cs) -import Network.HTTP.Types.Header (hLocation, hAuthorization) +import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept) import Network.HTTP.Types (RequestHeaders) -import Network.HTTP.Types.Status (status400, status401, status301) +import Network.HTTP.Types.Status (status400, status401, status301, status415) import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, rawQueryString, isSecure, Request(..), Response) +import Network.Wai.Middleware.Gzip (gzip, def) +import Network.Wai.Middleware.Cors (cors) +import Network.Wai.Middleware.Static (staticPolicy, only) import Network.URI (URI(..), parseURI) -import PostgREST.Config (AppConfig(..)) -import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole, setUserId, resetUserId) +import PostgREST.Config (AppConfig(..), corsPolicy) +import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) +import PostgREST.App (contentTypeForAccept) import Codec.Binary.Base64.String (decode) import Prelude @@ -58,10 +62,7 @@ runInRole r uid = do setUserId uid setRole r - res <- app req - resetRole - resetUserId - return res + app req redirectInsecure :: Application -> Application @@ -84,3 +85,17 @@ Nothing -> respond $ responseLBS status400 [] "SSL is required" else app req respond + +unsupportedAccept :: Application -> Application +unsupportedAccept app req respond = do + let + accept = lookup hAccept $ requestHeaders req + if isNothing $ contentTypeForAccept accept + then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json" + else app req respond + +defaultMiddle :: Bool -> Application -> Application +defaultMiddle secure = (if secure then redirectInsecure else id) + . gzip def . cors corsPolicy + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + . unsupportedAccept diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -10,8 +10,8 @@ import qualified Hasql.Backend as B import qualified Data.Text as T +import qualified Data.HashMap.Strict as H import Text.Regex.TDFA ( (=~) ) -import Text.Regex.TDFA.Text () import qualified Network.HTTP.Types.URI as Net import qualified Data.ByteString.Char8 as BS import Data.Monoid @@ -34,9 +34,9 @@ mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt -data QualifiedTable = QualifiedTable { - qtSchema :: T.Text -, qtName :: T.Text +data QualifiedIdentifier = QualifiedIdentifier { + qiSchema :: T.Text +, qiName :: T.Text } deriving (Show) data OrderTerm = OrderTerm { @@ -52,14 +52,15 @@ limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r -whereT :: Net.Query -> StatementT -whereT params q = +whereT :: QualifiedIdentifier -> Net.Query -> StatementT +whereT table params q = if L.null cols then q else q <> B.Stmt " where " empty True <> conjunction where cols = [ col | col <- params, fst col `notElem` ["order"] ] - conjunction = mconcat $ L.intersperse andq (map wherePred cols) + wherePredTable = wherePred table + conjunction = mconcat $ L.intersperse andq (map wherePredTable cols) withT :: PStmt -> T.Text -> StatementT withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) = @@ -95,36 +96,53 @@ countT :: StatementT countT s = - s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" } + s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" } -countRows :: QualifiedTable -> PStmt -countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True +countRows :: QualifiedIdentifier -> PStmt +countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True +asCsvWithCount :: QualifiedIdentifier -> StatementT +asCsvWithCount table = withCount . asCsv table + +asCsv :: QualifiedIdentifier -> StatementT +asCsv table s = s { B.stmtTemplate = + "(select string_agg(quote_ident(column_name::text), ',') from " + <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '" + <> fromQi table <> "' order by ordinal_position) h) || '\r' || " + <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from (" + <> B.stmtTemplate s <> ") t" } + asJsonWithCount :: StatementT -asJsonWithCount s = s { B.stmtTemplate = - "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" - <> B.stmtTemplate s <> ") t" } +asJsonWithCount = withCount . asJson +asJson :: StatementT +asJson s = s { B.stmtTemplate = + "array_to_json(array_agg(row_to_json(t)))::character varying from (" + <> B.stmtTemplate s <> ") t" } + +withCount :: StatementT +withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s } + asJsonRow :: StatementT asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" } -selectStar :: QualifiedTable -> PStmt -selectStar t = B.Stmt ("select * from " <> fromQt t) empty True +selectStar :: QualifiedIdentifier -> PStmt +selectStar t = B.Stmt ("select * from " <> fromQi t) empty True returningStarT :: StatementT returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } -deleteFrom :: QualifiedTable -> PStmt -deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True +deleteFrom :: QualifiedIdentifier -> PStmt +deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True -insertInto :: QualifiedTable +insertInto :: QualifiedIdentifier -> V.Vector T.Text -> V.Vector (V.Vector JSON.Value) -> PStmt insertInto t cols vals - | V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True + | V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True | otherwise = B.Stmt - ("insert into " <> fromQt t <> " (" <> + ("insert into " <> fromQi t <> " (" <> T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <> ") values " <> T.intercalate ", " @@ -133,38 +151,48 @@ <> ")" ) vals ) - <> " returning row_to_json(" <> fromQt t <> ".*)") + <> " returning row_to_json(" <> fromQi t <> ".*)") empty True -insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt +insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt insertSelect t [] _ = B.Stmt - ("insert into " <> fromQt t <> " default values returning *") empty True + ("insert into " <> fromQi t <> " default values returning *") empty True insertSelect t cols vals = B.Stmt - ("insert into " <> fromQt t <> " (" + ("insert into " <> fromQi t <> " (" <> T.intercalate ", " (map pgFmtIdent cols) <> ") select " <> T.intercalate ", " (map insertableValue vals)) empty True -update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt +update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt update t cols vals = B.Stmt - ("update " <> fromQt t <> " set (" + ("update " <> fromQi t <> " set (" <> T.intercalate ", " (map pgFmtIdent cols) <> ") = (" <> T.intercalate ", " (map insertableValue vals) <> ")") empty True -wherePred :: Net.QueryItem -> PStmt -wherePred (col, predicate) = - B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <> +callProc :: QualifiedIdentifier -> JSON.Object -> PStmt +callProc qi params = do + let args = T.intercalate "," $ map assignment (H.toList params) + B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True + where + assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v + +wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt +wherePred table (col, predicate) = + B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <> if opCode `elem` ["is","isnot"] then whiteList value else cs sqlValue) empty True where - opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate - value = T.intercalate "." rest + headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ") (L.find ((==) . T.toLower $ val) ["null","true","false"]) @@ -175,6 +203,7 @@ "like" -> unknownLiteral $ T.map star value "ilike" -> unknownLiteral $ T.map star value "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " _ -> unknownLiteral value @@ -188,6 +217,7 @@ "like"-> "like" "ilike"-> "ilike" "in" -> "in" + "notin" -> "not in" "is" -> "is" "isnot" -> "is not" "@@" -> "@@" @@ -238,11 +268,11 @@ (KeyIdentifier b) _ -> Nothing -pgFmtJsonbPath :: T.Text -> T.Text -pgFmtJsonbPath p = +pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text +pgFmtJsonbPath table p = pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p) where - pgFmtJsonbPath' (ColIdentifier i) = pgFmtIdent i + pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i pgFmtJsonbPath' (SingleArrow a b) = pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b @@ -252,26 +282,26 @@ pgFmtIdent :: T.Text -> T.Text pgFmtIdent x = let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in - if escaped =~ danger + if (cs escaped :: BS.ByteString) =~ danger then "\"" <> escaped <> "\"" else escaped - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString pgFmtLit :: T.Text -> T.Text pgFmtLit x = let trimmed = trimNullChars x escaped = "'" <> T.replace "'" "''" trimmed <> "'" slashed = T.replace "\\" "\\\\" escaped in - cs $ if escaped =~ ("\\\\" :: T.Text) + if T.isInfixOf "\\\\" escaped then "E" <> slashed else slashed trimNullChars :: T.Text -> T.Text trimNullChars = T.takeWhile (/= '\x0') -fromQt :: QualifiedTable -> T.Text -fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) +fromQi :: QualifiedIdentifier -> T.Text +fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t) unquoted :: JSON.Value -> T.Text unquoted (JSON.String t) = t diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -3,12 +3,12 @@ FlexibleContexts #-} module PostgREST.PgStructure where -import PostgREST.PgQuery (QualifiedTable(..)) +import PostgREST.PgQuery (QualifiedIdentifier(..)) import Data.Text hiding (foldl, map, zipWith, concat) import Data.Aeson import Data.Functor.Identity import Data.String.Conversions (cs) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Control.Applicative import qualified Data.Map as Map @@ -18,7 +18,7 @@ import Prelude -foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey) +foreignKeys :: QualifiedIdentifier -> H.Tx P.Postgres s (Map.Map Text ForeignKey) foreignKeys table = do r <- H.listEx $ [H.stmt| select kcu.column_name, ccu.table_name AS foreign_table_name, @@ -31,7 +31,7 @@ where constraint_type = 'FOREIGN KEY' and tc.table_name=? and tc.table_schema = ? order by kcu.column_name - |] (qtName table) (qtSchema table) + |] (qiName table) (qiSchema table) return $ foldl addKey Map.empty r where @@ -43,22 +43,37 @@ tables schema = do rows <- H.listEx $ [H.stmt| - select table_schema, table_name, - is_insertable_into - from information_schema.tables - where table_schema = ? - order by table_name + select + n.nspname as table_schema, + relname as table_name, + c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 + or (exists ( + select 1 + from pg_trigger + where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69) + ) as insertable + from + pg_class c + join pg_namespace n on n.oid = c.relnamespace + where + c.relkind in ('v', 'r', 'm') + and n.nspname = ? + and ( + pg_has_role(c.relowner, 'USAGE'::text) + or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) + ) + order by relname |] schema return $ map tableFromRow rows -columns :: QualifiedTable -> H.Tx P.Postgres s [Column] +columns :: QualifiedIdentifier -> H.Tx P.Postgres s [Column] columns table = do cols <- H.listEx $ [H.stmt| select info.table_schema as schema, info.table_name as table_name, info.column_name as name, info.ordinal_position as position, - info.is_nullable as nullable, info.data_type as col_type, - info.is_updatable as updatable, + info.is_nullable::boolean as nullable, info.data_type as col_type, + info.is_updatable::boolean as updatable, info.character_maximum_length as max_len, info.numeric_precision as precision, info.column_default as default_value, @@ -82,7 +97,7 @@ ) as enum_info on (info.udt_name = enum_info.n) order by position |] - (qtSchema table) (qtName table) + (qiSchema table) (qiName table) fks <- foreignKeys table return $ map (addFK fks . columnFromRow) cols @@ -91,7 +106,7 @@ addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } -primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text] +primaryKeyColumns :: QualifiedIdentifier -> H.Tx P.Postgres s [Text] primaryKeyColumns table = do r <- H.listEx $ [H.stmt| select kc.column_name @@ -103,12 +118,20 @@ and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema and kc.constraint_name = tc.constraint_name and kc.table_schema = ? - and kc.table_name = ? |] (qtSchema table) (qtName table) + and kc.table_name = ? |] (qiSchema table) (qiName table) return $ map runIdentity r - -toBool :: Text -> Bool -toBool = (== "YES") +doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool +doesProcExist schema proc = do + row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt| + SELECT 1 + FROM pg_catalog.pg_namespace n + JOIN pg_catalog.pg_proc p + ON pronamespace = n.oid + WHERE nspname = ? + AND proname = ? + |] schema proc + return $ isJust row data Table = Table { tableSchema :: Text @@ -135,16 +158,16 @@ , colFK :: Maybe ForeignKey } deriving (Show) -tableFromRow :: (Text, Text, Text) -> Table -tableFromRow (s, n, i) = Table s n (toBool i) +tableFromRow :: (Text, Text, Bool) -> Table +tableFromRow (s, n, i) = Table s n i columnFromRow :: (Text, Text, Text, - Int, Text, Text, - Text, Maybe Int, Maybe Int, + Int, Bool, Text, + Bool, Maybe Int, Maybe Int, Maybe Text, Maybe Text) -> Column columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = - Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing + Column s t n pos nul typ u l p d (parseEnum e) Nothing where parseEnum :: Maybe Text -> [Text] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -15,19 +15,18 @@ import Control.Monad (void) import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, - hRange, hAuthorization) + hRange, hAuthorization, hAccept) import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..)) import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS -import Network.Wai.Middleware.Cors (cors) import System.Process (readProcess) import qualified Data.Aeson.Types as J import PostgREST.App (app) -import PostgREST.Config (AppConfig(..), corsPolicy) +import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(errResponse) @@ -55,11 +54,11 @@ perform $ middle $ \req resp -> do body <- strictRequestBody req - result <- liftIO $ H.session pool $ H.tx Nothing + result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ authenticated cfg (app cfg body) req either (resp . errResponse) resp result - where middle = cors corsPolicy + where middle = defaultMiddle False resetDb :: IO () @@ -84,6 +83,9 @@ rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] +acceptHdrs :: BS.ByteString -> [Header] +acceptHdrs mime = [(hAccept, mime)] + rangeUnit :: Header rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items") @@ -94,7 +96,7 @@ authHeaderBasic :: String -> String -> Header authHeaderBasic u p = (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) - + authHeaderJWT :: String -> Header authHeaderJWT token = (hAuthorization, cs $ "Bearer " ++ token) @@ -124,6 +126,12 @@ txn = mapM_ H.unitEx (stmt':stmts) stmt' = [H.stmt|insert into "1".no_pk (a,b) values (null,null)|] stmts = map [H.stmt|insert into "1".no_pk (a,b) values (?,0)|] [1..n] + +createNullInteger :: IO () +createNullInteger = do + pool <- testPool + void . liftIO $ H.session pool $ H.tx Nothing $ + H.unitEx $ [H.stmt| insert into "1".nullable_integer (a) values (null) |] createLikableStrings :: IO () createLikableStrings = do