diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.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 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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, "", "") diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -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) <> ";" {-| diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -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) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -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 diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -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 diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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" diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -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) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -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" $ diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -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"), diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -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" $ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -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 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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 diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -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 diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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)