postgrest 0.2.10.0 → 0.2.11.0
raw patch · 8 files changed
+278/−152 lines, 8 filesdep −regex-tdfa-textdep ~aesondep ~bcryptdep ~hasql
Dependencies removed: regex-tdfa-text
Dependency ranges changed: aeson, bcrypt, hasql, hasql-backend, hasql-postgres, hspec, hspec-wai, network, network-uri, optparse-applicative, wai, wai-middleware-static, warp
Files
- postgrest.cabal +17/−19
- src/PostgREST/App.hs +85/−40
- src/PostgREST/Auth.hs +4/−7
- src/PostgREST/Main.hs +19/−9
- src/PostgREST/Middleware.hs +24/−9
- src/PostgREST/PgQuery.hs +69/−39
- src/PostgREST/PgStructure.hs +46/−23
- test/SpecHelper.hs +14/−6
postgrest.cabal view
@@ -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
src/PostgREST/App.hs view
@@ -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
src/PostgREST/Auth.hs view
@@ -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
src/PostgREST/Main.hs view
@@ -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
src/PostgREST/Middleware.hs view
@@ -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
src/PostgREST/PgQuery.hs view
@@ -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
src/PostgREST/PgStructure.hs view
@@ -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]
test/SpecHelper.hs view
@@ -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