postgrest 0.3.0.3 → 0.3.0.4
raw patch · 21 files changed
+838/−707 lines, 21 filesdep +contravariantdep +interpolatedstring-perl6dep +resource-pooldep −MissingHdep −hasql-backenddep −hasql-postgresdep ~aesondep ~hasqldep ~warp
Dependencies added: contravariant, interpolatedstring-perl6, resource-pool
Dependencies removed: MissingH, hasql-backend, hasql-postgres, hlint, packdeps, transformers
Dependency ranges changed: aeson, hasql, warp
Files
- postgrest.cabal +16/−33
- src/PostgREST/ApiRequest.hs +18/−11
- src/PostgREST/App.hs +48/−51
- src/PostgREST/Auth.hs +7/−6
- src/PostgREST/Config.hs +5/−6
- src/PostgREST/DbStructure.hs +391/−329
- src/PostgREST/Error.hs +33/−27
- src/PostgREST/Main.hs +41/−34
- src/PostgREST/Middleware.hs +6/−10
- src/PostgREST/QueryBuilder.hs +141/−88
- src/PostgREST/RangeQuery.hs +6/−6
- src/PostgREST/Types.hs +7/−3
- test/Feature/AuthSpec.hs +3/−5
- test/Feature/CorsSpec.hs +3/−5
- test/Feature/DeleteSpec.hs +4/−6
- test/Feature/InsertSpec.hs +29/−8
- test/Feature/QuerySpec.hs +30/−5
- test/Feature/RangeSpec.hs +4/−6
- test/Feature/StructureSpec.hs +7/−5
- test/Main.hs +22/−16
- test/SpecHelper.hs +17/−47
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.3.0.3+version: 0.3.0.4 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -22,44 +22,40 @@ Default: False executable postgrest- if flag(ci)- ghc-options: -Wall -W -Werror- else- ghc-options: -Wall -W -O2- main-is: PostgREST/Main.hs- default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes+ default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase+ ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010- build-depends: aeson >= 0.8+ build-depends: aeson >= 0.8 && < 0.10 , base >= 4.8 && < 5 , bytestring , case-insensitive , cassava , containers+ , contravariant , errors- , hasql >= 0.7.3 && < 0.8- , hasql-backend >= 0.4.1 && < 0.5- , hasql-postgres >= 0.10.4 && < 0.11+ , hasql >= 0.19.3.3 && < 0.20+ , http-types+ , interpolatedstring-perl6 , jwt , optparse-applicative >= 0.11 && < 0.13 , parsec , postgrest , regex-tdfa+ , resource-pool , safe >= 0.3 && < 0.4 , scientific , string-conversions , text , time- , transformers , unordered-containers , vector , wai >= 3.0.1 , wai-cors , wai-extra , wai-middleware-static >= 0.6.0- , warp >= 3.0.2- , HTTP, http-types- , MissingH+ , warp >= 3.1.0+ , HTTP , Ranged-sets if !os(windows) build-depends: unix >= 2.7 && < 3@@ -79,11 +75,6 @@ , PostgREST.Types library- if flag(ci)- ghc-options: -Wall -W -Werror- else- ghc-options: -Wall -W -O2- default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes build-depends: aeson@@ -92,11 +83,11 @@ , case-insensitive , cassava , containers+ , contravariant , errors , hasql- , hasql-backend- , hasql-postgres , http-types+ , interpolatedstring-perl6 , jwt , optparse-applicative , parsec@@ -113,7 +104,6 @@ , wai-extra , wai-middleware-static , HTTP- , MissingH , Ranged-sets Other-Modules: Paths_postgrest@@ -133,12 +123,8 @@ Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010- default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes+ default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase Hs-Source-Dirs: test, src- if flag(ci)- ghc-options: -Wall -W -Werror- else- ghc-options: -Wall -W -O2 Main-Is: Main.hs Other-Modules: Feature.AuthSpec , Feature.CorsSpec@@ -168,19 +154,17 @@ , case-insensitive , cassava , containers+ , contravariant , errors , hasql- , hasql-backend- , hasql-postgres , heredoc- , hlint , hspec == 2.2.* , hspec-wai , hspec-wai-json , http-types+ , interpolatedstring-perl6 , jwt , optparse-applicative- , packdeps , parsec , process , regex-tdfa@@ -196,5 +180,4 @@ , wai-extra , wai-middleware-static , HTTP- , MissingH , Ranged-sets
src/PostgREST/ApiRequest.hs view
@@ -28,9 +28,11 @@ data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke- | ActionUnknown BS.ByteString deriving Eq+ | ActionInappropriate+ deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier+ | TargetProc QualifiedIdentifier | TargetRoot | TargetUnknown [T.Text] -- | How to return the inserted data@@ -77,20 +79,25 @@ -- | Examines HTTP request and translates it into user intent. userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest userApiRequest schema req reqBody =- let action = case method of- "GET" -> ActionRead- "POST" -> if isTargetingProc- then ActionInvoke- else ActionCreate- "PATCH" -> ActionUpdate- "DELETE" -> ActionDelete- "OPTIONS" -> ActionInfo- other -> ActionUnknown other+ let action =+ if isTargetingProc+ then+ if method == "POST"+ then ActionInvoke+ else ActionInappropriate+ else+ case method of+ "GET" -> ActionRead+ "POST" -> ActionCreate+ "PATCH" -> ActionUpdate+ "DELETE" -> ActionDelete+ "OPTIONS" -> ActionInfo+ _ -> ActionInappropriate target = case path of [] -> TargetRoot [table] -> TargetIdent $ QualifiedIdentifier schema table- ["rpc", proc] -> TargetIdent+ ["rpc", proc] -> TargetProc $ QualifiedIdentifier schema proc other -> TargetUnknown other payload = case pickContentType (lookupHeader "content-type") of
src/PostgREST/App.hs view
@@ -10,10 +10,8 @@ import Control.Arrow ((***)) import Control.Monad (join) import Data.Bifunctor (first)-import qualified Data.ByteString.Lazy as BL-import Data.Functor.Identity import Data.List (find, sortBy, delete)-import Data.Maybe (fromMaybe, fromJust, mapMaybe)+import Data.Maybe (isJust, fromMaybe, fromJust, mapMaybe) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import Data.String.Conversions (cs)@@ -33,9 +31,7 @@ import Data.Aeson.Types (emptyArray) 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 qualified Hasql.Session as H import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers@@ -49,8 +45,7 @@ import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) -import PostgREST.QueryBuilder ( asJson- , callProc+import PostgREST.QueryBuilder ( callProc , addJoinConditions , sourceCTEName , requestToQuery@@ -58,11 +53,12 @@ , addRelations , createReadStatement , createWriteStatement+ , ResultsWithCount ) import Prelude -app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response+app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response app dbStructure conf reqBody req = let -- TODO: blow up for Left values (there is a middleware that checks the headers)@@ -82,17 +78,17 @@ if range == emptyRange then return $ errResponse status416 "HTTP Range error" else do- row <- H.maybeEx stm- let (tableTotal, queryTotal, _ , body) = extractQueryResult row+ row <- H.query () stm+ let (tableTotal, queryTotal, _ , body) = row if singular then return $ if queryTotal <= 0 then responseLBS status404 [] ""- else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)+ else responseLBS status200 [contentTypeH] (cs body) else do let frm = rangeOffset range- to = frm+queryTotal-1- contentRange = contentRangeH frm to tableTotal- status = rangeStatus frm to tableTotal+ to = frm + toInteger queryTotal - 1+ contentRange = contentRangeH frm to (toInteger <$> tableTotal)+ status = rangeStatus frm to (toInteger <$> tableTotal) canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? . sortBy (comparing fst) . map (join (***) cs)@@ -104,91 +100,93 @@ "/" <> cs (qiName qi) <> if Prelude.null canonical then "" else "?" <> cs canonical )- ] (fromMaybe "[]" body)+ ] (cs body) (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),- Just payload@(PayloadJSON (UniformObjects rows))) ->+ Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let isSingle = (==1) $ V.length rows let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload- row <- H.maybeEx stm+ row <- H.query uniform stm let (_, _, location, body) = extractQueryResult row return $ responseLBS status201 [ contentTypeH,- (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))+ (hLocation, "/" <> cs table <> "?" <> cs location) ]- $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else ""+ $ if iPreferRepresentation apiRequest == Full then cs body else "" - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON _)) ->+ (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload- row <- H.maybeEx stm+ row <- H.query uniform stm let (_, queryTotal, _, body) = extractQueryResult row- r = contentRangeH 0 (queryTotal-1) (Just queryTotal)+ r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal) s = case () of _ | queryTotal == 0 -> status404 | iPreferRepresentation apiRequest == Full -> status200 | otherwise -> status204 return $ responseLBS s [contentTypeH, r]- $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else ""+ $ if iPreferRepresentation apiRequest == Full then cs body else "" (ActionDelete, TargetIdent qi, Nothing) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do- let fakeload = PayloadJSON $ UniformObjects V.empty+ let emptyUniform = UniformObjects V.empty+ let fakeload = PayloadJSON emptyUniform let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload- row <- H.maybeEx stm+ row <- H.query emptyUniform stm let (_, queryTotal, _, _) = extractQueryResult row return $ if queryTotal == 0 then notFound else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" - (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> do- let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure- pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys- body = encode (TableOptions cols pkeys)- filterCol :: Schema -> TableName -> Column -> Bool- filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb- filterCol _ _ _ = False- return $ responseLBS status200 [jsonH, allOrigins] $ cs body+ (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->+ if isJust $ find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure)+ then let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure+ pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys+ body = encode (TableOptions cols pkeys)+ filterCol :: Schema -> TableName -> Column -> Bool+ filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb+ filterCol _ _ _ = False in+ return $ responseLBS status200 [jsonH, allOrigins] $ cs body+ else+ return notFound - (ActionInvoke, TargetIdent qi,+ (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> do- exists <- doesProcExist qi+ exists <- H.query qi doesProcExist if exists then do let p = V.head payload- call = B.Stmt "select " V.empty True <>- asJson (callProc qi p) jwtSecret = configJwtSecret conf - bodyJson :: Maybe (Identity Value) <- H.maybeEx call- returnJWT <- doesProcReturnJWT qi+ bodyJson <- H.query () (callProc qi p)+ returnJWT <- H.query qi doesProcReturnJWT return $ responseLBS status200 [jsonH]- (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in+ (let body = fromMaybe emptyArray bodyJson in if returnJWT then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" else cs $ encode body) else return notFound (ActionRead, TargetRoot, Nothing) -> do- body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))+ body <- encode <$> H.query schema accessibleTables return $ responseLBS status200 [jsonH] $ cs body - (ActionUnknown _, _, _) -> return notFound-- (_, TargetUnknown _, _) -> return notFound+ (ActionInappropriate, _, _) -> return $ responseLBS status405 [] "" (_, _, Just (PayloadParseError e)) -> return $ responseLBS status400 [jsonH] $ cs (formatGeneralError "Cannot parse request payload" (cs e)) + (_, TargetUnknown _, _) -> return notFound+ (_, _, _) -> return notFound where@@ -206,14 +204,14 @@ readSqlParts = (,) <$> selectQuery <*> countQuery mutateSqlParts = (,) <$> selectQuery <*> mutateQuery -rangeStatus :: Int -> Int -> Maybe Int -> Status+rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200 rangeStatus frm to (Just total) | frm > total = status416 | (1 + to - frm) < total = status206 | otherwise = status200 -contentRangeH :: Int -> Int -> Maybe Int -> Header+contentRangeH :: Integer -> Integer -> Maybe Integer -> Header contentRangeH frm to total = ("Content-Range", cs headerValue) where@@ -298,7 +296,7 @@ cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest-addFilter ([], flt) (Node (q@(Select {flt_=flts}), i) forest) = Node (q {flt_=flt:flts}, i) forest+addFilter ([], flt) (Node (q@Select {flt_=flts}, i) forest) = Node (q {flt_=flt:flts}, i) 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@@ -335,6 +333,5 @@ , "pkey" .= tblOptpkey t ] -extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)- -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)-extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")+extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount+extractQueryResult = fromMaybe (Nothing, 0, "", "")
src/PostgREST/Auth.hs view
@@ -21,6 +21,7 @@ import Control.Monad (join) import Data.Aeson (Value (..), Object) import Data.Aeson.Types (emptyObject, emptyArray)+import qualified Data.ByteString as BS import Data.Vector as V (null, head) import Data.Map as M (fromList, toList) import Data.Monoid ((<>))@@ -38,12 +39,12 @@ this one is mapped to a SET ROLE statement. In case there is any problem decoding the JWT it returns Nothing. -}-claimsToSQL :: JWT.ClaimsMap -> [Text]+claimsToSQL :: JWT.ClaimsMap -> [BS.ByteString] claimsToSQL = map setVar . toList where setVar ("role", String val) = setRole val- setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <>- " = " <> valueToVariable val <> ";"+ setVar (k, val) = "set local postgrest.claims." <> cs (pgFmtIdent k) <>+ " = " <> cs (valueToVariable val) <> ";" valueToVariable = pgFmtLit . unquoted {-|@@ -65,9 +66,9 @@ claim prop = prop . JWT.claims <$> decoded customClaims = claim JWT.unregisteredClaims --- | Receives the name of a role and returns a SET ROLE statement-setRole :: Text -> Text-setRole role = "set local role " <> cs (pgFmtLit role) <> ";"+{-| Receives the name of a role and returns a SET ROLE statement -}+setRole :: Text -> BS.ByteString+setRole r = "set local role " <> cs (pgFmtLit r) <> ";" {-|
src/PostgREST/Config.hs view
@@ -37,21 +37,20 @@ -- | Data type to store all command line options data AppConfig = AppConfig { configDatabase :: String- , configPort :: Int , configAnonRole :: String , configSchema :: String+ , configPort :: Int , configJwtSecret :: Secret , configPool :: Int- , configMaxRows :: Maybe Int+ , configMaxRows :: Maybe Integer } argParser :: Parser AppConfig argParser = AppConfig- <$> argument str (help "database connection string" <> metavar "STRING")-- <*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)- <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE")+ <$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL")+ <*> strOption (long "anonymous" <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE") <*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault)+ <*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault) <*> (secret . cs <$> strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)) <*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)
src/PostgREST/DbStructure.hs view
@@ -10,28 +10,32 @@ , doesProcReturnJWT ) where +import qualified Hasql.Query as H+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD+ import Control.Applicative-import Control.Monad (join)-import Data.Functor.Identity+import Control.Monad (join, replicateM)+import Data.Functor.Contravariant (contramap)+import Text.InterpolatedString.Perl6 (q) import Data.List (elemIndex, find, subsequences, sort, transpose) import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe) import Data.Monoid import Data.Text (Text, split)-import qualified Hasql as H-import qualified Hasql.Postgres as P-import qualified Hasql.Backend as B+import qualified Hasql.Session as H import PostgREST.Types import GHC.Exts (groupWith)+import Data.Int (Int32) import Prelude -getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure+getDbStructure :: Schema -> H.Session DbStructure getDbStructure schema = do- tabs <- allTables- cols <- allColumns tabs- syns <- allSynonyms cols- rels <- allRelations tabs cols- keys <- allPrimaryKeys tabs+ tabs <- H.query () allTables+ cols <- H.query () $ allColumns tabs+ syns <- H.query () $ allSynonyms cols+ rels <- H.query () $ allRelations tabs cols+ keys <- H.query () $ allPrimaryKeys tabs let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels cols' = addForeignKeys rels' cols@@ -44,52 +48,113 @@ , dbPrimaryKeys = keys' } -doesProc :: forall c s. B.CxValue c Int =>- (Text -> Text -> B.Stmt c) -> QualifiedIdentifier -> H.Tx c s Bool-doesProc stmt qi = do- row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi)- return $ isJust row+encodeQi :: HE.Params QualifiedIdentifier+encodeQi =+ contramap qiSchema (HE.value HE.text) <>+ contramap qiName (HE.value HE.text) -doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool-doesProcExist = doesProc [H.stmt|+decodeTables :: HD.Result [Table]+decodeTables =+ HD.rowsList tblRow+ where+ tblRow = Table <$> HD.value HD.text <*> HD.value HD.text+ <*> HD.value HD.bool++decodeColumns :: [Table] -> HD.Result [Column]+decodeColumns tables =+ mapMaybe (columnFromRow tables) <$> HD.rowsList colRow+ where+ colRow =+ (,,,,,,,,,,)+ <$> HD.value HD.text <*> HD.value HD.text+ <*> HD.value HD.text <*> HD.value HD.int4+ <*> HD.value HD.bool <*> HD.value HD.text+ <*> HD.value HD.bool+ <*> HD.nullableValue HD.int4+ <*> HD.nullableValue HD.int4+ <*> HD.nullableValue HD.text+ <*> HD.nullableValue HD.text++decodeRelations :: [Table] -> [Column] -> HD.Result [Relation]+decodeRelations tables cols =+ mapMaybe (relationFromRow tables cols) <$> HD.rowsList relRow+ where+ relRow = (,,,,,)+ <$> HD.value HD.text+ <*> HD.value HD.text+ <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text)))+ <*> HD.value HD.text+ <*> HD.value HD.text+ <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text)))++decodePks :: [Table] -> HD.Result [PrimaryKey]+decodePks tables =+ mapMaybe (pkFromRow tables) <$> HD.rowsList pkRow+ where+ pkRow = (,,) <$> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text++decodeSynonyms :: [Column] -> HD.Result [(Column,Column)]+decodeSynonyms cols =+ mapMaybe (synonymFromRow cols) <$> HD.rowsList synRow+ where+ synRow = (,,,,,)+ <$> HD.value HD.text <*> HD.value HD.text+ <*> HD.value HD.text <*> HD.value HD.text+ <*> HD.value HD.text <*> HD.value HD.text++doesProcExist :: H.Query QualifiedIdentifier Bool+doesProcExist =+ H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True+ where+ sql = [q| SELECT EXISTS ( SELECT 1 FROM pg_catalog.pg_namespace n JOIN pg_catalog.pg_proc p ON pronamespace = n.oid- WHERE nspname = ?- AND proname = ?- |]+ WHERE nspname = $1+ AND proname = $2+ ) |] -doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool-doesProcReturnJWT = doesProc [H.stmt|+doesProcReturnJWT :: H.Query QualifiedIdentifier Bool+doesProcReturnJWT =+ H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True+ where+ sql = [q| SELECT EXISTS ( SELECT 1 FROM pg_catalog.pg_namespace n JOIN pg_catalog.pg_proc p ON pronamespace = n.oid- WHERE nspname = ?- AND proname = ?+ WHERE nspname = $1+ AND proname = $2 AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims'- |]+ ) |] -accessibleTables :: [Table] -> H.Tx P.Postgres s [Table]-accessibleTables allTabs = do- accessible <- H.listEx $ [H.stmt|- SELECT- n.nspname AS table_schema,- c.relname AS table_name- FROM pg_class c- 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(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 table_schema, table_name- |]- let isAccessible table = isJust $ find (\(s,n) -> tableSchema table == s && tableName table == n) accessible- return $ filter isAccessible allTabs+accessibleTables :: H.Query Schema [Table]+accessibleTables =+ H.statement sql (HE.value HE.text) decodeTables True+ where+ sql = [q|+ 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 = $1+ 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 |] synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]] synonymousColumns allSyns cols = synCols'@@ -107,9 +172,9 @@ addFk col = col { colFK = fk col } fk col = join $ relToFk col <$> find (lookupFn col) rels lookupFn :: Column -> Relation -> Bool- lookupFn c (Relation{relColumns=cs, relType=rty}) = c `elem` cs && rty==Child+ lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child -- lookupFn _ _ = False- relToFk col (Relation{relColumns=cols, relFColumns=colsF}) = ForeignKey <$> colF+ relToFk col Relation{relColumns=cols, relFColumns=colsF} = ForeignKey <$> colF where pos = elemIndex col cols colF = (colsF !!) <$> pos@@ -131,7 +196,7 @@ where links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels groupFn :: Relation -> Text- groupFn (Relation{relTable=Table{tableSchema=s, tableName=t}}) = s<>"_"<>t+ groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s<>"_"<>t combinations k ns = filter ((k==).length) (subsequences ns) addMirrorRelation [] = [] addMirrorRelation (rel@(Relation t c ft fc _ lt lc1 lc2):rels') = Relation ft fc t c Many lt lc2 lc1 : rel : addMirrorRelation rels'@@ -163,173 +228,170 @@ keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns -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- FROM pg_class c- 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')- GROUP BY table_schema, table_name, insertable- ORDER BY table_schema, table_name- |]- return $ map tableFromRow rows--tableFromRow :: (Text, Text, Bool) -> Table-tableFromRow (s, n, i) = Table s n i+allTables :: H.Query () [Table]+allTables =+ H.statement sql HE.unit decodeTables True+ where+ sql = [q|+ 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+ FROM pg_class c+ 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')+ GROUP BY table_schema, table_name, insertable+ ORDER BY table_schema, table_name |] -allColumns :: [Table] -> H.Tx P.Postgres s [Column]-allColumns tabs = do- cols <- H.listEx $ [H.stmt|- SELECT DISTINCT- 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 (- /*- -- CTE based on information_schema.columns to remove the owner filter- */- WITH columns AS (- SELECT current_database()::information_schema.sql_identifier AS table_catalog,- nc.nspname::information_schema.sql_identifier AS table_schema,- c.relname::information_schema.sql_identifier AS table_name,- a.attname::information_schema.sql_identifier AS column_name,- a.attnum::information_schema.cardinal_number AS ordinal_position,- pg_get_expr(ad.adbin, ad.adrelid)::information_schema.character_data AS column_default,- CASE- WHEN a.attnotnull OR t.typtype = 'd'::"char" AND t.typnotnull THEN 'NO'::text- ELSE 'YES'::text- END::information_schema.yes_or_no AS is_nullable,- CASE- WHEN t.typtype = 'd'::"char" THEN- CASE- WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text- WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)- ELSE 'USER-DEFINED'::text- END- ELSE- CASE- WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text- WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)- ELSE 'USER-DEFINED'::text- END- END::information_schema.character_data AS data_type,- information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length,- information_schema._pg_char_octet_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_octet_length,- information_schema._pg_numeric_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision,- information_schema._pg_numeric_precision_radix(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision_radix,- information_schema._pg_numeric_scale(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_scale,- information_schema._pg_datetime_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS datetime_precision,- information_schema._pg_interval_type(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.character_data AS interval_type,- NULL::integer::information_schema.cardinal_number AS interval_precision,- NULL::character varying::information_schema.sql_identifier AS character_set_catalog,- NULL::character varying::information_schema.sql_identifier AS character_set_schema,- NULL::character varying::information_schema.sql_identifier AS character_set_name,- CASE- WHEN nco.nspname IS NOT NULL THEN current_database()- ELSE NULL::name- END::information_schema.sql_identifier AS collation_catalog,- nco.nspname::information_schema.sql_identifier AS collation_schema,- co.collname::information_schema.sql_identifier AS collation_name,- CASE- WHEN t.typtype = 'd'::"char" THEN current_database()- ELSE NULL::name- END::information_schema.sql_identifier AS domain_catalog,- CASE- WHEN t.typtype = 'd'::"char" THEN nt.nspname- ELSE NULL::name- END::information_schema.sql_identifier AS domain_schema,- CASE- WHEN t.typtype = 'd'::"char" THEN t.typname- ELSE NULL::name- END::information_schema.sql_identifier AS domain_name,- current_database()::information_schema.sql_identifier AS udt_catalog,- COALESCE(nbt.nspname, nt.nspname)::information_schema.sql_identifier AS udt_schema,- COALESCE(bt.typname, t.typname)::information_schema.sql_identifier AS udt_name,- NULL::character varying::information_schema.sql_identifier AS scope_catalog,- NULL::character varying::information_schema.sql_identifier AS scope_schema,- NULL::character varying::information_schema.sql_identifier AS scope_name,- NULL::integer::information_schema.cardinal_number AS maximum_cardinality,- a.attnum::information_schema.sql_identifier AS dtd_identifier,- 'NO'::character varying::information_schema.yes_or_no AS is_self_referencing,- 'NO'::character varying::information_schema.yes_or_no AS is_identity,- NULL::character varying::information_schema.character_data AS identity_generation,- NULL::character varying::information_schema.character_data AS identity_start,- NULL::character varying::information_schema.character_data AS identity_increment,- NULL::character varying::information_schema.character_data AS identity_maximum,- NULL::character varying::information_schema.character_data AS identity_minimum,- NULL::character varying::information_schema.yes_or_no AS identity_cycle,- 'NEVER'::character varying::information_schema.character_data AS is_generated,- NULL::character varying::information_schema.character_data AS generation_expression,- CASE- WHEN c.relkind = 'r'::"char" OR (c.relkind = ANY (ARRAY['v'::"char", 'f'::"char"])) AND pg_column_is_updatable(c.oid::regclass, a.attnum, false) THEN 'YES'::text- ELSE 'NO'::text- END::information_schema.yes_or_no AS is_updatable- FROM pg_attribute a- LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum- JOIN (pg_class c- JOIN pg_namespace nc ON c.relnamespace = nc.oid) ON a.attrelid = c.oid- JOIN (pg_type t- JOIN pg_namespace nt ON t.typnamespace = nt.oid) ON a.atttypid = t.oid- LEFT JOIN (pg_type bt- JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid) ON t.typtype = 'd'::"char" AND t.typbasetype = bt.oid- LEFT JOIN (pg_collation co- JOIN pg_namespace nco ON co.collnamespace = nco.oid) ON a.attcollation = co.oid AND (nco.nspname <> 'pg_catalog'::name OR co.collname <> 'default'::name)- WHERE NOT pg_is_other_temp_schema(nc.oid) AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))- /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/- )- 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*/- FROM 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 $ mapMaybe (columnFromRow tabs) cols+allColumns :: [Table] -> H.Query () [Column]+allColumns tabs =+ H.statement sql HE.unit (decodeColumns tabs) True+ where+ sql = [q|+ SELECT DISTINCT+ 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 (+ /*+ -- CTE based on information_schema.columns to remove the owner filter+ */+ WITH columns AS (+ SELECT current_database()::information_schema.sql_identifier AS table_catalog,+ nc.nspname::information_schema.sql_identifier AS table_schema,+ c.relname::information_schema.sql_identifier AS table_name,+ a.attname::information_schema.sql_identifier AS column_name,+ a.attnum::information_schema.cardinal_number AS ordinal_position,+ pg_get_expr(ad.adbin, ad.adrelid)::information_schema.character_data AS column_default,+ CASE+ WHEN a.attnotnull OR t.typtype = 'd'::"char" AND t.typnotnull THEN 'NO'::text+ ELSE 'YES'::text+ END::information_schema.yes_or_no AS is_nullable,+ CASE+ WHEN t.typtype = 'd'::"char" THEN+ CASE+ WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text+ WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)+ ELSE 'USER-DEFINED'::text+ END+ ELSE+ CASE+ WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text+ WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)+ ELSE 'USER-DEFINED'::text+ END+ END::information_schema.character_data AS data_type,+ information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length,+ information_schema._pg_char_octet_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_octet_length,+ information_schema._pg_numeric_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision,+ information_schema._pg_numeric_precision_radix(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision_radix,+ information_schema._pg_numeric_scale(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_scale,+ information_schema._pg_datetime_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS datetime_precision,+ information_schema._pg_interval_type(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.character_data AS interval_type,+ NULL::integer::information_schema.cardinal_number AS interval_precision,+ NULL::character varying::information_schema.sql_identifier AS character_set_catalog,+ NULL::character varying::information_schema.sql_identifier AS character_set_schema,+ NULL::character varying::information_schema.sql_identifier AS character_set_name,+ CASE+ WHEN nco.nspname IS NOT NULL THEN current_database()+ ELSE NULL::name+ END::information_schema.sql_identifier AS collation_catalog,+ nco.nspname::information_schema.sql_identifier AS collation_schema,+ co.collname::information_schema.sql_identifier AS collation_name,+ CASE+ WHEN t.typtype = 'd'::"char" THEN current_database()+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_catalog,+ CASE+ WHEN t.typtype = 'd'::"char" THEN nt.nspname+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_schema,+ CASE+ WHEN t.typtype = 'd'::"char" THEN t.typname+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_name,+ current_database()::information_schema.sql_identifier AS udt_catalog,+ COALESCE(nbt.nspname, nt.nspname)::information_schema.sql_identifier AS udt_schema,+ COALESCE(bt.typname, t.typname)::information_schema.sql_identifier AS udt_name,+ NULL::character varying::information_schema.sql_identifier AS scope_catalog,+ NULL::character varying::information_schema.sql_identifier AS scope_schema,+ NULL::character varying::information_schema.sql_identifier AS scope_name,+ NULL::integer::information_schema.cardinal_number AS maximum_cardinality,+ a.attnum::information_schema.sql_identifier AS dtd_identifier,+ 'NO'::character varying::information_schema.yes_or_no AS is_self_referencing,+ 'NO'::character varying::information_schema.yes_or_no AS is_identity,+ NULL::character varying::information_schema.character_data AS identity_generation,+ NULL::character varying::information_schema.character_data AS identity_start,+ NULL::character varying::information_schema.character_data AS identity_increment,+ NULL::character varying::information_schema.character_data AS identity_maximum,+ NULL::character varying::information_schema.character_data AS identity_minimum,+ NULL::character varying::information_schema.yes_or_no AS identity_cycle,+ 'NEVER'::character varying::information_schema.character_data AS is_generated,+ NULL::character varying::information_schema.character_data AS generation_expression,+ CASE+ WHEN c.relkind = 'r'::"char" OR (c.relkind = ANY (ARRAY['v'::"char", 'f'::"char"])) AND pg_column_is_updatable(c.oid::regclass, a.attnum, false) THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS is_updatable+ FROM pg_attribute a+ LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum+ JOIN (pg_class c+ JOIN pg_namespace nc ON c.relnamespace = nc.oid) ON a.attrelid = c.oid+ JOIN (pg_type t+ JOIN pg_namespace nt ON t.typnamespace = nt.oid) ON a.atttypid = t.oid+ LEFT JOIN (pg_type bt+ JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid) ON t.typtype = 'd'::"char" AND t.typbasetype = bt.oid+ LEFT JOIN (pg_collation co+ JOIN pg_namespace nco ON co.collnamespace = nco.oid) ON a.attcollation = co.oid AND (nco.nspname <> 'pg_catalog'::name OR co.collname <> 'default'::name)+ WHERE NOT pg_is_other_temp_schema(nc.oid) AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))+ /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/+ )+ 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*/+ FROM 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 |] columnFromRow :: [Table] ->- (Text, Text, Text,- Int, Bool, Text,- Bool, Maybe Int, Maybe Int,+ (Text, Text, Text,+ Int32, Bool, Text,+ Bool, Maybe Int32, Maybe Int32, Maybe Text, Maybe Text) -> Maybe Column columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table@@ -339,9 +401,11 @@ parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str -allRelations :: [Table] -> [Column] -> H.Tx P.Postgres s [Relation]-allRelations tabs cols = do- rels <- H.listEx $ [H.stmt|+allRelations :: [Table] -> [Column] -> H.Query () [Relation]+allRelations tabs cols =+ H.statement sql HE.unit (decodeRelations tabs cols) True+ where+ sql = [q| SELECT ns1.nspname AS table_schema, tab.relname AS table_name, column_info.cols AS columns,@@ -365,9 +429,7 @@ LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other, LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2 WHERE confrelid != 0- ORDER BY (conrelid, column_info.nums)- |]- return $ mapMaybe (relationFromRow tabs cols) rels+ ORDER BY (conrelid, column_info.nums) |] relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =@@ -380,119 +442,121 @@ cols = mapM (findCol rs rt) rcs colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey]-allPrimaryKeys tabs = do- pks <- H.listEx $ [H.stmt|- /*- -- CTE to replace information_schema.table_constraints to remove owner limit- */- WITH tc AS (- SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,- nc.nspname::information_schema.sql_identifier AS constraint_schema,- c.conname::information_schema.sql_identifier AS constraint_name,- current_database()::information_schema.sql_identifier AS table_catalog,- nr.nspname::information_schema.sql_identifier AS table_schema,- r.relname::information_schema.sql_identifier AS table_name,- CASE c.contype- WHEN 'c'::"char" THEN 'CHECK'::text- WHEN 'f'::"char" THEN 'FOREIGN KEY'::text- WHEN 'p'::"char" THEN 'PRIMARY KEY'::text- WHEN 'u'::"char" THEN 'UNIQUE'::text- ELSE NULL::text- END::information_schema.character_data AS constraint_type,- CASE- WHEN c.condeferrable THEN 'YES'::text- ELSE 'NO'::text- END::information_schema.yes_or_no AS is_deferrable,- CASE- WHEN c.condeferred THEN 'YES'::text- ELSE 'NO'::text- END::information_schema.yes_or_no AS initially_deferred- FROM pg_namespace nc,- pg_namespace nr,- pg_constraint c,- pg_class r- WHERE nc.oid = c.connamespace AND nr.oid = r.relnamespace AND c.conrelid = r.oid AND (c.contype <> ALL (ARRAY['t'::"char", 'x'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)- /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/- UNION ALL- SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,- nr.nspname::information_schema.sql_identifier AS constraint_schema,- (((((nr.oid::text || '_'::text) || r.oid::text) || '_'::text) || a.attnum::text) || '_not_null'::text)::information_schema.sql_identifier AS constraint_name,- current_database()::information_schema.sql_identifier AS table_catalog,- nr.nspname::information_schema.sql_identifier AS table_schema,- r.relname::information_schema.sql_identifier AS table_name,- 'CHECK'::character varying::information_schema.character_data AS constraint_type,- 'NO'::character varying::information_schema.yes_or_no AS is_deferrable,- 'NO'::character varying::information_schema.yes_or_no AS initially_deferred- FROM pg_namespace nr,- pg_class r,- pg_attribute a- WHERE nr.oid = r.relnamespace AND r.oid = a.attrelid AND a.attnotnull AND a.attnum > 0 AND NOT a.attisdropped AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)- /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/- ),- /*- -- CTE to replace information_schema.key_column_usage to remove owner limit- */- kc AS (- SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,- ss.nc_nspname::information_schema.sql_identifier AS constraint_schema,- ss.conname::information_schema.sql_identifier AS constraint_name,- current_database()::information_schema.sql_identifier AS table_catalog,- ss.nr_nspname::information_schema.sql_identifier AS table_schema,- ss.relname::information_schema.sql_identifier AS table_name,- a.attname::information_schema.sql_identifier AS column_name,- (ss.x).n::information_schema.cardinal_number AS ordinal_position,- CASE- WHEN ss.contype = 'f'::"char" THEN information_schema._pg_index_position(ss.conindid, ss.confkey[(ss.x).n])- ELSE NULL::integer- END::information_schema.cardinal_number AS position_in_unique_constraint- FROM pg_attribute a,- ( SELECT r.oid AS roid,- r.relname,- r.relowner,- nc.nspname AS nc_nspname,- nr.nspname AS nr_nspname,- c.oid AS coid,- c.conname,- c.contype,- c.conindid,- c.confkey,- c.confrelid,- information_schema._pg_expandarray(c.conkey) AS x- FROM pg_namespace nr,- pg_class r,- pg_namespace nc,- pg_constraint c- WHERE nr.oid = r.relnamespace AND r.oid = c.conrelid AND nc.oid = c.connamespace AND (c.contype = ANY (ARRAY['p'::"char", 'u'::"char", 'f'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)) ss- WHERE ss.roid = a.attrelid AND a.attnum = (ss.x).x AND NOT a.attisdropped- /*--AND (pg_has_role(ss.relowner, 'USAGE'::text) OR has_column_privilege(ss.roid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/- )- SELECT- kc.table_schema,- kc.table_name,- kc.column_name- FROM- /*- --information_schema.table_constraints tc,- --information_schema.key_column_usage kc- */- tc, 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')- |]- return $ mapMaybe (pkFromRow tabs) pks+allPrimaryKeys :: [Table] -> H.Query () [PrimaryKey]+allPrimaryKeys tabs =+ H.statement sql HE.unit (decodePks tabs) True+ where+ sql = [q|+ /*+ -- CTE to replace information_schema.table_constraints to remove owner limit+ */+ WITH tc AS (+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ nc.nspname::information_schema.sql_identifier AS constraint_schema,+ c.conname::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ nr.nspname::information_schema.sql_identifier AS table_schema,+ r.relname::information_schema.sql_identifier AS table_name,+ CASE c.contype+ WHEN 'c'::"char" THEN 'CHECK'::text+ WHEN 'f'::"char" THEN 'FOREIGN KEY'::text+ WHEN 'p'::"char" THEN 'PRIMARY KEY'::text+ WHEN 'u'::"char" THEN 'UNIQUE'::text+ ELSE NULL::text+ END::information_schema.character_data AS constraint_type,+ CASE+ WHEN c.condeferrable THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS is_deferrable,+ CASE+ WHEN c.condeferred THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS initially_deferred+ FROM pg_namespace nc,+ pg_namespace nr,+ pg_constraint c,+ pg_class r+ WHERE nc.oid = c.connamespace AND nr.oid = r.relnamespace AND c.conrelid = r.oid AND (c.contype <> ALL (ARRAY['t'::"char", 'x'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)+ /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/+ UNION ALL+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ nr.nspname::information_schema.sql_identifier AS constraint_schema,+ (((((nr.oid::text || '_'::text) || r.oid::text) || '_'::text) || a.attnum::text) || '_not_null'::text)::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ nr.nspname::information_schema.sql_identifier AS table_schema,+ r.relname::information_schema.sql_identifier AS table_name,+ 'CHECK'::character varying::information_schema.character_data AS constraint_type,+ 'NO'::character varying::information_schema.yes_or_no AS is_deferrable,+ 'NO'::character varying::information_schema.yes_or_no AS initially_deferred+ FROM pg_namespace nr,+ pg_class r,+ pg_attribute a+ WHERE nr.oid = r.relnamespace AND r.oid = a.attrelid AND a.attnotnull AND a.attnum > 0 AND NOT a.attisdropped AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)+ /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/+ ),+ /*+ -- CTE to replace information_schema.key_column_usage to remove owner limit+ */+ kc AS (+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ ss.nc_nspname::information_schema.sql_identifier AS constraint_schema,+ ss.conname::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ ss.nr_nspname::information_schema.sql_identifier AS table_schema,+ ss.relname::information_schema.sql_identifier AS table_name,+ a.attname::information_schema.sql_identifier AS column_name,+ (ss.x).n::information_schema.cardinal_number AS ordinal_position,+ CASE+ WHEN ss.contype = 'f'::"char" THEN information_schema._pg_index_position(ss.conindid, ss.confkey[(ss.x).n])+ ELSE NULL::integer+ END::information_schema.cardinal_number AS position_in_unique_constraint+ FROM pg_attribute a,+ ( SELECT r.oid AS roid,+ r.relname,+ r.relowner,+ nc.nspname AS nc_nspname,+ nr.nspname AS nr_nspname,+ c.oid AS coid,+ c.conname,+ c.contype,+ c.conindid,+ c.confkey,+ c.confrelid,+ information_schema._pg_expandarray(c.conkey) AS x+ FROM pg_namespace nr,+ pg_class r,+ pg_namespace nc,+ pg_constraint c+ WHERE nr.oid = r.relnamespace AND r.oid = c.conrelid AND nc.oid = c.connamespace AND (c.contype = ANY (ARRAY['p'::"char", 'u'::"char", 'f'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)) ss+ WHERE ss.roid = a.attrelid AND a.attnum = (ss.x).x AND NOT a.attisdropped+ /*--AND (pg_has_role(ss.relowner, 'USAGE'::text) OR has_column_privilege(ss.roid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/+ )+ SELECT+ kc.table_schema,+ kc.table_name,+ kc.column_name+ FROM+ /*+ --information_schema.table_constraints tc,+ --information_schema.key_column_usage kc+ */+ tc, 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') |] pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -allSynonyms :: [Column] -> H.Tx P.Postgres s [(Column,Column)]-allSynonyms allCols = do- syns <- H.listEx $ [H.stmt|+allSynonyms :: [Column] -> H.Query () [(Column,Column)]+allSynonyms cols =+ H.statement sql HE.unit (decodeSynonyms cols) True+ where+ sql = [q| WITH synonyms AS ( /* -- CTE to replace the view from information_schema because the information in it depended on the logged in role@@ -554,9 +618,7 @@ syn_table_schema, syn_table_name, (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] AS syn_column_name /* " <- for syntax highlighting */ FROM synonyms- )- |]- return $ mapMaybe (synonymFromRow allCols) syns+ ) |] synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column) synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
src/PostgREST/Error.hs view
@@ -2,58 +2,64 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (PgError, pgErrResponse, errResponse) where+module PostgREST.Error (pgErrResponse, errResponse) where import Data.Aeson ((.=)) import qualified Data.Aeson as JSON+import Data.Monoid ((<>)) import Data.String.Conversions (cs)-import Data.String.Utils (replace) import Data.Text (Text) import qualified Data.Text as T-import qualified Hasql as H-import qualified Hasql.Postgres as P+import qualified Hasql.Session as H import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) -type PgError = H.SessionError P.Postgres- errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) -pgErrResponse :: PgError -> Response+pgErrResponse :: H.Error -> Response pgErrResponse e = responseLBS (httpStatus e) [(hContentType, "application/json")] (JSON.encode e) -instance JSON.ToJSON PgError where- toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [+instance JSON.ToJSON H.Error where+ toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ "code" .= (cs c::T.Text), "message" .= (cs m::T.Text), "details" .= (fmap cs d::Maybe T.Text), "hint" .= (fmap cs h::Maybe T.Text)]- toJSON (H.TxError (P.NoResult d)) = JSON.object [- "message" .= ("No response from server"::T.Text),- "details" .= (fmap cs d::Maybe T.Text)]- toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]- toJSON (H.TxError P.NotInTransaction) = JSON.object [- "message" .= ("Not in transaction"::T.Text)]- toJSON (H.CxError (P.CantConnect d)) = JSON.object [- "message" .= ("Can't connect to the database"::T.Text),+ toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [+ "message" .= (cs m::T.Text)]+ toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [+ "message" .= ("Row error: end of input"::String),+ "details" .=+ ("Attempt to parse more columns than there are in the result"::String),+ "details" .= ("Row number " <> show i)]+ toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [+ "message" .= ("Row error: unexpected null"::String),+ "details" .= ("Attempt to parse a NULL as some value."::String),+ "details" .= ("Row number " <> show i)]+ toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [+ "message" .= ("Row error: Wrong value parser used"::String),+ "details" .= d,+ "details" .= ("Row number " <> show i)]+ toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [+ "message" .= ("Unexpected amount of rows"::String),+ "details" .= i]+ toJSON (H.ClientError d) = JSON.object [+ "message" .= ("Database client error"::String), "details" .= (fmap cs d::Maybe T.Text)]- toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [- "message" .= ("Postgres version "++version++" is not supported") ]- where version = replace "0" "." (show v)- toJSON (H.ResultError m) = JSON.object ["message" .= m] -httpStatus :: PgError -> HT.Status-httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =- let code = cs codeBS in- case code of+httpStatus :: H.Error -> HT.Status+httpStatus (H.ResultError (H.ServerError c _ _ _)) =+ case cs c of '0':'8':_ -> HT.status503 -- pg connection err '0':'9':_ -> HT.status500 -- triggered action exception '0':'L':_ -> HT.status403 -- invalid grantor '0':'P':_ -> HT.status403 -- invalid role specification+ "23503" -> HT.status409 -- foreign_key_violation+ "23505" -> HT.status409 -- unique_violation '2':'5':_ -> HT.status500 -- invalid tx state '2':'8':_ -> HT.status403 -- invalid auth specification '2':'D':_ -> HT.status500 -- invalid tx termination@@ -73,5 +79,5 @@ "42P01" -> HT.status404 -- undefined table "42501" -> HT.status404 -- insufficient privilege _ -> HT.status400-httpStatus (H.TxError (P.NoResult _)) = HT.status503-httpStatus _ = HT.status500+httpStatus (H.ResultError _) = HT.status500+httpStatus (H.ClientError _) = HT.status503
src/PostgREST/Main.hs view
@@ -9,21 +9,23 @@ prettyVersion, readOptions) import PostgREST.DbStructure-import PostgREST.Error (PgError, pgErrResponse)+import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Middleware+import PostgREST.QueryBuilder (inTransaction, Isolation(..)) import Control.Monad (unless, void)-import Control.Monad.IO.Class (liftIO)-import Data.Aeson (encode)-import Data.Functor.Identity import Data.Monoid ((<>))+import Data.Pool import Data.String.Conversions (cs)-import Data.Text (Text) import Data.Time.Clock.POSIX (getPOSIXTime)-import qualified Hasql as H-import qualified Hasql.Postgres as P+import qualified Hasql.Query as H+import qualified Hasql.Connection as H+import qualified Hasql.Session as H+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Network.HTTP.Types.Status as HT import Network.Wai-import Network.Wai.Handler.Warp hiding (Connection)+import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger (logStdout) import System.IO (BufferMode (..), hSetBuffering, stderr,@@ -36,13 +38,14 @@ import Control.Exception.Base (throwTo, AsyncException(..)) #endif -isServerVersionSupported :: H.Session P.Postgres IO Bool+isServerVersionSupported :: H.Session Bool isServerVersionSupported = do- Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]- return $ read (cs row) >= minimumPgVersion--hasqlError :: PgError -> IO a-hasqlError = error . cs . encode+ ver <- H.query () pgVersion+ return $ read (cs ver) >= minimumPgVersion+ where+ pgVersion =+ H.statement "SHOW server_version_num"+ HE.unit (HD.singleRow $ HD.value HD.text) True main :: IO () main = do@@ -58,40 +61,44 @@ Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let pgSettings = P.StringSettings $ cs (configDatabase conf)+ let pgSettings = cs (configDatabase conf) appSettings = setPort port . setServerName (cs $ "postgrest/" <> prettyVersion) $ defaultSettings middle = logStdout . defaultMiddle - poolSettings <- maybe (fail "Improper session settings") return $- H.poolSettings (fromIntegral $ configPool conf) 30- pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings+ pool <- createPool (H.acquire pgSettings)+ (either (const $ return ()) H.release) 1 1 (configPool conf) - supportedOrError <- H.session pool isServerVersionSupported- either hasqlError- (\supported ->- unless supported $- error (- "Cannot run in this PostgreSQL version, PostgREST needs at least "- <> show minimumPgVersion)- ) supportedOrError+ dbStructure <- withResource pool $ \case+ Left err -> error $ show err+ Right c -> do+ supported <- H.run isServerVersionSupported c+ case supported of+ Left e -> error $ show e+ Right good -> unless good $+ error (+ "Cannot run in this PostgreSQL version, PostgREST needs at least "+ <> show minimumPgVersion) + dbOrError <- H.run (getDbStructure (cs $ configSchema conf)) c+ either (error . show) return dbOrError+ #ifndef mingw32_HOST_OS tid <- myThreadId void $ installHandler keyboardSignal (Catch $ do- H.releasePool pool+ destroyAllResources pool throwTo tid UserInterrupt ) Nothing #endif - let txSettings = Just (H.ReadCommitted, Just True)- dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf)- dbStructure <- either hasqlError return dbOrError- runSettings appSettings $ middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req- resOrError <- liftIO $ H.session pool $ H.tx txSettings $- runWithClaims conf time (app dbStructure conf body) req- either (respond . pgErrResponse) respond resOrError+ let handleReq = H.run $ inTransaction ReadCommitted+ (runWithClaims conf time (app dbStructure conf body) req)+ withResource pool $ \case+ Left err -> respond $ errResponse HT.status500 (cs . show $ err)+ Right c -> do+ resOrError <- handleReq c+ either (respond . pgErrResponse) respond resOrError
src/PostgREST/Middleware.hs view
@@ -7,8 +7,7 @@ import Data.Text import Data.String.Conversions (cs) import Data.Time.Clock (NominalDiffTime)-import qualified Hasql as H-import qualified Hasql.Postgres as P+import qualified Hasql.Session as H import Network.HTTP.Types.Header (hAccept, hAuthorization) import Network.HTTP.Types.Status (status415, status400)@@ -25,28 +24,25 @@ import Prelude hiding(concat) -import qualified Data.Vector as V-import qualified Hasql.Backend as B import qualified Data.Map.Lazy as M -runWithClaims :: forall s. AppConfig -> NominalDiffTime ->- (Request -> H.Tx P.Postgres s Response) ->- Request -> H.Tx P.Postgres s Response+runWithClaims :: AppConfig -> NominalDiffTime ->+ (Request -> H.Session Response) ->+ Request -> H.Session Response runWithClaims conf time app req = do- _ <- H.unitEx $ stmt setAnon+ H.sql setAnon case split (== ' ') (cs auth) of ("Bearer" : tokenStr : _) -> case jwtClaims jwtSecret tokenStr time of Just claims -> if M.member "role" claims then do- mapM_ H.unitEx $ stmt <$> claimsToSQL claims+ mapM_ H.sql $ claimsToSQL claims app req else invalidJWT _ -> invalidJWT _ -> app req where- stmt c = B.Stmt c V.empty True hdrs = requestHeaders req jwtSecret = configJwtSecret conf auth = fromMaybe "" $ lookup hAuthorization hdrs
src/PostgREST/QueryBuilder.hs view
@@ -15,10 +15,10 @@ module PostgREST.QueryBuilder ( addRelations , addJoinConditions- , asJson , callProc , createReadStatement , createWriteStatement+ , inTransaction , operators , pgFmtIdent , pgFmtLit@@ -26,28 +26,34 @@ , requestToCountQuery , sourceCTEName , unquoted+ , ResultsWithCount+ , Isolation(..) ) where -import qualified Hasql as H-import qualified Hasql.Backend as B-import qualified Hasql.Postgres as P+import qualified Hasql.Query as H+import qualified Hasql.Session as H+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD import qualified Data.Aeson as JSON+import Data.Int (Int64) import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error (note, fromMaybe, mapMaybe)+import Data.Functor.Contravariant (contramap) import qualified Data.HashMap.Strict as HM import Data.List (find, (\\)) import Data.Monoid ((<>)) import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T (map, takeWhile) import Data.String.Conversions (cs)-import Control.Applicative (empty, (<|>))+import Control.Applicative ((<|>)) import Control.Monad (join) import Data.Tree (Tree(..)) import qualified Data.Vector as V import PostgREST.Types import qualified Data.Map as M+import Text.InterpolatedString.Perl6 (qc) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Data.Scientific ( FPFormat (..)@@ -57,70 +63,101 @@ import Prelude hiding (unwords) import PostgREST.ApiRequest (PreferRepresentation (..)) -type PStmt = H.Stmt P.Postgres-instance Monoid PStmt where- mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =- B.Stmt (query <> query') (params <> params') (prep && prep')- mempty = B.Stmt "" empty True-type StatementT = PStmt -> PStmt -createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres+{-| The generic query result format used by API responses -}+type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString)++{-| Read and Write api requests use a similar response format which includes+ various record counts and possible location header. This is the decoder+ for that common type of query.+-}+decodeStandard :: HD.Result ResultsWithCount+decodeStandard =+ HD.singleRow standardRow+ where+ standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8+ <*> HD.value HD.bytea <*> HD.value HD.bytea++decodeStandardMay :: HD.Result (Maybe ResultsWithCount)+decodeStandardMay =+ HD.maybeRow standardRow+ where+ standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8+ <*> HD.value HD.bytea <*> HD.value HD.bytea++{-| JSON and CSV payloads from the client are given to us as+ UniformObjects (objects who all have the same keys),+ and we turn this into an old fasioned JSON array+-}+encodeUniformObjs :: HE.Params UniformObjects+encodeUniformObjs =+ contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json)++createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool ->+ H.Query () ResultsWithCount createReadStatement selectQuery countQuery range isSingle countTotal asCsv =- B.Stmt (- "WITH " <> sourceCTEName <> " AS (" <> selectQuery <> ") " <>- "SELECT " <> intercalate ", " [+ H.statement sql HE.unit decodeStandard True+ where+ sql = [qc|+ WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}+ FROM ( SELECT * FROM {sourceCTEName} {limitF range}) t |]+ countResultF = if countTotal then "("<>countQuery<>")" else "null"+ cols = intercalate ", " [ countResultF <> " AS total_result_set", "pg_catalog.count(t) AS page_total",- "null AS header",+ "'' AS header", bodyF <> " AS body"- ] <>- " FROM ( SELECT * FROM " <> sourceCTEName <> " " <> limitF range <> ") t"- ) V.empty True- where- countResultF = if countTotal then "("<>countQuery<>")" else "null"- bodyF- | asCsv = asCsvF- | isSingle = asJsonSingleF- | otherwise = asJsonF+ ]+ bodyF+ | asCsv = asCsvF+ | isSingle = asJsonSingleF+ | otherwise = asJsonF -createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation ->- [Text] -> Bool -> Payload -> B.Stmt P.Postgres+createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->+ PreferRepresentation -> [Text] -> Bool -> Payload ->+ H.Query UniformObjects (Maybe ResultsWithCount) createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ mutateQuery _ None- _ _ (PayloadJSON (UniformObjects rows)) =- B.Stmt (- "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> ") " <>- "SELECT null, 0, null, null"- ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True+ _ _ (PayloadJSON (UniformObjects _)) =+ H.statement sql encodeUniformObjs decodeStandardMay True+ where+ sql = [qc|+ WITH {sourceCTEName} AS ({mutateQuery})+ SELECT '', 0, '', '' |]+ createWriteStatement qi _ mutateQuery isSingle HeadersOnly- pKeys _ (PayloadJSON (UniformObjects rows)) =- B.Stmt (- "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <>- "SELECT " <> intercalate ", " [- "null AS total_result_set",+ pKeys _ (PayloadJSON (UniformObjects _)) =+ H.statement sql encodeUniformObjs decodeStandardMay True+ where+ sql = [qc|+ WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)+ SELECT {cols}+ FROM (SELECT 1 FROM {sourceCTEName}) t |]+ cols = intercalate ", " [+ "'' AS total_result_set", "pg_catalog.count(t) AS page_total",- if isSingle then locationF pKeys else "null",- "null"- ] <>- " FROM (SELECT 1 FROM " <> sourceCTEName <> ") t"- ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True+ if isSingle then locationF pKeys else "''",+ "''"+ ]+ createWriteStatement qi selectQuery mutateQuery isSingle Full- pKeys asCsv (PayloadJSON (UniformObjects rows)) =- B.Stmt (- "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <>- "SELECT " <> intercalate ", " [- "null AS total_result_set", -- when updateing it does not make sense+ pKeys asCsv (PayloadJSON (UniformObjects _)) =+ H.statement sql encodeUniformObjs decodeStandardMay True+ where+ sql = [qc|+ WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)+ SELECT {cols}+ FROM ({selectQuery}) t |]+ cols = intercalate ", " [+ "'' AS total_result_set", -- when updateing it does not make sense "pg_catalog.count(t) AS page_total",- if isSingle then locationF pKeys else "null" <> " AS header",+ if isSingle then locationF pKeys else "''" <> " AS header", bodyF <> " AS body"- ] <>- " FROM ( "<>selectQuery<>") t"- ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True- where- bodyF- | asCsv = asCsvF- | isSingle = asJsonSingleF- | otherwise = asJsonF+ ]+ bodyF+ | asCsv = asCsvF+ | isSingle = asJsonSingleF+ | otherwise = asJsonF addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _)) forest) =@@ -131,8 +168,8 @@ $ findRelationByTable schema name parentTable <|> findRelationByColumn schema parentTable name addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))- addRel (q, (n, _)) r = (q {from=fromRelation}, (n, Just r))- where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from q)+ addRel (query', (n, _)) r = (query' {from=fromRelation}, (n, Just r))+ where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query') _ -> Node (query, (name, Nothing)) <$> updatedForest where@@ -150,13 +187,13 @@ addJoinConditions schema (Node (query, (n, r)) forest) = case r of Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node- Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest- Just (Relation{relType=Parent}) -> Node (updatedQuery, (n,r)) <$> updatedForest- Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->+ Just rel@Relation{relType=Child} -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest+ Just Relation{relType=Parent} -> Node (updatedQuery, (n,r)) <$> updatedForest+ Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> Node (qq, (n, r)) <$> updatedForest where- q = addCond updatedQuery (getJoinConditions rel)- qq = q{from=tableName linkTable : from q}+ query' = addCond updatedQuery (getJoinConditions rel)+ qq = query'{from=tableName linkTable : from query'} _ -> Left "unknown relation" where -- add parentTable and parentJoinConditions to the query@@ -164,23 +201,23 @@ where parentJoinConditions = map (getJoinConditions . snd) parents parents = mapMaybe (getParents . rootLabel) forest- getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)+ getParents (_, (tbl, Just rel@Relation{relType=Parent})) = Just (tbl, rel) getParents _ = Nothing updatedForest = mapM (addJoinConditions schema) forest- addCond q con = q{flt_=con ++ flt_ q}--asJson :: StatementT-asJson s = s {- B.stmtTemplate =- "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from ("- <> B.stmtTemplate s <> ") t" }+ addCond query' con = query'{flt_=con ++ flt_ query'} -callProc :: QualifiedIdentifier -> JSON.Object -> PStmt-callProc qi params = do- let args = intercalate "," $ map assignment (HM.toList params)- B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True+callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value)+callProc qi params =+ H.statement sql HE.unit decodeObj True where- assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v+ sql = [qc| SELECT array_to_json(+ coalesce(array_agg(row_to_json(t)), '\{}')+ )::character varying+ from ({_callSql}) t |]+ _args = intercalate "," $ map _assignment (HM.toList params)+ _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v+ _callSql = [qc| select * from {fromQi qi}({_args}) |] :: BS.ByteString+ decodeObj = HD.maybeRow (HD.value HD.json) operators :: [(Text, SqlFragment)] operators = [@@ -209,7 +246,7 @@ let trimmed = trimNullChars x escaped = "'" <> replace "'" "''" trimmed <> "'" slashed = replace "\\" "\\\\" escaped in- if "\\\\" `isInfixOf` escaped+ if "\\" `isInfixOf` escaped then "E" <> slashed else slashed @@ -222,8 +259,8 @@ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions ] where- fn (Filter{value=VText _}) = True- fn (Filter{value=VForeignKey _ _}) = False+ fn Filter{value=VText _} = True+ fn Filter{value=VForeignKey _ _} = False localConditions = filter fn conditions requestToQuery :: Schema -> DbRequest -> SqlQuery@@ -268,19 +305,19 @@ filterParentConditions parentTable (Filter _ _ (VForeignKey (QualifiedIdentifier "" t) _)) = parentTable == t filterParentConditions _ _ = False getQueryParts :: Tree ReadNode -> ([(SqlFragment, TableName)], [SqlFragment]) -> ([(SqlFragment,TableName)], [SqlFragment])- getQueryParts (Node n@(_, (name, Just (Relation {relType=Child,relTable=Table{tableName=table}}))) forst) (j,s) = (j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s) where sel = "COALESCE((" <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table <> "), '[]') AS " <> pgFmtIdent name where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just (Relation {relType=Parent,relTable=Table{tableName=table}}))) forst) (j,s) = (joi:j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}})) forst) (j,s) = (joi:j,sel:s) where sel = "row_to_json(" <> pgFmtIdent table <> ".*) AS "<>pgFmtIdent name --TODO must be singular joi = ("( " <> subquery <> " ) AS " <> pgFmtIdent table, table) where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just (Relation {relType=Many,relTable=Table{tableName=table}}))) forst) (j,s) = (j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s) where sel = "COALESCE ((" <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "@@ -299,7 +336,7 @@ "INSERT INTO ", fromQi qi, " (" <> colsString <> ")" <> " SELECT " <> colsString <>- " FROM json_populate_recordset(null::" , fromQi qi, ", ?)"+ " FROM json_populate_recordset(null::" , fromQi qi, ", $1)" ] requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = case rows V.!? 0 of@@ -339,7 +376,7 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF where asCsvHeaderF =- "(SELECT string_agg(a.k, ',')" <>+ "(SELECT coalesce(string_agg(a.k, ','), '')" <> " FROM (" <> " SELECT json_object_keys(r)::TEXT as k" <> " FROM ( " <>@@ -350,10 +387,10 @@ asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" asJsonF :: SqlFragment-asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"+asJsonF = "coalesce(array_to_json(array_agg(row_to_json(t))), '[]')::character varying" asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element-asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "+asJsonSingleF = "coalesce(string_agg(row_to_json(t)::text, ','), '')::character varying " locationF :: [Text] -> SqlFragment locationF pKeys =@@ -365,8 +402,7 @@ if null pKeys then "" else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"- ) <>- ")"+ ) <> ")" limitF :: NonnegRange -> SqlFragment limitF r = "LIMIT " <> limit <> " OFFSET " <> offset@@ -468,3 +504,20 @@ trimNullChars :: Text -> Text trimNullChars = T.takeWhile (/= '\x0')++data Isolation = ReadCommitted | RepeatableRead | Serializable++{- |+ Wrap a session in a transaction of desired isolation level+-}+inTransaction :: Isolation -> H.Session a -> H.Session a+inTransaction lvl f = do+ H.sql $ "begin " <> isolate <> ";"+ r <- f+ H.sql "commit;"+ return r+ where+ isolate = case lvl of+ ReadCommitted -> "ISOLATION LEVEL READ COMMITTED"+ RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"+ Serializable -> "ISOLATION LEVEL SERIALIZABLE"
src/PostgREST/RangeQuery.hs view
@@ -24,7 +24,7 @@ import Prelude -type NonnegRange = Range Int+type NonnegRange = Range Integer rangeParse :: BS.ByteString -> NonnegRange rangeParse range = do@@ -41,28 +41,28 @@ rangeRequested :: RequestHeaders -> NonnegRange rangeRequested = rangeParse . fromMaybe "" . lookup hRange -restrictRange :: Maybe Int -> NonnegRange -> NonnegRange+restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange restrictRange Nothing r = r restrictRange (Just limit) r = rangeIntersection r $ Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) -rangeLimit :: NonnegRange -> Maybe Int+rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range = case [rangeLower range, rangeUpper range] of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) _ -> Nothing -rangeOffset :: NonnegRange -> Int+rangeOffset :: NonnegRange -> Integer rangeOffset range = case rangeLower range of BoundaryBelow from -> from _ -> error "range without lower bound" -- should never happen -rangeGeq :: Int -> NonnegRange+rangeGeq :: Integer -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll -rangeLeq :: Int -> NonnegRange+rangeLeq :: Integer -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n)
src/PostgREST/Types.hs view
@@ -5,6 +5,7 @@ import qualified Data.ByteString as BS import qualified Data.Vector as V import Data.Aeson+import Data.Int (Int32) data DbStructure = DbStructure { dbTables :: [Table]@@ -31,12 +32,12 @@ Column { colTable :: Table , colName :: Text- , colPosition :: Int+ , colPosition :: Int32 , colNullable :: Bool , colType :: Text , colUpdatable :: Bool- , colMaxLen :: Maybe Int- , colPrecision :: Maybe Int+ , colMaxLen :: Maybe Int32+ , colPrecision :: Maybe Int32 , colDefault :: Maybe Text , colEnum :: [Text] , colFK :: Maybe ForeignKey@@ -89,6 +90,9 @@ -- the same keys in every object newtype UniformObjects = UniformObjects (V.Vector Object) deriving (Show, Eq)++unUniformObjects :: UniformObjects -> V.Vector Object+unUniformObjects (UniformObjects objs) = objs -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until
test/Feature/AuthSpec.hs view
@@ -5,16 +5,14 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types--import Hasql as H-import Hasql.Postgres as P+import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) -- }}} -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = around (withApp cfgDefault struct pool)+spec :: DbStructure -> H.Connection -> Spec+spec struct c = around (withApp cfgDefault struct c) $ describe "authorization" $ do it "hides tables that anonymous does not own" $
test/Feature/CorsSpec.hs view
@@ -5,9 +5,7 @@ import Test.Hspec.Wai import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) import qualified Data.ByteString.Lazy as BL--import Hasql as H-import Hasql.Postgres as P+import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..))@@ -15,8 +13,8 @@ import Network.HTTP.Types -- }}} -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = around (withApp cfgDefault struct pool) $ describe "CORS" $ do+spec :: DbStructure -> H.Connection -> Spec+spec struct c = around (withApp cfgDefault struct c) $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), ("Origin", "http://example.com"),
test/Feature/DeleteSpec.hs view
@@ -4,17 +4,15 @@ import Test.Hspec.Wai import Text.Heredoc -import Hasql as H-import Hasql.Postgres as P- import SpecHelper import PostgREST.Types (DbStructure(..))+import qualified Hasql.Connection as H import Network.HTTP.Types -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = beforeAll resetDb- . around (withApp cfgDefault struct pool) $+spec :: DbStructure -> H.Connection -> Spec+spec struct c = beforeAll resetDb+ . around (withApp cfgDefault struct c) $ describe "Deleting" $ do context "existing record" $ do it "succeeds with 204 and deletion count" $
test/Feature/InsertSpec.hs view
@@ -5,9 +5,6 @@ import Test.Hspec.Wai.JSON import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus)) -import Hasql as H-import Hasql.Postgres as P- import SpecHelper import PostgREST.Types (DbStructure(..)) @@ -17,13 +14,14 @@ import Network.HTTP.Types.Header import Network.HTTP.Types import Control.Monad (replicateM_)+import qualified Hasql.Connection as H import TestTypes(IncPK(..), CompoundPK(..)) -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = beforeAll_ resetDb $ around (withApp cfgDefault struct pool) $ do+spec :: DbStructure -> H.Connection -> Spec+spec struct c = beforeAll_ resetDb $ around (withApp cfgDefault struct c) $ do describe "Posting new record" $ do- context "disparate csv types" $ do+ context "disparate json types" $ do it "accepts disparate json types" $ do p <- post "/menagerie" [json| {@@ -124,6 +122,18 @@ it "fails with 400 and error" $ post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400 + context "with valid json payload" $+ it "succeeds and returns 201 created" $+ post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 201++ context "attempting to insert a row with the same primary key" $+ it "fails returning a 409 Conflict" $+ post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 409++ context "attempting to insert a row with conflicting unique constraint" $+ it "fails returning a 409 Conflict" $+ post "/withUnique" [json| { "uni":"nodup", "extra":"e2" } |] `shouldRespondWith` 409+ context "jsonb" $ do it "serializes nested object" $ do let inserted = [json| { "data": { "foo":"bar" } } |]@@ -231,7 +241,7 @@ describe "Putting record" $ do - context "to unkonwn uri" $+ context "to unknown uri" $ it "gives a 404" $ do pendingWith "Decide on PUT usefullness" request methodPut "/fake" []@@ -306,7 +316,7 @@ describe "Patching record" $ do - context "to unkonwn uri" $+ context "to unknown uri" $ it "gives a 404" $ request methodPatch "/fake" [] [json| { "real": false } |]@@ -366,6 +376,17 @@ [("Prefer", "return=representation")] [json| { id: 99 } |] `shouldRespondWith` [json| [{id:99}] |]++ it "can set a json column to escaped value" $ do+ _ <- post "/json" [json| { data: {"escaped":"bar"} } |]+ request methodPatch "/json?data->>escaped=eq.bar"+ [("Prefer", "return=representation")]+ [json| { "data": { "escaped":" \"bar" } } |]+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [json| [{ "data": { "escaped":" \"bar" } }] |]+ , matchStatus = 200+ , matchHeaders = []+ } describe "Row level permission" $ it "set user_id when inserting rows" $ do
test/Feature/QuerySpec.hs view
@@ -5,16 +5,14 @@ import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders))--import Hasql as H-import Hasql.Postgres as P+import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) import Text.Heredoc -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = around (withApp cfgDefault struct pool) $ do+spec :: DbStructure -> H.Connection -> Spec+spec struct c = around (withApp cfgDefault struct c) $ do describe "Querying a table with a column called count" $ it "should not confuse count column with pg_catalog.count aggregate" $@@ -387,6 +385,33 @@ it "returns proper json" $ post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith` [json| [{"sayhello":"Hello, world"}] |]++ context "improper input" $ do+ it "rejects unknown content type even if payload is good" $+ request methodPost "/rpc/sayhello"+ (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]+ `shouldRespondWith` 415+ it "rejects malformed json payload" $+ request methodPost "/rpc/sayhello"+ (acceptHdrs "application/json") "sdfsdf"+ `shouldRespondWith` 400++ context "unsupported verbs" $ do+ it "DELETE fails" $+ request methodDelete "/rpc/sayhello" [] ""+ `shouldRespondWith` 405+ it "PATCH fails" $+ request methodPatch "/rpc/sayhello" [] ""+ `shouldRespondWith` 405+ it "OPTIONS fails" $+ -- TODO: should return info about the function+ request methodOptions "/rpc/sayhello" [] ""+ `shouldRespondWith` 405+ it "GET fails with 405 on unknown procs" $+ -- TODO: should this be 404?+ get "/rpc/fake" `shouldRespondWith` 405+ it "GET with 405 on known procs" $+ get "/rpc/sayhello" `shouldRespondWith` 405 describe "weird requests" $ do it "can query as normal" $ do
test/Feature/RangeSpec.hs view
@@ -5,16 +5,14 @@ import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))--import Hasql as H-import Hasql.Postgres as P+import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = beforeAll resetDb- . around (withApp cfgDefault struct pool) $+spec :: DbStructure -> H.Connection -> Spec+spec struct c = beforeAll resetDb+ . around (withApp cfgDefault struct c) $ describe "GET /items" $ do context "without range headers" $ do
test/Feature/StructureSpec.hs view
@@ -3,17 +3,15 @@ import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON--import Hasql as H-import Hasql.Postgres as P+import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -spec :: DbStructure -> H.Pool P.Postgres -> Spec-spec struct pool = around (withApp cfgDefault struct pool) $ do+spec :: DbStructure -> H.Connection -> Spec+spec struct c = around (withApp cfgDefault struct c) $ do describe "GET /" $ do it "lists views in schema" $ request methodGet "/" [] ""@@ -45,6 +43,7 @@ , {"schema":"test","name":"users","insertable":true} , {"schema":"test","name":"users_projects","insertable":true} , {"schema":"test","name":"users_tasks","insertable":true}+ , {"schema":"test","name":"withUnique","insertable":true} ] |] {matchStatus = 200} @@ -321,3 +320,6 @@ ] } |]++ it "errors for non existant tables" $+ request methodOptions "/dne" [] "" `shouldRespondWith` 404
test/Main.hs view
@@ -3,8 +3,12 @@ import Test.Hspec import SpecHelper ---import PostgREST.Types (DbStructure(..))+import qualified Hasql.Session as H+import qualified Hasql.Connection as H +import PostgREST.DbStructure (getDbStructure)+import Data.String.Conversions (cs)+ import qualified Feature.AuthSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec@@ -18,20 +22,22 @@ main = do setupDb - pool <- specDbPool- dbStructure <- specDbStructure pool-- -- Not using hspec-discover because we want to precompute- -- the db structure and pass it to specs for speed- hspec $ specs dbStructure pool+ H.acquire (cs dbString) >>= \case+ Left err -> error $ show err+ Right c -> do+ dbOrErr <- H.run (getDbStructure "test") c+ -- Not using hspec-discover because we want to precompute+ -- the db structure and pass it to specs for speed+ either (error.show) (hspec . specs c) dbOrErr+ H.release c where- specs dbStructure pool = do- describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure pool- describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure pool- describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure pool- describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure pool- describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure pool- describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure pool- describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure pool- describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure pool+ specs conn dbStructure = do+ describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn+ describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn+ describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn+ describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn+ describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure conn+ describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure conn+ describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure conn+ describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure conn
test/SpecHelper.hs view
@@ -2,16 +2,8 @@ import Network.Wai import Test.Hspec-import Test.Hspec.Wai -import Hasql as H-import Hasql.Backend as B-import Hasql.Postgres as P- import Data.String.Conversions (cs)-import Data.Monoid-import Data.Text hiding (map)-import qualified Data.Vector as V import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad (void) @@ -19,57 +11,47 @@ hRange, hAuthorization, hAccept) import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..))-import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import System.Process (readProcess) import Web.JWT (secret) +import qualified Hasql.Connection as H+import qualified Hasql.Session as H+ import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(pgErrResponse)-import PostgREST.DbStructure import PostgREST.Types+import PostgREST.QueryBuilder (inTransaction, Isolation(..)) dbString :: String dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" -cfg :: String -> Maybe Int -> AppConfig-cfg conStr = AppConfig conStr 3000 "postgrest_test_anonymous" "test" (secret "safe") 10+cfg :: String -> Maybe Integer -> AppConfig+cfg conStr = AppConfig conStr "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 cfgDefault :: AppConfig cfgDefault = cfg dbString Nothing -cfgLimitRows :: Int -> AppConfig+cfgLimitRows :: Integer -> AppConfig cfgLimitRows = cfg dbString . Just -testPoolOpts :: PoolSettings-testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30--pgSettings :: P.Settings-pgSettings = P.StringSettings $ cs dbString--specDbPool :: IO (H.Pool P.Postgres)-specDbPool = H.acquirePool pgSettings testPoolOpts--specDbStructure :: H.Pool P.Postgres -> IO DbStructure-specDbStructure pool = do- dbOrError <- H.session pool $ H.tx specTxSettings- $ getDbStructure "test"- either (fail . show) return dbOrError--withApp :: AppConfig -> DbStructure -> H.Pool P.Postgres+withApp :: AppConfig -> DbStructure -> H.Connection -> ActionWith Application -> IO ()-withApp config dbStructure pool perform = do- perform $ middle $ \req resp -> do+withApp config dbStructure c perform =+ perform $ defaultMiddle $ \req resp -> do time <- getPOSIXTime body <- strictRequestBody req- result <- liftIO $ H.session pool $ H.tx specTxSettings- $ runWithClaims config time (app dbStructure config body) req- either (resp . pgErrResponse) resp result+ let handleReq = H.run $ inTransaction ReadCommitted+ (runWithClaims config time (app dbStructure config body) req) - where middle = defaultMiddle+ handleReq c >>= \case+ Left err -> do+ void $ H.run (H.sql "rollback;") c+ resp $ pgErrResponse err+ Right res -> resp res setupDb :: IO () setupDb = do@@ -106,15 +88,3 @@ authHeaderJWT :: String -> Header authHeaderJWT token = (hAuthorization, cs $ "Bearer " ++ token)--testPool :: IO(H.Pool P.Postgres)-testPool = H.acquirePool pgSettings testPoolOpts--clearTable :: Text -> IO ()-clearTable table = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $ B.Stmt ("truncate table test." <> table <> " cascade") V.empty True--specTxSettings :: Maybe (TxIsolationLevel, Maybe Bool)-specTxSettings = Just (H.ReadCommitted, Just True)