diff --git a/postgrest.cabal b/postgrest.cabal index bae11bca3..bfe278c4a 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -52,6 +52,9 @@ executable postgrest , mtl , cassava , jwt + , parsec + , errors + , bifunctors hs-source-dirs: src library @@ -87,7 +90,14 @@ library , mtl , cassava , jwt + , parsec + , errors + , bifunctors + Exposed-Modules: PostgREST.App + , PostgREST.Types + , PostgREST.Parsers + , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -108,6 +118,9 @@ Test-Suite spec ghc-options: -Wall -W -O2 Main-Is: Main.hs Other-Modules: PostgREST.App + , PostgREST.Types + , PostgREST.Parsers + , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -147,3 +160,6 @@ Test-Suite spec , process , heredoc , jwt + , parsec + , errors + , bifunctors diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 6c2ba9694..8dc758f48 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,98 +1,137 @@ -{-# LANGUAGE FlexibleContexts #-} -module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept) where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module PostgREST.App ( + app +, sqlError +, isSqlError +, contentTypeForAccept +, jsonH +, requestedSchema +, TableOptions(..) +) where -import Control.Monad (join) -import Control.Arrow ((***), second) -import Control.Applicative +import qualified Blaze.ByteString.Builder as BB +import Control.Applicative +import Control.Arrow (second, (***)) +import Control.Monad (join) +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import Data.CaseInsensitive (original) +import qualified Data.Csv as CSV +import Data.Functor.Identity +import qualified Data.HashMap.Strict as M +import Data.List (find, sortBy) +import Data.Maybe (fromMaybe, isJust, isNothing, + mapMaybe) +import Data.Ord (comparing) +import Data.Ranged.Ranges (emptyRange) +import qualified Data.Set as S +import Data.String.Conversions (cs) +import Data.Text (Text, replace, strip) +import Text.Regex.TDFA ((=~)) -import Data.Text (Text) -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, 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 +import Text.Parsec.Error -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -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 Network.HTTP.Base (urlEncodeVars) +import Network.HTTP.Types.Header +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI (parseSimpleQuery) +import Network.Wai +import Network.Wai.Internal (Response (..)) +import Network.Wai.Parse (parseHttpAccept) -import Data.Aeson -import Data.Monoid -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P +import Data.Aeson +import Data.Monoid +import qualified Data.Vector as V +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P -import PostgREST.Config (AppConfig(..)) -import PostgREST.Auth -import PostgREST.PgQuery -import PostgREST.RangeQuery -import PostgREST.PgStructure +import PostgREST.Auth +import PostgREST.Config (AppConfig (..)) +import PostgREST.Parsers +import PostgREST.PgQuery +import PostgREST.PgStructure +import PostgREST.QueryBuilder +import PostgREST.RangeQuery +import PostgREST.Types -import Prelude +import Prelude -app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response -app conf reqBody req = +app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response +app dbstructure conf reqBody dbrole req = case (path, verb) of + ([], _) -> do - body <- encode <$> tables (cs schema) + let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do - let qt = qualify table - cols <- columns qt - pkey <- map cs <$> primaryKeyColumns qt - return $ responseLBS status200 [jsonH, allOrigins] - $ encode (TableOptions cols pkey) + let cols = filter (filterCol schema table) allCols + pkeys = map pkName $ filter (filterPk schema table) allPrKeys + body = encode (TableOptions cols pkeys) + return $ responseLBS status200 [jsonH, allOrigins] $ cs body ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" - else do - let qt = qualify table - from = fromMaybe 0 $ rangeOffset <$> range - count = if hasPrefer "count=none" + else + case queries of + Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e + Right (qs, cqs) -> do + let qt = qualify table + count = if hasPrefer "count=none" then countNone - else whereT qt qq $ countRows qt - query = B.Stmt "select " V.empty True <> - parentheticT count <> commaq <> ( - bodyForAccept contentType qt - . limitT range - . orderT (orderParse qq) - . whereT qt qq - $ select qt qq - ) - row <- H.maybeEx query - let (tableTotal, queryTotal, body) = - fromMaybe (Just 0, 0, Just "" :: Maybe Text) row - to = from+queryTotal-1 - contentRange = contentRangeH from to tableTotal - status = rangeStatus from to tableTotal - canonical = urlEncodeVars - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req - return $ responseLBS status - [contentTypeH, contentRange, - ("Content-Location", - "/" <> cs table <> - if Prelude.null canonical then "" else "?" <> cs canonical - ) - ] (cs $ fromMaybe "[]" body) + else cqs + q = B.Stmt "select " V.empty True <> + parentheticT count + <> commaq <> ( + bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables + . limitT range + $ qs + ) + row <- H.maybeEx q + let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe Text) row + to = from+queryTotal-1 + contentRange = contentRangeH from to tableTotal + status = rangeStatus from to tableTotal + canonical = urlEncodeVars + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + return $ responseLBS status + [contentTypeH, contentRange, + ("Content-Location", + "/" <> cs table <> + if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (cs $ fromMaybe "[]" body) + + where + from = fromMaybe 0 $ rangeOffset <$> range + apiRequest = first formatParserError (parseGetRequest req) + >>= first formatRelationError . addRelations schema allRels Nothing + >>= addJoinConditions schema allCols + where + formatRelationError :: Text -> Text + formatRelationError e = cs $ encode $ object [ + "mesage" .= ("could not find foreign keys between these entities"::String), + "details" .= e] + formatParserError :: ParseError -> Text + formatParserError e = cs $ encode $ object [ + "message" .= message, + "details" .= details] + where + message = show (errorPos e) + details = strip $ replace "\n" " " $ cs + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) + + query = requestToQuery schema <$> apiRequest + countQuery = requestToCountQuery schema <$> apiRequest + queries = (,) <$> query <*> countQuery + (["postgrest", "users"], "POST") -> do let user = decode reqBody :: Maybe AuthUser @@ -148,12 +187,12 @@ app conf reqBody req = Right toBeInserted -> do rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - primaryKeys <- primaryKeyColumns qt - let responses = flip map inserted $ \obj -> do + pKeys = map pkName $ filter (filterPk schema table) allPrKeys + responses = flip map inserted $ \obj -> do let primaries = - if Prelude.null primaryKeys + if Prelude.null pKeys then obj - else M.filterWithKey (const . (`elem` primaryKeys)) obj + else M.filterWithKey (const . (`elem` pKeys)) obj let params = urlEncodeVars $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t))) $ sortBy (comparing fst) $ M.toList primaries @@ -182,14 +221,14 @@ app conf reqBody req = ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table - primaryKeys <- primaryKeyColumns qt - let specifiedKeys = map (cs . fst) qq - if S.fromList primaryKeys /= S.fromList specifiedKeys + pKeys = map pkName $ filter (filterPk schema table) allPrKeys + specifiedKeys = map (cs . fst) qq + if S.fromList pKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do - tableCols <- map (cs . colName) <$> columns qt - let cols = map cs $ M.keys obj + let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols + cols = map cs $ M.keys obj if S.fromList tableCols == S.fromList cols then do let vals = M.elems obj @@ -239,6 +278,16 @@ app conf reqBody req = return $ responseLBS status404 [] "" where + allTabs = tables dbstructure + allRels = relations dbstructure + allCols = columns dbstructure + allPrKeys = primaryKeys dbstructure + filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t + filterCol _ _ _ = False + filterPk sc table pk = sc == pkSchema pk && table == pkTable pk + + filterTableAcl :: Text -> Table -> Bool + filterTableAcl r (Table{tableAcl=a}) = r `elem` a path = pathInfo req verb = requestMethod req qq = queryString req @@ -358,7 +407,7 @@ multipart s rs = data TableOptions = TableOptions { tblOptcolumns :: [Column] -, tblOptpkey :: [Text] +, tblOptpkey :: [Text] } instance ToJSON TableOptions where diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 0dfe553e0..2e60448c5 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} module PostgREST.Auth where -import Data.Aeson -import Control.Monad (mzero) -import Control.Applicative -import Crypto.BCrypt -import Data.Text -import Data.Monoid -import Data.Map -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import qualified Web.JWT as JWT -import Data.String.Conversions (cs) -import PostgREST.PgQuery (pgFmtLit) +import Control.Applicative +import Control.Monad (mzero) +import Crypto.BCrypt +import Data.Aeson +import Data.Map +import Data.Monoid +import Data.String.Conversions (cs) +import Data.Text +import qualified Data.Vector as V +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +import PostgREST.PgQuery (pgFmtLit) +import Prelude +import qualified Web.JWT as JWT -import Prelude - -import System.IO.Unsafe +import System.IO.Unsafe data AuthUser = AuthUser { - userId :: String + userId :: String , userPass :: String , userRole :: String } deriving (Show) diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 37c772e37..4e2448149 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,27 +1,28 @@ module PostgREST.Config where -import Network.Wai -import Control.Applicative -import Data.Text (strip) -import qualified Data.CaseInsensitive as CI -import qualified Data.ByteString.Char8 as BS -import Data.String.Conversions (cs) -import Options.Applicative hiding (columns) -import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) -import Prelude + +import Control.Applicative +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.String.Conversions (cs) +import Data.Text (strip) +import Network.Wai +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) +import Options.Applicative hiding (columns) +import Prelude data AppConfig = AppConfig { - configDbName :: String - , configDbPort :: Int - , configDbUser :: String - , configDbPass :: String - , configDbHost :: String + configDbName :: String + , configDbPort :: Int + , configDbUser :: String + , configDbPass :: String + , configDbHost :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - , configV1Schema :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + , configV1Schema :: String , configJwtSecret :: String } @@ -31,7 +32,7 @@ argParser = AppConfig <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database") <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault) <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role") - <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role") + <*> strOption (long "db-pass" <> metavar "PASS" <> help "password for authenticator role") <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault) <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault) diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 176b5a327..9b162c53a 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -1,18 +1,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module PostgREST.Error (PgError, errResponse) where -import qualified Hasql as H -import qualified Hasql.Postgres as P + +import Data.Aeson ((.=)) +import qualified Data.Aeson as JSON +import Data.String.Conversions (cs) +import Data.String.Utils (replace) +import qualified Data.Text as T +import qualified Hasql as H +import qualified Hasql.Postgres as P +import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT -import qualified Data.Aeson as JSON -import qualified Data.Text as T -import Data.Aeson ((.=)) -import Data.String.Conversions (cs) -import Data.String.Utils(replace) -import Network.Wai(Response, responseLBS) -import Network.HTTP.Types.Header +import Network.Wai (Response, responseLBS) type PgError = H.SessionError P.Postgres diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index a0d486c29..bf756e14d 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,33 +1,39 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} module Main where -import Paths_postgrest (version) -import PostgREST.App -import PostgREST.Middleware -import PostgREST.Error(errResponse) +import Paths_postgrest (version) +import PostgREST.PgStructure +import PostgREST.Types +import Network.Wai -import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) -import Data.String.Conversions (cs) -import Network.Wai (strictRequestBody) -import Network.Wai.Handler.Warp hiding (Connection) -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.App +import PostgREST.Error (errResponse) +import PostgREST.Middleware -import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..)) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Functor.Identity +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Version (versionBranch) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import Network.Wai.Handler.Warp hiding (Connection) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Options.Applicative hiding (columns) -import PostgREST.Config (AppConfig(..), argParser) +import System.IO (BufferMode (..), + hSetBuffering, stderr, + stdin, stdout) +import PostgREST.Config (AppConfig (..), + argParser) + +isServerVersionSupported :: H.Session P.Postgres IO Bool isServerVersionSupported = do Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|] - return $ read (cs row) >= 90200 + return $ read (cs row) >= (90200::Integer) main :: IO () main = do @@ -67,17 +73,36 @@ main = do H.poolSettings (fromIntegral $ configPool conf) 30 pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings - resOrError <- H.session pool isServerVersionSupported + supportedOrError <- 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 + ) supportedOrError - runSettings appSettings $ middle $ \req respond -> do + let txSettings = Just (H.ReadCommitted, Just True) + metadata <- H.session pool $ H.tx txSettings $ do + tabs <- allTables + rels <- allRelations + cols <- allColumns rels + keys <- allPrimaryKeys + return (tabs, rels, cols, keys) + + dbstructure <- case metadata of + Left e -> fail $ show e + Right (tabs, rels, cols, keys) -> + return DbStructure { + tables=tabs + , columns=cols + , relations=rels + , primaryKeys=keys + } + + + runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req - resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ - authenticated conf (app conf body) req + resOrError <- liftIO $ H.session pool $ H.tx txSettings $ + authenticated conf (app dbstructure conf body) req either (respond . errResponse) respond resOrError where diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 8fa775f25..b2dfee16a 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,34 +3,38 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid -import Data.Text --- import Data.Pool(withResource, Pool) +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid +import Data.Text +import Data.String.Conversions (cs) +import qualified Hasql as H +import qualified Hasql.Postgres as P -import qualified Hasql as H -import qualified Hasql.Postgres as P -import Data.String.Conversions(cs) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Header (hAccept, hAuthorization, + hLocation) +import Network.HTTP.Types.Status (status301, status400, status401, + status415) +import Network.URI (URI (..), parseURI) +import Network.Wai (Application, Request (..), + Response, isSecure, rawPathInfo, + rawQueryString, requestHeaders, + responseLBS) +import Network.Wai.Middleware.Cors (cors) +import Network.Wai.Middleware.Gzip (def, gzip) +import Network.Wai.Middleware.Static (only, staticPolicy) -import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept) -import Network.HTTP.Types (RequestHeaders) -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 Codec.Binary.Base64.String (decode) +import PostgREST.App (contentTypeForAccept) +import PostgREST.Auth (DbRole, LoginAttempt (..), + setRole, setUserId, signInRole, + signInWithJWT) +import PostgREST.Config (AppConfig (..), corsPolicy) -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 +import Prelude authenticated :: forall s. AppConfig -> - (Request -> H.Tx P.Postgres s Response) -> + (DbRole -> Request -> H.Tx P.Postgres s Response) -> Request -> H.Tx P.Postgres s Response authenticated conf app req = do attempt <- httpRequesterRole (requestHeaders req) @@ -39,8 +43,8 @@ authenticated conf app req = do return $ responseLBS status400 [] "Malformed basic auth header" LoginFailed -> return $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app req - NoCredentials -> if anon /= currentRole then runInRole anon "" else app req + LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req + NoCredentials -> if anon /= currentRole then runInRole anon "" else app currentRole req where jwtSecret = cs $ configJwtSecret conf @@ -62,7 +66,7 @@ authenticated conf app req = do runInRole r uid = do setUserId uid setRole r - app req + app r req redirectInsecure :: Application -> Application diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs new file mode 100644 index 000000000..235962811 --- /dev/null +++ b/src/PostgREST/Parsers.hs @@ -0,0 +1,159 @@ +module PostgREST.Parsers +( parseGetRequest +) +where + +import Control.Applicative hiding ((<$>)) +--lines needed for ghc 7.8 +import Data.Functor ((<$>)) +import Data.Traversable (traverse) + +import Control.Monad (join) +import Data.List (delete, find) +import Data.Maybe +import Data.Monoid +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Tree +import Network.Wai (Request, pathInfo, queryString) +import PostgREST.Types +import Text.ParserCombinators.Parsec hiding (many, (<|>)) +parseGetRequest :: Request -> Either ParseError ApiRequest +parseGetRequest httpRequest = + foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts + where + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr + addOrder (Node r f) o = Node r{order=o} f + flts = mapM pRequestFilter whereFilters + rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head + qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + orderStr = join $ lookup "order" qString + ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr + selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * + whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] + +pRequestSelect :: Text -> Parser ApiRequest +pRequestSelect rootNodeName = do + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree + where + treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest + treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = + case fldForest of + [] -> Node (rNode {fields=fld:fields rNode}) rForest + _ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest) + +pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) +pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) + where + treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k + opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v + path = fst <$> treePath + fld = snd <$> treePath + op = fst <$> opVal + val = snd <$> opVal + +addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest +addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest +addFilter (path, flt) (Node rn forest) = + case targetNode of + Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where maybeNode = find ((name==).mainTable.rootLabel) forst + +ws :: Parser Text +ws = cs <$> many (oneOf " \t") + +lexeme :: Parser a -> Parser a +lexeme p = ws *> p <* ws + +pTreePath :: Parser (Path,Field) +pTreePath = do + p <- pFieldName `sepBy1` pDelimiter + jp <- optionMaybe ( string "->" >> pJsonPath) + let pp = map cs p + jpp = map cs <$> jp + return (init pp, (last pp, jpp)) + where + + +pFieldForest :: Parser [Tree SelectItem] +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') + +pFieldTree :: Parser (Tree SelectItem) +pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) + <|> Node <$> pSelect <*> pure [] + +pStar :: Parser Text +pStar = cs <$> (string "*" *> pure ("*"::String)) + +pFieldName :: Parser Text +pFieldName = cs <$> (many1 (letter <|> digit <|> oneOf "_") + "field name (* or [a..z0..9_])") + +pJsonPathDelimiter :: Parser Text +pJsonPathDelimiter = cs <$> (try (string "->>") <|> string "->") + +pJsonPath :: Parser [Text] +pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter + +pField :: Parser Field +pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJsonPath) + +pSelect :: Parser SelectItem +pSelect = lexeme $ + try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) ) + <|> do + s <- pStar + return ((s, Nothing), Nothing) + +pOperator :: Parser Operator +pOperator = cs <$> ( try (string "lte") -- has to be before lt + <|> try (string "lt") + <|> try (string "eq") + <|> try (string "gte") -- has to be before gh + <|> try (string "gt") + <|> try (string "lt") + <|> try (string "neq") + <|> try (string "like") + <|> try (string "ilike") + <|> try (string "in") + <|> try (string "notin") + <|> try (string "is" ) + <|> try (string "isnot") + <|> try (string "@@") + "operator (eq, gt, ...)" + ) + +pValue :: Parser FValue +pValue = VText <$> (cs <$> many anyChar) + +pDelimiter :: Parser Char +pDelimiter = char '.' "delimiter (.)" + +pOperatiorWithNegation :: Parser Operator +pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*> pOperator) <|> pOperator + +pOpValueExp :: Parser (Operator, FValue) +pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue) + +pOrder :: Parser [OrderTerm] +pOrder = lexeme pOrderTerm `sepBy` char ',' + +pOrderTerm :: Parser OrderTerm +pOrderTerm = + try ( do + c <- pFieldName + _ <- pDelimiter + d <- string "asc" <|> string "desc" + nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) + return $ OrderTerm (cs c) (cs d) (cs <$> nls) + ) + <|> OrderTerm <$> (cs <$> pFieldName) <*> pure "asc" <*> pure Nothing diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 2ef65af21..4fb81dac0 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -1,31 +1,35 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PostgREST.PgQuery where -import PostgREST.RangeQuery -import qualified Hasql as H -import qualified Hasql.Postgres as P -import qualified Hasql.Backend as B +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +import PostgREST.RangeQuery +import PostgREST.Types (OrderTerm (..)) -import qualified Data.Text as T -import qualified Data.HashMap.Strict as H -import Text.Regex.TDFA ( (=~) ) -import qualified Network.HTTP.Types.URI as Net -import qualified Data.ByteString.Char8 as BS -import Data.Monoid -import Data.Vector (empty) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Functor -import Control.Monad (join) -import Data.String.Conversions (cs) -import qualified Data.Aeson as JSON -import qualified Data.List as L -import qualified Data.Vector as V -import Data.Scientific (isInteger, formatScientific, FPFormat(..)) +import Control.Monad (join) +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import Data.Functor +import qualified Data.HashMap.Strict as H +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Scientific (FPFormat (..), formatScientific, + isInteger) +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Vector (empty) +import qualified Data.Vector as V +import qualified Network.HTTP.Types.URI as Net +import Text.Regex.TDFA ((=~)) -import Prelude +import Prelude type PStmt = H.Stmt P.Postgres instance Monoid PStmt where @@ -39,11 +43,6 @@ data QualifiedIdentifier = QualifiedIdentifier { , qiName :: T.Text } deriving (Show) -data OrderTerm = OrderTerm { - otTerm :: T.Text -, otDirection :: BS.ByteString -, otNullOrder :: Maybe BS.ByteString -} limitT :: Maybe NonnegRange -> StatementT limitT r q = @@ -131,36 +130,6 @@ 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 :: QualifiedIdentifier -> PStmt -selectStar t = B.Stmt ("select * from " <> fromQi t) empty True - -select :: QualifiedIdentifier -> Net.Query -> PStmt -select table params = - if L.null cols - then selectStar table - else B.Stmt "select " empty True <> conjunction <> B.Stmt (" from " <> fromQi table ) empty True - where - selectTermTable = selectTerm table - conjunction = mconcat $ L.intersperse commaq (map selectTermTable cols) - columnsParam = fromMaybe "" $ join (lookup "select" params) - cols = filter ((>0) . T.length) $ map T.strip $ T.split (==',') $ cs columnsParam - -selectTerm :: QualifiedIdentifier -> T.Text -> PStmt -selectTerm table col = - case T.splitOn "::" col of - [colName,castTo] -> - B.Stmt ( - "CAST (" <> pgFmtJsonbPath table (cs colName) <> " AS " - <> castToSafe <> " )" <> asT (jsonbPath colName) - ) empty True - where castToSafe = T.filter ( `elem` ['a'..'z'] ) castTo - _ -> B.Stmt (pgFmtJsonbPath table (cs col) <> asT (jsonbPath col)) empty True - where - jsonbPath :: T.Text -> Maybe JsonbPath - jsonbPath c = parseJsonbPath $ cs c - asT (Just (DoubleArrow _ (KeyIdentifier key))) = " AS " <> pgFmtIdent key - asT _ = "" - returningStarT :: StatementT returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } @@ -225,57 +194,45 @@ wherePred table (col, predicate) = 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"]) + sqlValue = pgFmtValue opCode value + op = pgFmtOperator opCode + + +whiteList :: T.Text -> T.Text +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (L.find ((==) . T.toLower $ val) ["null","true","false"]) + +pgFmtValue :: T.Text -> T.Text -> T.Text +pgFmtValue opCode value = + case opCode of + "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 + where star c = if c == '*' then '%' else c unknownLiteral = (<> "::unknown ") . pgFmtLit - sqlValue = case opCode of - "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 - - op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - "like"-> "like" - "ilike"-> "ilike" - "in" -> "in" - "notin" -> "not in" - "is" -> "is" - "isnot" -> "is not" - "@@" -> "@@" - _ -> "=" - -orderParse :: Net.Query -> [OrderTerm] -orderParse q = - mapMaybe orderParseTerm . T.split (==',') $ cs order - where - order = fromMaybe "" $ join (lookup "order" q) - -orderParseTerm :: T.Text -> Maybe OrderTerm -orderParseTerm s = - case T.split (=='.') s of - (c:d:nls) -> - if d `elem` ["asc", "desc"] - then Just $ OrderTerm c - ( if d == "asc" then "asc" else "desc" ) - ( case nls of - [n] -> if | n == "nullsfirst" -> Just "nulls first" - | n == "nullslast" -> Just "nulls last" - | otherwise -> Nothing - _ -> Nothing - ) - else Nothing - _ -> Nothing +pgFmtOperator :: T.Text -> T.Text +pgFmtOperator opCode = + case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + "like"-> "like" + "ilike"-> "ilike" + "in" -> "in" + "notin" -> "not in" + "is" -> "is" + "isnot" -> "is not" + "@@" -> "@@" + _ -> "=" commaq :: PStmt commaq = B.Stmt ", " empty True diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 9e5647b8a..8ed08873b 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,126 +1,24 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, - MultiParamTypeClasses, ScopedTypeVariables, - FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module PostgREST.PgStructure where -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, isJust) -import Control.Applicative +import Control.Applicative +import Data.Functor.Identity +import Data.List (find) +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Monoid +import Data.Text (Text, split) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import PostgREST.PgQuery () +import PostgREST.Types -import qualified Data.Map as Map +import GHC.Exts (groupWith) +import Prelude -import qualified Hasql as H -import qualified Hasql.Postgres as P - -import Prelude - -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, - ccu.column_name AS foreign_column_name - from information_schema.table_constraints AS tc - join information_schema.key_column_usage AS kcu - on tc.constraint_name = kcu.constraint_name - join information_schema.constraint_column_usage AS ccu - on ccu.constraint_name = tc.constraint_name - where constraint_type = 'FOREIGN KEY' - and tc.table_name=? and tc.table_schema = ? - order by kcu.column_name - |] (qiName table) (qiSchema table) - - return $ foldl addKey Map.empty r - where - addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey - addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m - - -tables :: Text -> H.Tx P.Postgres s [Table] -tables schema = do - rows <- H.listEx $ - [H.stmt| - 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 :: 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::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, - array_to_string(enum_info.vals, ',') as enum - from ( - select table_schema, table_name, column_name, ordinal_position, - is_nullable, data_type, is_updatable, - character_maximum_length, numeric_precision, - column_default, udt_name - from information_schema.columns - where table_schema = ? and table_name = ? - ) as info - left outer join ( - select n.nspname as s, - t.typname as n, - array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals - from pg_type t - join pg_enum e on t.oid = e.enumtypid - join pg_catalog.pg_namespace n ON n.oid = t.typnamespace - group by s, n - ) as enum_info - on (info.udt_name = enum_info.n) - order by position |] - (qiSchema table) (qiName table) - - fks <- foreignKeys table - return $ map (addFK fks . columnFromRow) cols - - where - addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } - - -primaryKeyColumns :: QualifiedIdentifier -> H.Tx P.Postgres s [Text] -primaryKeyColumns table = do - r <- H.listEx $ [H.stmt| - select kc.column_name - from - information_schema.table_constraints tc, - information_schema.key_column_usage kc - where - tc.constraint_type = 'PRIMARY KEY' - 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 = ? |] (qiSchema table) (qiName table) - return $ map runIdentity r doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool doesProcExist schema proc = do @@ -134,33 +32,12 @@ doesProcExist schema proc = do |] schema proc return $ isJust row -data Table = Table { - tableSchema :: Text -, tableName :: Text -, tableInsertable :: Bool -} deriving (Show) -data ForeignKey = ForeignKey { - fkTable::Text, fkCol::Text -} deriving (Eq, Show) - -data Column = Column { - colSchema :: Text -, colTable :: Text -, colName :: Text -, colPosition :: Int -, colNullable :: Bool -, colType :: Text -, colUpdatable :: Bool -, colMaxLen :: Maybe Int -, colPrecision :: Maybe Int -, colDefault :: Maybe Text -, colEnum :: [Text] -, colFK :: Maybe ForeignKey -} deriving (Show) - -tableFromRow :: (Text, Text, Bool) -> Table -tableFromRow (s, n, i) = Table s n i +tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table +tableFromRow (s, n, i, a) = Table s n i (parseAcl a) + where + parseAcl :: Maybe Text -> [Text] + parseAcl str = fromMaybe [] $ split (==',') <$> str columnFromRow :: (Text, Text, Text, Int, Bool, Text, @@ -175,25 +52,190 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = parseEnum str = fromMaybe [] $ split (==',') <$> str -instance ToJSON Column where - toJSON c = object [ - "schema" .= colSchema c - , "name" .= colName c - , "position" .= colPosition c - , "nullable" .= colNullable c - , "type" .= colType c - , "updatable" .= colUpdatable c - , "maxLen" .= colMaxLen c - , "precision" .= colPrecision c - , "references".= colFK c - , "default" .= colDefault c - , "enum" .= colEnum c ] +relationFromRow :: (Text, Text, Text, Text, Text) -> Relation +relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc Child Nothing Nothing Nothing -instance ToJSON ForeignKey where - toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] +pkFromRow :: (Text, Text, Text) -> PrimaryKey +pkFromRow (s, t, n) = PrimaryKey s t n -instance ToJSON Table where - toJSON v = object [ - "schema" .= tableSchema v - , "name" .= tableName v - , "insertable" .= tableInsertable v ] + +addParentRelation :: Relation -> [Relation] -> [Relation] +addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels + +allTables :: H.Tx P.Postgres s [Table] +allTables = do + rows <- H.listEx $ [H.stmt| + SELECT + n.nspname AS table_schema, + c.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, + array_to_string(array_agg(r.rolname), ',') AS acl + FROM pg_class c + CROSS JOIN pg_roles r + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE c.relkind IN ('v','r','m') + AND n.nspname NOT IN ('pg_catalog', 'information_schema') + AND ( + pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR + has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR + has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) ) + + GROUP BY table_schema, table_name, insertable + ORDER BY table_schema, table_name + |] + return $ map tableFromRow rows + +allRelations :: H.Tx P.Postgres s [Relation] +allRelations = do + rels <- H.listEx $ [H.stmt| + WITH table_fk AS ( + SELECT + tc.table_schema, tc.table_name, kcu.column_name, + ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + FROM information_schema.table_constraints AS tc + JOIN information_schema.key_column_usage AS kcu on tc.constraint_name = kcu.constraint_name + JOIN information_schema.constraint_column_usage AS ccu on ccu.constraint_name = tc.constraint_name + WHERE constraint_type = 'FOREIGN KEY' + AND tc.table_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY tc.table_schema, tc.table_name, kcu.column_name + ) + SELECT * FROM table_fk + UNION + ( + SELECT + vcu.table_schema, vcu.view_name AS table_name, vcu.column_name, + table_fk.foreign_table_name, + table_fk.foreign_column_name + FROM information_schema.view_column_usage as vcu + JOIN table_fk ON + table_fk.table_schema = vcu.view_schema AND + table_fk.table_name = vcu.table_name AND + table_fk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name + ) + UNION + ( + SELECT + vcu.view_schema as table_schema, + table_fk.table_name, + table_fk.column_name, + vcu.view_name as foreign_table_name, + vcu.column_name as foreign_column_name + FROM information_schema.view_column_usage as vcu + JOIN table_fk ON + table_fk.table_schema = vcu.view_schema AND + table_fk.foreign_table_name = vcu.table_name AND + table_fk.foreign_column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name + ) + |] + let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels + let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations + return $ simpleRelations ++ mapMaybe link2Relation links + where + groupFn :: Relation -> Text + groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t + link2Relation [ + Relation{relSchema=sc, relTable=lt, relColumn=lc1, relFTable=t, relFColumn=c}, + Relation{ relColumn=lc2, relFTable=ft, relFColumn=fc} + ] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2) + link2Relation _ = Nothing + +allColumns :: [Relation] -> H.Tx P.Postgres s [Column] +allColumns rels = 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::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, + array_to_string(enum_info.vals, ',') AS enum + FROM ( + SELECT + table_schema, + table_name, + column_name, + ordinal_position, + is_nullable, + data_type, + is_updatable, + character_maximum_length, + numeric_precision, + column_default, + udt_name + FROM information_schema.columns + WHERE table_schema NOT IN ('pg_catalog', 'information_schema') + ) AS info + LEFT OUTER JOIN ( + SELECT + n.nspname AS s, + t.typname AS n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals + FROM pg_type t + JOIN pg_enum e ON t.oid = e.enumtypid + JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace + GROUP BY s,n + ) AS enum_info ON (info.udt_name = enum_info.n) + ORDER BY schema, position + |] + return $ map (addFK . columnFromRow) cols + + where + addFK col = col { colFK = relToFk <$> find (lookupFn col) rels } + lookupFn :: Column -> Relation -> Bool + lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) = + cs==rs && ct==rt && cn==rc && rty==Child + lookupFn _ _ = False + relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c + +allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey] +allPrimaryKeys = do + pks <- H.listEx $ [H.stmt| + WITH table_pk AS ( + SELECT + kc.table_schema, + kc.table_name, + kc.column_name + FROM + information_schema.table_constraints tc, + information_schema.key_column_usage kc + WHERE + tc.constraint_type = 'PRIMARY KEY' 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 NOT IN ('pg_catalog', 'information_schema') + ) + SELECT table_schema, + table_name, + column_name + FROM table_pk + UNION ( + SELECT + vcu.view_schema, + vcu.view_name, + vcu.column_name + FROM information_schema.view_column_usage AS vcu + JOIN + table_pk ON table_pk.table_schema = vcu.view_schema AND + table_pk.table_name = vcu.table_name AND + table_pk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema') + ) + |] + return $ map pkFromRow pks diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs new file mode 100644 index 000000000..95243800a --- /dev/null +++ b/src/PostgREST/QueryBuilder.hs @@ -0,0 +1,164 @@ +module PostgREST.QueryBuilder +where + + +import Control.Error +import Data.List (find) +import Data.Monoid +import Data.Text hiding (filter, find, foldr, head, last, map, + null) +import Control.Applicative +import Data.Tree +import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, + orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, + pgFmtValue, whiteList) +import PostgREST.Types +import qualified Data.Vector as V (empty) +import qualified Hasql.Backend as B + +findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation +findRelation allRelations s t1 t2 = + find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations + +addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest +addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) = + case parentNode of + Nothing -> Node query{relation=Nothing} <$> updatedForest + (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + where + rel = note ("no relation between " <> table <> " and " <> parentTable) + $ findRelation allRelations schema table parentTable + <|> findRelation allRelations schema parentTable table + addRel :: Query -> Relation -> Query + addRel q r = q{relation = Just r} + where + updatedForest = mapM (addRelations schema allRelations (Just node)) forest + +addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest +addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = + case r of + Nothing -> Node updatedQuery <$> updatedForest -- this is the root node + Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest + Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest + Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) -> + Node <$> pure qq <*> updatedForest + where + q = addCond updatedQuery (getJoinConditions rel) + qq = q{joinTables=linkTable:joinTables q} + _ -> Left "unknow relation" + where + -- add parentTable and parentJoinConditions to the query + updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions + where + parentJoinConditions = map (getJoinConditions.snd) parents + parentTables = map fst parents + parents = mapMaybe (getParents.rootLabel) forest + getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel) + getParents _ = Nothing + updatedForest = mapM (addJoinConditions schema allColumns) forest + getJoinConditions :: Relation -> [Filter] + getJoinConditions rel@(Relation _ _ c _ _ Child _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions rel@(Relation _ _ c _ _ Parent _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions (Relation s t c ft fc Many (Just lt) (Just lc1) (Just lc2)) = + [ + Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 Child Nothing Nothing Nothing)), + Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 Child Nothing Nothing Nothing)) + ] + getJoinConditions _ = [] + addCond q con = q{filters=con ++ filters q} + +requestToCountQuery :: Text -> ApiRequest -> PStmt +requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) = + B.Stmt query V.empty True + where + query = Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", fromQi $ QualifiedIdentifier schema mainTbl, + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions + ] + emptyOnNull val x = if null x then "" else val + localConditions = filter fn conditions + where + fn (Filter{value=VText _}) = True + fn (Filter{value=VForeignKey _}) = False + +requestToQuery :: Text -> ApiRequest -> PStmt +requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) = + orderT (fromMaybe [] ord) query + where + query = B.Stmt qStr V.empty True + qStr = Data.Text.unwords [ + ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects), + "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)), + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + (withs, selects) = foldr getQueryParts ([],[]) forest + getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s) + where + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " + <> "FROM (" <> subquery <> ") " <> table + <> ") AS " <> table + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) + + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s) + where + sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular + wit = table <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) + + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s) + where + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " + <> "FROM (" <> subquery <> ") " <> table + <> ") AS " <> table + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) + + -- the following is just to remove the warning + --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only + --posible relations are Child Parent Many + getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined + +pgFmtCondition :: QualifiedIdentifier -> Filter -> Text +pgFmtCondition table (Filter (col,jp) ops val) = + notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <> + if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue + where + headPredicate:rest = split (=='.') ops + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + sqlCol = case val of + VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp + VForeignKey (Relation s t c _ _ _ _ _ _) -> pgFmtColumn (QualifiedIdentifier s t) c + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" + valToStr v = case v of + VText s -> pgFmtValue opCode s + VForeignKey (Relation{relSchema=s, relFTable=ft, relFColumn=fc}) -> pgFmtColumn (QualifiedIdentifier s ft) fc + +pgFmtColumn :: QualifiedIdentifier -> Text -> Text +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c + +pgFmtJsonPath :: Maybe JsonPath -> Text +pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x +pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) +pgFmtJsonPath _ = "" + +pgFmtTable :: Table -> Text +pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n + +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text +pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp +pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp + +asJsonPath :: Maybe JsonPath -> Text +asJsonPath Nothing = "" +asJsonPath (Just xx) = " AS " <> last xx diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index a138d9559..ff9997378 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,21 +6,22 @@ module PostgREST.RangeQuery ( , NonnegRange ) where -import Control.Applicative -import Network.HTTP.Types.Header -import qualified Data.ByteString.Char8 as BS +import Control.Applicative +import Network.HTTP.Types.Header +import PostgREST.Types () -import Data.Ranged.Boundaries -import Data.Ranged.Ranges +import qualified Data.ByteString.Char8 as BS +import Data.Ranged.Boundaries +import Data.Ranged.Ranges -import Data.String.Conversions (cs) -import Text.Regex.TDFA ((=~)) -import Text.Read (readMaybe) +import Data.String.Conversions (cs) +import Text.Read (readMaybe) +import Text.Regex.TDFA ((=~)) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) -import Prelude +import Prelude type NonnegRange = Range Int diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs new file mode 100644 index 000000000..164f2d7a4 --- /dev/null +++ b/src/PostgREST/Types.hs @@ -0,0 +1,107 @@ +module PostgREST.Types where +import Data.Text +import Data.Tree +import qualified Data.ByteString.Char8 as BS +import Data.Aeson + +data DbStructure = DbStructure { + tables :: [Table] +, columns :: [Column] +, relations :: [Relation] +, primaryKeys :: [PrimaryKey] +} + + +data Table = Table { + tableSchema :: Text +, tableName :: Text +, tableInsertable :: Bool +, tableAcl :: [Text] +} deriving (Show) + +data ForeignKey = ForeignKey { + fkTable::Text, fkCol::Text +} deriving (Show) + + +data Column = Column { + colSchema :: Text +, colTable :: Text +, colName :: Text +, colPosition :: Int +, colNullable :: Bool +, colType :: Text +, colUpdatable :: Bool +, colMaxLen :: Maybe Int +, colPrecision :: Maybe Int +, colDefault :: Maybe Text +, colEnum :: [Text] +, colFK :: Maybe ForeignKey +} | Star {colSchema :: Text, colTable :: Text } deriving (Show) + +data PrimaryKey = PrimaryKey { + pkSchema::Text, pkTable::Text, pkName::Text +} + +data OrderTerm = OrderTerm { + otTerm :: Text +, otDirection :: BS.ByteString +, otNullOrder :: Maybe BS.ByteString +} deriving (Show, Eq) + +data RelationType = Child | Parent | Many deriving (Show, Eq) +data Relation = Relation { + relSchema :: Text +, relTable :: Text +, relColumn :: Text +, relFTable :: Text +, relFColumn :: Text +, relType :: RelationType +, relLTable :: Maybe Text +, relLCol1 :: Maybe Text +, relLCol2 :: Maybe Text +} deriving (Show, Eq) + + +type Operator = Text +data FValue = VText Text | VForeignKey Relation deriving (Show, Eq) +type FieldName = Text +type JsonPath = [Text] +type Field = (FieldName, Maybe JsonPath) +type Cast = Text +type SelectItem = (Field, Maybe Cast) +type Path = [Text] +data Query = Select { + mainTable::Text +, fields::[SelectItem] +, joinTables::[Text] +, filters::[Filter] +, order::Maybe [OrderTerm] +, relation::Maybe Relation +} deriving (Show, Eq) +data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) +type ApiRequest = Tree Query + + +instance ToJSON Column where + toJSON c = object [ + "schema" .= colSchema c + , "name" .= colName c + , "position" .= colPosition c + , "nullable" .= colNullable c + , "type" .= colType c + , "updatable" .= colUpdatable c + , "maxLen" .= colMaxLen c + , "precision" .= colPrecision c + , "references".= colFK c + , "default" .= colDefault c + , "enum" .= colEnum c ] + +instance ToJSON ForeignKey where + toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] + +instance ToJSON Table where + toJSON v = object [ + "schema" .= tableSchema v + , "name" .= tableName v + , "insertable" .= tableInsertable v ] diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 5487fb09b..df100c8c8 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -1,6 +1,6 @@ module Feature.QuerySpec where -import Test.Hspec +import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types @@ -130,6 +130,10 @@ spec = get "/items?always_true=eq.true" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] + it "matches filtering nested items" $ + get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` + "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1,\"name\":\"Design w7\"}]},{\"id\":2,\"tasks\":[{\"id\":3,\"name\":\"Design w10\"}]}]},{\"id\":2,\"projects\":[{\"id\":3,\"tasks\":[{\"id\":5,\"name\":\"Design IOS\"}]},{\"id\":4,\"tasks\":[{\"id\":7,\"name\":\"Design OSX\"}]}]}]" + describe "Shaping response with select parameter" $ do it "selectStar works in absense of parameter" $ @@ -178,6 +182,27 @@ spec = get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith` [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now + it "requesting parents and children" $ + get "/projects?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" + + it "requesting children 2 levels" $ + get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith` + "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1},{\"id\":2}]},{\"id\":2,\"tasks\":[{\"id\":3},{\"id\":4}]}]}]" + + it "requesting many<->many relation" $ + get "/tasks?select=id,users(id)" `shouldRespondWith` + "[{\"id\":1,\"users\":[{\"id\":1},{\"id\":3}]},{\"id\":2,\"users\":[{\"id\":1}]},{\"id\":3,\"users\":[{\"id\":1}]},{\"id\":4,\"users\":[{\"id\":1}]},{\"id\":5,\"users\":[{\"id\":2},{\"id\":3}]},{\"id\":6,\"users\":[{\"id\":2}]},{\"id\":7,\"users\":[{\"id\":2}]},{\"id\":8,\"users\":null}]" + + it "requesting parents and children on views" $ + get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" + + it "requesting children with composite key" $ do + pendingWith "have to resolve issue #302" + get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` + [json| [{"user_id":2,"task_id":6,"comments":[{"content": "Needs to be delivered ASAP"}]}] |] + describe "ordering response" $ do it "by a column asc" $ @@ -226,7 +251,7 @@ spec = } it "without other constraints" $ - get "/items?order=asc.id" `shouldRespondWith` 200 + get "/items?order=id.asc" `shouldRespondWith` 200 describe "Accept headers" $ do it "should respond an unknown accept type with 415" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index f63628e8a..d68db8440 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -15,6 +15,8 @@ spec = around withApp $ do request methodGet "/" [] "" `shouldRespondWith` [json| [ {"schema":"1","name":"auto_incrementing_pk","insertable":true} + , {"schema":"1","name":"clients","insertable":true} + , {"schema":"1","name":"comments","insertable":true} , {"schema":"1","name":"complex_items","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} , {"schema":"1","name":"has_count_column","insertable":false} @@ -26,8 +28,14 @@ spec = around withApp $ do , {"schema":"1","name":"menagerie","insertable":true} , {"schema":"1","name":"no_pk","insertable":true} , {"schema":"1","name":"nullable_integer","insertable":true} + , {"schema":"1","name":"projects","insertable":true} + , {"schema":"1","name":"projects_view","insertable":true} , {"schema":"1","name":"simple_pk","insertable":true} + , {"schema":"1","name":"tasks","insertable":true} , {"schema":"1","name":"tsearch","insertable":true} + , {"schema":"1","name":"users","insertable":true} + , {"schema":"1","name":"users_projects","insertable":true} + , {"schema":"1","name":"users_tasks","insertable":true} ] |] {matchStatus = 200} @@ -145,6 +153,102 @@ spec = around withApp $ do } |] + it "it includes primary and foreign keys for views" $ + request methodOptions "/insertable_view_with_join" [] "" `shouldRespondWith` + [json| + { + "pkey":[ + "id" + ], + "columns":[ + { + "references":null, + "default":null, + "precision":64, + "updatable":false, + "schema":"1", + "name":"id", + "type":"bigint", + "maxLen":null, + "enum":[], + "nullable":true, + "position":1 + }, + { + "references":{ + "column":"id", + "table":"auto_incrementing_pk" + }, + "default":null, + "precision":32, + "updatable":false, + "schema":"1", + "name":"auto_inc_fk", + "type":"integer", + "maxLen":null, + "enum":[], + "nullable":true, + "position":2 + }, + { + "references":{ + "column":"k", + "table":"simple_pk" + }, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"simple_fk", + "type":"character varying", + "maxLen":255, + "enum":[], + "nullable":true, + "position":3 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"nullable_string", + "type":"character varying", + "maxLen":null, + "enum":[], + "nullable":true, + "position":4 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"non_nullable_string", + "type":"character varying", + "maxLen":null, + "enum":[], + "nullable":true, + "position":5 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"inserted_at", + "type":"timestamp with time zone", + "maxLen":null, + "enum":[], + "nullable":true, + "position":6 + } + ] + } + |] + it "includes foreign key data" $ do pendingWith "have to resolve issue #107" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index f198cf7dc..f47f23b6d 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -30,6 +30,8 @@ import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(errResponse) +import PostgREST.PgStructure +import PostgREST.Types isLeft :: Either a b -> Bool isLeft (Left _ ) = True @@ -53,10 +55,28 @@ withApp perform = do pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts + let txSettings = Just (H.ReadCommitted, Just True) + metadata <- H.session pool $ H.tx txSettings $ do + tabs <- allTables + rels <- allRelations + cols <- allColumns rels + keys <- allPrimaryKeys + return (tabs, rels, cols, keys) + + dbstructure <- case metadata of + Left e -> fail $ show e + Right (tabs, rels, cols, keys) -> + return $ DbStructure { + tables=tabs + , columns=cols + , relations=rels + , primaryKeys=keys + } + perform $ middle $ \req resp -> do body <- strictRequestBody req - result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) - $ authenticated cfg (app cfg body) req + result <- liftIO $ H.session pool $ H.tx txSettings + $ authenticated cfg (app dbstructure cfg body) req either (resp . errResponse) resp result where middle = defaultMiddle False diff --git a/test/fixtures/schema.sql b/test/fixtures/schema.sql index 0f5cb5068..d66ce05a4 100755 --- a/test/fixtures/schema.sql +++ b/test/fixtures/schema.sql @@ -210,6 +210,73 @@ CREATE TABLE complex_items ( ALTER TABLE "1".complex_items OWNER TO postgrest_test; +--- Structure for testing table relations +CREATE TABLE clients( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL +); +ALTER TABLE "1".clients OWNER TO postgrest_test; + +CREATE TABLE projects( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL, + client_id INT REFERENCES clients(id) +); +ALTER TABLE "1".projects OWNER TO postgrest_test; + +CREATE TABLE tasks( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL, + project_id INT REFERENCES projects(id) +); +ALTER TABLE "1".tasks OWNER TO postgrest_test; + +CREATE TABLE users( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL +); +ALTER TABLE "1".users OWNER TO postgrest_test; + +CREATE TABLE users_tasks( + user_id INT REFERENCES users(id), + task_id INT REFERENCES tasks(id), + CONSTRAINT task_user PRIMARY KEY (task_id,user_id) +); +ALTER TABLE "1".users_tasks OWNER TO postgrest_test; + +CREATE TABLE comments( +id INT PRIMARY KEY NOT NULL, +commenter_id INT NOT NULL REFERENCES users(id), +user_id INT NOT NULL, +task_id INT NOT NULL, +content TEXT NOT NULL, +FOREIGN KEY (task_id,user_id) REFERENCES users_tasks (task_id,user_id) +); +ALTER TABLE "1".comments OWNER TO postgrest_test; + +CREATE TABLE users_projects( + user_id INT REFERENCES users(id), + project_id INT REFERENCES projects(id), + CONSTRAINT project_user PRIMARY KEY (project_id, user_id) +); +ALTER TABLE "1".users_projects OWNER TO postgrest_test; + +CREATE VIEW "1".projects_view AS + SELECT + projects.id, + projects.name, + projects.client_id + FROM projects; +ALTER TABLE "1".projects_view OWNER TO postgrest_test; +------- SAMPLE DATA ----- +INSERT INTO clients VALUES (1, 'Microsoft'),(2, 'Apple'); +INSERT INTO projects VALUES (1,'Windows 7', 1),(2,'Windows 10', 1),(3,'IOS', 2),(4,'OSX', 2); +INSERT INTO tasks VALUES (1,'Design w7',1),(2,'Code w7',1),(3,'Design w10',2),(4,'Code w10',2),(5,'Design IOS',3),(6,'Code IOS',3),(7,'Design OSX',4),(8,'Code OSX',4); +INSERT INTO users VALUES (1, 'Angela Martin'),(2, 'Michael Scott'),(3, 'Dwight Schrute'); +INSERT INTO users_projects VALUES(1,1),(1,2),(2,3),(2,4),(3,1),(3,3); +INSERT INTO users_tasks VALUES(1,1),(1,2),(1,3),(1,4),(2,5),(2,6),(2,7),(3,1),(3,5); +INSERT INTO comments VALUES (1, 1, 2, 6, 'Needs to be delivered ASAP'); +---------------- CREATE SEQUENCE items_id_seq START WITH 1 @@ -555,6 +622,41 @@ REVOKE ALL ON TABLE complex_items FROM postgrest_test; GRANT ALL ON TABLE complex_items TO postgrest_test; GRANT ALL ON TABLE complex_items TO postgrest_anonymous; +--------- +REVOKE ALL ON TABLE clients FROM PUBLIC; +REVOKE ALL ON TABLE clients FROM postgrest_test; +GRANT ALL ON TABLE clients TO postgrest_test; +GRANT ALL ON TABLE clients TO postgrest_anonymous; +REVOKE ALL ON TABLE projects FROM PUBLIC; +REVOKE ALL ON TABLE projects FROM postgrest_test; +GRANT ALL ON TABLE projects TO postgrest_test; +GRANT ALL ON TABLE projects TO postgrest_anonymous; +REVOKE ALL ON TABLE tasks FROM PUBLIC; +REVOKE ALL ON TABLE tasks FROM postgrest_test; +GRANT ALL ON TABLE tasks TO postgrest_test; +GRANT ALL ON TABLE tasks TO postgrest_anonymous; +REVOKE ALL ON TABLE users FROM PUBLIC; +REVOKE ALL ON TABLE users FROM postgrest_test; +GRANT ALL ON TABLE users TO postgrest_test; +GRANT ALL ON TABLE users TO postgrest_anonymous; +REVOKE ALL ON TABLE users_tasks FROM PUBLIC; +REVOKE ALL ON TABLE users_tasks FROM postgrest_test; +GRANT ALL ON TABLE users_tasks TO postgrest_test; +GRANT ALL ON TABLE users_tasks TO postgrest_anonymous; +REVOKE ALL ON TABLE comments FROM PUBLIC; +REVOKE ALL ON TABLE comments FROM postgrest_test; +GRANT ALL ON TABLE comments TO postgrest_test; +GRANT ALL ON TABLE comments TO postgrest_anonymous; +REVOKE ALL ON TABLE users_projects FROM PUBLIC; +REVOKE ALL ON TABLE users_projects FROM postgrest_test; +GRANT ALL ON TABLE users_projects TO postgrest_test; +GRANT ALL ON TABLE users_projects TO postgrest_anonymous; +REVOKE ALL ON TABLE projects_view FROM PUBLIC; +REVOKE ALL ON TABLE projects_view FROM postgrest_test; +GRANT ALL ON TABLE projects_view TO postgrest_test; +GRANT ALL ON TABLE projects_view TO postgrest_anonymous; +--------- + REVOKE ALL ON FUNCTION getitemrange(bigint, bigint) FROM PUBLIC; REVOKE ALL ON FUNCTION getitemrange(bigint, bigint) FROM postgrest_test;