postgrest 0.2.11.1 → 0.2.12.0
raw patch · 14 files changed
+1210/−548 lines, 14 filesdep +bifunctorsdep +errorsdep +parsecdep ~optparse-applicative
Dependencies added: bifunctors, errors, parsec
Dependency ranges changed: optparse-applicative
Files
- postgrest.cabal +20/−2
- src/PostgREST/App.hs +178/−124
- src/PostgREST/Auth.hs +33/−30
- src/PostgREST/Config.hs +68/−24
- src/PostgREST/Error.hs +12/−10
- src/PostgREST/Main.hs +57/−41
- src/PostgREST/Middleware.hs +39/−35
- src/PostgREST/Parsers.hs +159/−0
- src/PostgREST/PgQuery.hs +84/−100
- src/PostgREST/PgStructure.hs +230/−164
- src/PostgREST/QueryBuilder.hs +165/−0
- src/PostgREST/RangeQuery.hs +17/−16
- src/PostgREST/Types.hs +113/−0
- test/SpecHelper.hs +35/−2
postgrest.cabal view
@@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits.-version: 0.2.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
src/PostgREST/App.hs view
@@ -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
src/PostgREST/Auth.hs view
@@ -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
src/PostgREST/Config.hs view
@@ -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
src/PostgREST/Error.hs view
@@ -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
src/PostgREST/Main.hs view
@@ -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
src/PostgREST/Middleware.hs view
@@ -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
+ src/PostgREST/Parsers.hs view
@@ -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
src/PostgREST/PgQuery.hs view
@@ -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
src/PostgREST/PgStructure.hs view
@@ -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
+ src/PostgREST/QueryBuilder.hs view
@@ -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
src/PostgREST/RangeQuery.hs view
@@ -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 =
+ src/PostgREST/Types.hs view
@@ -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 ]
test/SpecHelper.hs view
@@ -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