diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.11.1 +version: 0.2.12.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -40,7 +40,7 @@ , bytestring, text, split, string-conversions , stringsearch , containers, unordered-containers - , optparse-applicative == 0.11.* + , optparse-applicative >= 0.11 && < 0.13 , regex-base, regex-tdfa , Ranged-sets , transformers, MissingH @@ -52,6 +52,9 @@ , mtl , cassava , jwt + , parsec + , errors + , bifunctors hs-source-dirs: src library @@ -87,7 +90,15 @@ , mtl , cassava , jwt + , parsec + , errors + , bifunctors + + Other-Modules: Paths_postgrest Exposed-Modules: PostgREST.App + , PostgREST.Types + , PostgREST.Parsers + , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -108,6 +119,9 @@ 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 @@ -117,6 +131,7 @@ , PostgREST.RangeQuery , Spec , SpecHelper + , Paths_postgrest Build-Depends: base, hspec == 2.1.*, QuickCheck , hspec-wai, hspec-wai-json , hasql, hasql-backend @@ -147,3 +162,6 @@ , process , heredoc , jwt + , parsec + , errors + , bifunctors diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,98 +1,138 @@ -{-# 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 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, 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 - select = B.Stmt "select " V.empty True <> - parentheticT ( - whereT qt qq $ countRows qt - ) <> commaq <> ( - bodyForAccept contentType qt - . limitT range - . orderT (orderParse qq) - . whereT qt qq - $ selectStar qt + 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 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 BL.ByteString) 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 ) - row <- H.maybeEx select - let (tableTotal, queryTotal, body) = - fromMaybe (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) + ] (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 @@ -101,7 +141,7 @@ encode . object $ [("message", String "Failed to parse user.")] Just u -> do _ <- addUser (cs $ userId u) - (cs $ userPass u) (cs $ userRole u) + (cs $ userPass u) (cs <$> userRole u) return $ responseLBS status201 [ jsonH , (hLocation, "/postgrest/users?id=eq." <> cs (userId u)) @@ -119,8 +159,7 @@ encode . object $ [("message", String "Failed to parse user.")] Just u -> do setRole authenticator - login <- signInRole (cs $ userId u) - (cs $ userPass u) + login <- signInRole (cs $ userId u) (cs $ userPass u) case login of LoginSuccess role uid -> return $ responseLBS status201 [ jsonH ] $ @@ -130,30 +169,30 @@ ([table], "POST") -> do let qt = qualify table - echoRequested = lookupHeader "Prefer" == Just "return=representation" + echoRequested = hasPrefer "return=representation" parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) parsed = if lookupHeader "Content-Type" == Just csvMT - then do - rows <- CSV.decode CSV.NoHeader reqBody - if V.null rows then Left "CSV requires header" - else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) - else eitherDecode reqBody >>= \val -> - case val of - Object obj -> Right . second V.singleton . V.unzip . V.fromList $ - M.toList obj - _ -> Left "Expecting single JSON object or CSV rows" + then do + rows <- CSV.decode CSV.NoHeader reqBody + if V.null rows then Left "CSV requires header" + else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) + else eitherDecode reqBody >>= \val -> + case val of + Object obj -> Right . second V.singleton . V.unzip . V.fromList $ + M.toList obj + _ -> Left "Expecting single JSON object or CSV rows" case parsed of Left err -> return $ responseLBS status400 [] $ encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)] 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,33 +221,33 @@ ([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" + "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 H.unitEx $ iffNotT - (whereT qt qq $ update qt cols vals) - (insertSelect qt cols vals) + (whereT qt qq $ update qt cols vals) + (insertSelect qt cols vals) return $ responseLBS status204 [ jsonH ] "" else return $ if Prelude.null tableCols then responseLBS status404 [] "" else responseLBS status400 [] - "You must specify all columns in PUT request" + "You must specify all columns in PUT request" ([table], "PATCH") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table up = returningStarT - . whereT qt qq - $ update qt (map cs $ M.keys obj) (M.elems obj) + . 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" V.empty True @@ -216,8 +255,8 @@ row <- H.maybeEx patch let (queryTotal, body) = fromMaybe (0 :: Int, Just "" :: Maybe Text) row - r = contentRangeH 0 (queryTotal-1) queryTotal - echoRequested = lookupHeader "Prefer" == Just "return=representation" + r = contentRangeH 0 (queryTotal-1) (Just queryTotal) + echoRequested = hasPrefer "return=representation" s = case () of _ | queryTotal == 0 -> status404 | echoRequested -> status200 | otherwise -> status204 @@ -232,19 +271,30 @@ row <- H.maybeEx del let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row return $ if deletedCount == 0 - then responseLBS status404 [] "" - else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" + then responseLBS status404 [] "" + else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" (_, _) -> 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 qualify = QualifiedIdentifier schema hdrs = requestHeaders req lookupHeader = flip lookup hdrs + hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs accept = lookupHeader hAccept schema = requestedSchema (cs $ configV1Schema conf) accept authenticator = cs $ configDbUser conf @@ -260,30 +310,34 @@ isSqlError :: t isSqlError = undefined -rangeStatus :: Int -> Int -> Int -> Status -rangeStatus from to total +rangeStatus :: Int -> Int -> Maybe Int -> Status +rangeStatus _ _ Nothing = status200 +rangeStatus from to (Just total) | from > total = status416 | (1 + to - from) < total = status206 | otherwise = status200 -contentRangeH :: Int -> Int -> Int -> Header +contentRangeH :: Int -> Int -> Maybe Int -> Header contentRangeH from to total = - ("Content-Range", - if total == 0 || from > total - then "*/" <> cs (show total) - else cs (show from) <> "-" - <> cs (show to) <> "/" - <> cs (show total) - ) + ("Content-Range", cs headerValue) + where + headerValue = rangeString <> "/" <> totalString + rangeString + | totalNotZero && fromInRange = show from <> "-" <> cs (show to) + | otherwise = "*" + totalString = fromMaybe "*" (show <$> total) + totalNotZero = fromMaybe True ((/=) 0 <$> total) + fromInRange = from <= to requestedSchema :: Text -> Maybe BS.ByteString -> Text requestedSchema v1schema accept = case verStr of - Just [[_, ver]] -> if ver == "1" then v1schema else cs ver - _ -> v1schema + Just [[_, ver]] -> if ver == "1" then v1schema else cs ver + _ -> v1schema - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString - verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] + where + verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString + verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] jsonMT :: BS.ByteString @@ -353,7 +407,7 @@ 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 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,36 +1,35 @@ -{-# 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 Prelude +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 Data.Maybe (isNothing) +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 System.IO.Unsafe +import System.IO.Unsafe data AuthUser = AuthUser { - userId :: String + userId :: String , userPass :: String - , userRole :: String + , userRole :: Maybe String } deriving (Show) instance FromJSON AuthUser where parseJSON (Object v) = AuthUser <$> v .: "id" <*> v .: "pass" <*> - v .:? "role" .!= "" + v .:? "role" parseJSON _ = mzero instance ToJSON AuthUser where @@ -56,20 +55,24 @@ 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 local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True -else - resetUserId +setUserId uid = + if uid /= "" + then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True + else resetUserId resetUserId :: H.Tx P.Postgres s () resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|] -addUser :: Text -> Text -> Text -> H.Tx P.Postgres s () -addUser identity pass role = do - let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) +addUser :: Text -> Text -> Maybe Text -> H.Tx P.Postgres s () +addUser identity pass role = H.unitEx $ - [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|] - identity (cs hashed :: Text) role + if isNothing role + then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|] + identity hashedText + else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|] + identity hashedText role + where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) + hashedText = cs hashed :: Text signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt signInRole user pass = do diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,28 +1,50 @@ -module PostgREST.Config where +{-| +Module : PostgREST.Config +Description : Manages PostgREST configuration options. -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 +This module provides a helper function to read the command line arguments using the optparse-applicative +and the AppConfig type to store them. +It also can be used to define other middleware configuration that may be delegated to some sort of +external configuration. +It currently includes a hardcoded CORS policy but this could easly be turned in configurable behaviour if needed. + +Other hardcoded options such as the minimum version number also belong here. +-} +module PostgREST.Config ( prettyVersion + , readOptions + , corsPolicy + , minimumPgVersion + , AppConfig (..) + ) + where + +import Control.Applicative +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (strip) +import Data.Version (versionBranch) +import Network.Wai +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) +import Options.Applicative hiding (columns) +import Paths_postgrest (version) +import Prelude + +-- | Data type to store all command line options 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 } @@ -46,15 +68,16 @@ ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing (Just $ 60*60*24) False False True +-- | CORS policy to be used in by Wai Cors middleware corsPolicy :: Request -> Maybe CorsResourcePolicy corsPolicy req = case lookup "origin" headers of Just origin -> Just defaultCorsPolicy { corsOrigins = Just ([origin], True) , corsRequestHeaders = "Authentication":accHeaders , corsExposedHeaders = Just [ - "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" - , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" - ] + "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" + , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" + ] } Nothing -> Nothing where @@ -62,3 +85,24 @@ accHeaders = case lookup "access-control-request-headers" headers of Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs Nothing -> [] + +-- | User friendly version number +prettyVersion :: String +prettyVersion = intercalate "." $ map show $ versionBranch version + +-- | Function to read and parse options from the command line +readOptions :: IO AppConfig +readOptions = customExecParser parserPrefs opts + where + opts = info (helper <*> argParser) $ + fullDesc + <> progDesc ( + "PostgREST " + <> prettyVersion + <> " / create a REST API to an existing Postgres database" + ) + parserPrefs = prefs showHelpOnError + +-- | Tells the minimum PostgreSQL version required by this version of PostgREST +minimumPgVersion :: Integer +minimumPgVersion = 90300 diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- 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 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,33 +1,38 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} module Main where -import Paths_postgrest (version) -import PostgREST.App -import PostgREST.Middleware -import PostgREST.Error(errResponse) +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.Monoid ((<>)) +import Data.String.Conversions (cs) +import Data.Text (Text) +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 PostgREST.Config (AppConfig(..), argParser) +import System.IO (BufferMode (..), + hSetBuffering, stderr, + stdin, stdout) +import PostgREST.Config (AppConfig (..), + prettyVersion, + readOptions, + minimumPgVersion) + +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) >= minimumPgVersion main :: IO () main = do @@ -35,15 +40,7 @@ hSetBuffering stdin LineBuffering hSetBuffering stderr NoBuffering - let opts = info (helper <*> argParser) $ - fullDesc - <> progDesc ( - "PostgREST " - <> prettyVersion - <> " / create a REST API to an existing Postgres database" - ) - parserPrefs = prefs showHelpOnError - conf <- customExecParser parserPrefs opts + conf <- readOptions let port = configPort conf unless (configSecure conf) $ @@ -64,18 +61,37 @@ 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 + 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 + 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" + ) 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 - prettyVersion = intercalate "." $ map show $ versionBranch version diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- 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 qualified Hasql as H -import qualified Hasql.Postgres as P -import Data.String.Conversions(cs) +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 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 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 PostgREST.Config (AppConfig(..), corsPolicy) -import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) -import PostgREST.App (contentTypeForAccept) -import Codec.Binary.Base64.String (decode) +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 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 @@ 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 @@ runInRole r uid = do setUserId uid setRole r - app req + app r req redirectInsecure :: Application -> Application @@ -78,12 +82,12 @@ if not (isSecure req || isHerokuSecure) then case uriM of - Just uri -> - respond $ responseLBS status301 [ - (hLocation, cs . show $ uri { uriScheme = "https:" }) - ] "" - Nothing -> - respond $ responseLBS status400 [] "SSL is required" + Just uri -> + respond $ responseLBS status301 [ + (hLocation, cs . show $ uri { uriScheme = "https:" }) + ] "" + Nothing -> + respond $ responseLBS status400 [] "SSL is required" else app req respond unsupportedAccept :: Application -> Application @@ -96,6 +100,6 @@ defaultMiddle :: Bool -> Application -> Application defaultMiddle secure = (if secure then redirectInsecure else id) - . gzip def . cors corsPolicy - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - . unsupportedAccept + . gzip def . cors corsPolicy + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + . unsupportedAccept diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs new file mode 100644 --- /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 --- 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 (..), QualifiedIdentifier(..)) -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 @@ -34,17 +38,7 @@ mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt -data QualifiedIdentifier = QualifiedIdentifier { - qiSchema :: T.Text -, 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 = q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True @@ -54,13 +48,13 @@ 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"] ] - wherePredTable = wherePred table - conjunction = mconcat $ L.intersperse andq (map wherePredTable cols) + if L.null cols + then q + else q <> B.Stmt " where " empty True <> conjunction + where + cols = [ col | col <- params, fst col `notElem` ["order","select"] ] + 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) = @@ -74,13 +68,13 @@ then q else q <> B.Stmt " order by " empty True <> clause where - clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> PStmt - queryTerm t = B.Stmt - (" " <> cs (pgFmtIdent $ otTerm t) <> " " - <> cs (otDirection t) <> " " - <> maybe "" cs (otNullOrder t) <> " ") - empty True + clause = mconcat $ L.intersperse commaq (map queryTerm ts) + queryTerm :: OrderTerm -> PStmt + queryTerm t = B.Stmt + (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> cs (otDirection t) <> " " + <> maybe "" cs (otNullOrder t) <> " ") + empty True parentheticT :: StatementT parentheticT s = @@ -101,11 +95,15 @@ countRows :: QualifiedIdentifier -> PStmt countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True +countNone :: PStmt +countNone = B.Stmt "select null" empty True + asCsvWithCount :: QualifiedIdentifier -> StatementT asCsvWithCount table = withCount . asCsv table asCsv :: QualifiedIdentifier -> StatementT -asCsv table s = s { B.stmtTemplate = +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' || " @@ -116,7 +114,8 @@ asJsonWithCount = withCount . asJson asJson :: StatementT -asJson s = s { B.stmtTemplate = +asJson s = s { + B.stmtTemplate = "array_to_json(array_agg(row_to_json(t)))::character varying from (" <> B.stmtTemplate s <> ") t" } @@ -126,9 +125,6 @@ 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 - returningStarT :: StatementT returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } @@ -189,61 +185,49 @@ where 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"]) - star c = if c == '*' then '%' else c - unknownLiteral = (<> "::unknown ") . pgFmtLit + 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) + sqlValue = pgFmtValue opCode value + op = pgFmtOperator opCode - 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" - "@@" -> "@@" - _ -> "=" +whiteList :: T.Text -> T.Text +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (L.find ((==) . T.toLower $ val) ["null","true","false"]) -orderParse :: Net.Query -> [OrderTerm] -orderParse q = - mapMaybe orderParseTerm . T.split (==',') $ cs order +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 - order = fromMaybe "" $ join (lookup "order" q) + star c = if c == '*' then '%' else c + unknownLiteral = (<> "::unknown ") . pgFmtLit -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 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,126 +1,26 @@ -{-# 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 qualified Data.Map as Map - -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 +import Control.Applicative +import Control.Monad (join) +import Data.Functor.Identity +import Data.List (elemIndex, 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 - where - addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } +import GHC.Exts (groupWith) +import Prelude -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 row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt| @@ -133,33 +33,12 @@ |] 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, @@ -174,25 +53,212 @@ 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, cs, ft, fcs) = Relation s t cs ft fcs 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 ns.nspname AS table_schema, + tab.relname AS table_name, + column_info.cols AS columns, + other.relname AS foreign_table_name, + column_info.refs AS foreign_columns + FROM pg_constraint, + LATERAL (SELECT array_agg(cols.attname) AS cols, + array_agg(cols.attnum) AS nums, + array_agg(refs.attname) AS refs + FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k, + LATERAL (SELECT * FROM pg_attribute + WHERE attrelid = conrelid AND attnum = col) + AS cols, + LATERAL (SELECT * FROM pg_attribute + WHERE attrelid = confrelid AND attnum = ref) + AS refs) + AS column_info, + LATERAL (SELECT * FROM pg_namespace + WHERE pg_namespace.oid = connamespace) AS ns, + LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab, + LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other + WHERE confrelid != 0 + ORDER BY (conrelid, column_info.nums) + ) + + SELECT * FROM table_fk + UNION + ( + SELECT + vcu.table_schema, + vcu.view_name AS table_name, + array_agg(vcu.column_name::text) AS columns, + table_fk.foreign_table_name, + table_fk.foreign_columns + 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 + vcu.column_name = ANY (table_fk.columns) + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + AND columns = table_fk.columns + GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns + ) + UNION + ( + SELECT + vcu.view_schema as table_schema, + table_fk.table_name, + table_fk.columns, + vcu.view_name as foreign_table_name, + array_agg(vcu.column_name::text) as foreign_columns + 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 + vcu.column_name = ANY (table_fk.foreign_columns) + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + AND foreign_columns = table_fk.foreign_columns + GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns + ) + |] + 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, relColumns=lc1, relFTable=t, relFColumns=c}, + Relation{ relColumns=lc2, relFTable=ft, relFColumns=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 = fk col } + fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels + lookupFn :: Column -> Relation -> Bool + lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) = + cs==rs && ct==rt && cn `elem` rc && rty==Child + lookupFn _ _ = False + relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c + where + pos = elemIndex cName cs + c = (fcs !!) <$> pos + +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 --- /dev/null +++ b/src/PostgREST/QueryBuilder.hs @@ -0,0 +1,165 @@ +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, zipWith) +import Control.Applicative +import Data.Tree +import PostgREST.PgQuery (PStmt, 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 + +getJoinConditions :: Relation -> [Filter] +getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) = + case typ of + Child -> zipWith (toFilter t ft) cs fcs + Parent -> zipWith (toFilter t ft) cs fcs + Many -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2) + where + toFilter :: Text -> Text -> FieldName -> FieldName -> Filter + toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc)) + +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 + 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 qi _ -> pgFmtColumn qi col + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" + valToStr v = case v of + VText s -> pgFmtValue opCode s + VForeignKey (QualifiedIdentifier s _) (ForeignKey ft 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 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,21 +6,22 @@ , 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 @@ -41,15 +42,15 @@ rangeLimit :: NonnegRange -> Maybe Int rangeLimit range = - case [rangeLower range, rangeUpper range] - of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) - _ -> Nothing + case [rangeLower range, rangeUpper range] of + [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing rangeOffset :: NonnegRange -> Int rangeOffset range = - case rangeLower range - of BoundaryBelow from -> from - _ -> error "range without lower bound" -- should never happen + case rangeLower range of + BoundaryBelow from -> from + _ -> error "range without lower bound" -- should never happen rangeGeq :: Int -> NonnegRange rangeGeq n = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Types.hs @@ -0,0 +1,113 @@ +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, Eq) + + +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 QualifiedIdentifier = QualifiedIdentifier { + qiSchema :: Text +, qiName :: Text +} deriving (Show, Eq) + + +data RelationType = Child | Parent | Many deriving (Show, Eq) +data Relation = Relation { + relSchema :: Text +, relTable :: Text +, relColumns :: [Text] +, relFTable :: Text +, relFColumns :: [Text] +, relType :: RelationType +, relLTable :: Maybe Text +, relLCols1 :: Maybe [Text] +, relLCols2 :: Maybe [Text] +} deriving (Show, Eq) + + +type Operator = Text +data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey 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/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -13,6 +13,7 @@ import Data.Text hiding (map) import qualified Data.Vector as V import Control.Monad (void) +import Control.Applicative import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization, hAccept) @@ -29,6 +30,8 @@ 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 @@ -52,10 +55,28 @@ 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 @@ -117,6 +138,18 @@ where txn = mapM_ H.unitEx stmts stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n] + +createComplexItems :: IO () +createComplexItems = do + pool <- testPool + void . liftIO $ H.session pool $ H.tx Nothing txn + where + txn = mapM_ H.unitEx stmts + stmts = getZipList $ [H.stmt|insert into "1".complex_items (id, name, settings) values (?,?,?)|] + <$> ZipList ([1..3]::[Int]) + <*> ZipList (["One", "Two", "Three"]::[Text]) + <*> ZipList ([jobj,jobj,jobj]) + jobj = (J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]) createNulls :: Int -> IO () createNulls n = do