From d6102cc90813ea88f356e97a7d1eeb868b05c414 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 3 Jan 2016 15:57:36 -0800 Subject: [PATCH 01/26] Use the correct Error types for hasql 0.19 --- postgrest.cabal | 8 +------ src/PostgREST/Error.hs | 50 +++++++++++++++++++++++------------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 28bebb487..d2caf922d 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -37,9 +37,7 @@ executable postgrest , cassava , containers , errors - , hasql >= 0.7.3 && < 0.8 - , hasql-backend >= 0.4.1 && < 0.5 - , hasql-postgres >= 0.10.4 && < 0.11 + , hasql >= 0.15.1 && < 0.16 , jwt , optparse-applicative >= 0.11 && < 0.13 , parsec @@ -94,8 +92,6 @@ library , containers , errors , hasql - , hasql-backend - , hasql-postgres , http-types , jwt , optparse-applicative @@ -170,8 +166,6 @@ Test-Suite spec , containers , errors , hasql - , hasql-backend - , hasql-postgres , heredoc , hlint , hspec == 2.2.* diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index cdd12761e..71ddafa3b 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -7,17 +7,16 @@ module PostgREST.Error (PgError, 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 +type PgError = H.Error errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) @@ -27,29 +26,36 @@ 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 [ + 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), + 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.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), - "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.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 @@ -75,5 +81,5 @@ httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) = "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 From 72cd6c37bdf5897323a9138334fdd1e1647ed219 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 12 Jan 2016 16:52:44 -0800 Subject: [PATCH 02/26] Change some import statements and Session types --- src/PostgREST/App.hs | 4 +--- src/PostgREST/DbStructure.hs | 20 +++++++++----------- src/PostgREST/Middleware.hs | 8 +++----- 3 files changed, 13 insertions(+), 19 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 46463bf3a..90853917b 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -33,9 +33,7 @@ import Data.Aeson 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.Connection as H import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index c5dd29bc8..340e3ad62 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -17,15 +17,13 @@ import Data.List (elemIndex, find, subsequences, sort, tr 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 Prelude -getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure +getDbStructure :: Schema -> H.Session DbStructure getDbStructure schema = do tabs <- allTables cols <- allColumns tabs @@ -50,7 +48,7 @@ doesProc stmt qi = do row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi) return $ isJust row -doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool +doesProcExist :: QualifiedIdentifier -> H.Session Bool doesProcExist = doesProc [H.stmt| SELECT 1 FROM pg_catalog.pg_namespace n @@ -60,7 +58,7 @@ doesProcExist = doesProc [H.stmt| AND proname = ? |] -doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool +doesProcReturnJWT :: QualifiedIdentifier -> H.Session Bool doesProcReturnJWT = doesProc [H.stmt| SELECT 1 FROM pg_catalog.pg_namespace n @@ -171,7 +169,7 @@ synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys s 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 :: H.Session [Table] allTables = do rows <- H.listEx $ [H.stmt| SELECT @@ -196,7 +194,7 @@ allTables = do tableFromRow :: (Text, Text, Bool) -> Table tableFromRow (s, n, i) = Table s n i -allColumns :: [Table] -> H.Tx P.Postgres s [Column] +allColumns :: [Table] -> H.Session [Column] allColumns tabs = do cols <- H.listEx $ [H.stmt| SELECT DISTINCT @@ -347,7 +345,7 @@ columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> tab parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str -allRelations :: [Table] -> [Column] -> H.Tx P.Postgres s [Relation] +allRelations :: [Table] -> [Column] -> H.Session [Relation] allRelations tabs cols = do rels <- H.listEx $ [H.stmt| SELECT ns1.nspname AS table_schema, @@ -388,7 +386,7 @@ relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) = cols = mapM (findCol rs rt) rcs colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey] +allPrimaryKeys :: [Table] -> H.Session [PrimaryKey] allPrimaryKeys tabs = do pks <- H.listEx $ [H.stmt| /* @@ -498,7 +496,7 @@ 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 :: [Column] -> H.Session [(Column,Column)] allSynonyms allCols = do syns <- H.listEx $ [H.stmt| WITH synonyms AS ( diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 1a80fef7a..9aee017f3 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -7,8 +7,7 @@ import Data.Maybe (fromMaybe) 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) @@ -26,12 +25,11 @@ import PostgREST.Error (errResponse) 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 + (Request -> H.Session Response) -> + Request -> H.Session Response runWithClaims conf time app req = do _ <- H.unitEx $ stmt setAnon case split (== ' ') (cs auth) of From 7b92449343d5319e6e110641946b7f85fae5899e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 13 Jan 2016 15:35:55 -0800 Subject: [PATCH 03/26] QueryBuilder compiles with hasql 19 --- postgrest.cabal | 4 +- src/PostgREST/QueryBuilder.hs | 152 ++++++++++++++++++++-------------- src/PostgREST/Types.hs | 3 + stack.yaml | 3 +- 4 files changed, 98 insertions(+), 64 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index d2caf922d..ea8acb100 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -37,7 +37,7 @@ executable postgrest , cassava , containers , errors - , hasql >= 0.15.1 && < 0.16 + , hasql >= 0.19.3.1 && < 0.20 , jwt , optparse-applicative >= 0.11 && < 0.13 , parsec @@ -90,9 +90,11 @@ library , case-insensitive , cassava , containers + , contravariant , errors , hasql , http-types + , interpolatedstring-perl6 , jwt , optparse-applicative , parsec diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 52a2101d3..2b40f236e 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -28,26 +28,29 @@ module PostgREST.QueryBuilder ( , unquoted ) 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.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, q) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Data.Scientific ( FPFormat (..) @@ -57,70 +60,94 @@ import Data.Scientific ( FPFormat (..) 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 = (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.value 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", 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 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 decodeStandard True + where + sql = [qc| + WITH {sourceCTEName} AS ({mutateQuery}) + SELECT null, 0, null, null |] + createWriteStatement qi _ mutateQuery isSingle HeadersOnly - pKeys _ (PayloadJSON (UniformObjects rows)) = - B.Stmt ( - "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <> - "SELECT " <> intercalate ", " [ + pKeys _ (PayloadJSON (UniformObjects _)) = + H.statement sql encodeUniformObjs decodeStandard True + where + sql = [qc| + WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) + SELECT {cols} + FROM (SELECT 1 FROM {sourceCTEName}) t |] + cols = intercalate ", " [ "null 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 + ] + createWriteStatement qi selectQuery mutateQuery isSingle Full - pKeys asCsv (PayloadJSON (UniformObjects rows)) = - B.Stmt ( - "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <> - "SELECT " <> intercalate ", " [ + pKeys asCsv (PayloadJSON (UniformObjects _)) = + H.statement sql encodeUniformObjs decodeStandard True + where + sql = [qc| + WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) + SELECT {cols} + FROM ({selectQuery}) t |] + cols = intercalate ", " [ "null 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", 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 +158,8 @@ addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _ $ 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 @@ -155,8 +182,8 @@ addJoinConditions schema (Node (query, (n, r)) forest) = 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 @@ -167,19 +194,20 @@ addJoinConditions schema (Node (query, (n, r)) forest) = 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} + addCond query' con = query'{flt_=con ++ flt_ query'} -asJson :: StatementT -asJson s = s { - B.stmtTemplate = - "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from (" - <> B.stmtTemplate s <> ") t" } +asJson :: BS.ByteString -> BS.ByteString +asJson _sql = + [q| SELECT array_to_json( + coalesce(array_agg(row_to_json(t)), '{}') + )::character varying + from ({_sql}) t |] -callProc :: QualifiedIdentifier -> JSON.Object -> PStmt +callProc :: QualifiedIdentifier -> JSON.Object -> BS.ByteString callProc qi params = do - let args = intercalate "," $ map assignment (HM.toList params) - B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True + [qc| select * from {fromQi qi}({args}) |] where + args = intercalate "," $ map assignment (HM.toList params) assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v operators :: [(Text, SqlFragment)] diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 8bd6b91c8..5ee53d7cb 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -90,6 +90,9 @@ data Relation = Relation { 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 -- then CSV is converted to a JSON array. diff --git a/stack.yaml b/stack.yaml index fb06a970b..f9f57e7b1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ flags: {} packages: - '.' extra-deps: + - hasql-0.19.3.1 - Ranged-sets-0.3.0 - packdeps-0.4.1 -resolver: nightly-2015-10-27 +resolver: lts-4.1 From 684b11badb1472df8c6e7563285c59829262dcca Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 13 Jan 2016 20:26:39 -0800 Subject: [PATCH 04/26] WIP: converting DbStructure --- src/PostgREST/DbStructure.hs | 40 ++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 340e3ad62..d2f10f1f3 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -10,9 +10,15 @@ module PostgREST.DbStructure ( , 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.Contravariant (contramap) import Data.Functor.Identity +import Text.InterpolatedString.Perl6 (q) import Data.List (elemIndex, find, subsequences, sort, transpose) import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe) import Data.Monoid @@ -42,24 +48,36 @@ getDbStructure schema = do , 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.Session Bool -doesProcExist = doesProc [H.stmt| +decodeTable :: HD.Result Table +decodeTable = + HD.singleRow standardRow + where + standardRow = Table <$> HD.value HD.text <*> HD.value HD.text + <*> HD.value HD.bool + +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 = ? - |] + ) |] -doesProcReturnJWT :: QualifiedIdentifier -> H.Session 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 @@ -67,7 +85,7 @@ doesProcReturnJWT = doesProc [H.stmt| WHERE nspname = ? AND proname = ? AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims' - |] + ) |] accessibleTables :: Schema -> H.Tx P.Postgres s [Table] accessibleTables schema = do From 2d5210464accb56e33a90cc109c43e7e18954675 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 15 Jan 2016 13:27:50 -0800 Subject: [PATCH 05/26] WIP: converting dbstructure --- src/PostgREST/DbStructure.hs | 106 +++++++++++++++++------------------ 1 file changed, 53 insertions(+), 53 deletions(-) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index d2f10f1f3..93d8ecc07 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -53,12 +53,12 @@ encodeQi = contramap qiSchema (HE.value HE.text) <> contramap qiName (HE.value HE.text) -decodeTable :: HD.Result Table -decodeTable = - HD.singleRow standardRow +decodeTables :: HD.Result [Table] +decodeTables = + HD.rowsList tblRow where - standardRow = Table <$> HD.value HD.text <*> HD.value HD.text - <*> HD.value HD.bool + tblRow = Table <$> HD.value HD.text <*> HD.value HD.text + <*> HD.value HD.bool doesProcExist :: H.Query QualifiedIdentifier Bool doesProcExist = @@ -87,33 +87,33 @@ doesProcReturnJWT = AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims' ) |] -accessibleTables :: Schema -> H.Tx P.Postgres s [Table] -accessibleTables schema = do - rows <- H.listEx $ - [H.stmt| - select - n.nspname as table_schema, - relname as table_name, - c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 - or (exists ( - select 1 - from pg_trigger - where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69) - ) as insertable - from - pg_class c - join pg_namespace n on n.oid = c.relnamespace - where - c.relkind in ('v', 'r', 'm') - and n.nspname = ? - and ( - pg_has_role(c.relowner, 'USAGE'::text) - or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) - or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) - ) - order by relname - |] schema - return $ map tableFromRow rows +accessibleTables :: H.Query Schema [Table] +accessibleTables = + H.statement sql (HE.value HE.text) (HD.rowsList (HD.value HD.text)) 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' @@ -187,27 +187,27 @@ synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys s 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.Session [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 +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 |] tableFromRow :: (Text, Text, Bool) -> Table tableFromRow (s, n, i) = Table s n i From 4b515c5df477f024538da60192aedbb99a7b03e6 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 00:03:51 -0800 Subject: [PATCH 06/26] WIP: converting DbStructure --- src/PostgREST/DbStructure.hs | 556 +++++++++++++++++++---------------- 1 file changed, 298 insertions(+), 258 deletions(-) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 93d8ecc07..84843c520 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -27,9 +27,10 @@ import qualified Hasql.Session as H import PostgREST.Types import GHC.Exts (groupWith) +import GHC.Int (Int32) import Prelude -getDbStructure :: Schema -> H.Session DbStructure +getDbStructure :: Schema -> H.Query () DbStructure getDbStructure schema = do tabs <- allTables cols <- allColumns tabs @@ -60,6 +61,48 @@ decodeTables = 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.arrayValue HD.text) + <*> HD.value HD.text + <*> HD.value HD.text + <*> HD.value (HD.array $ 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 @@ -209,151 +252,148 @@ allTables = GROUP BY table_schema, table_name, insertable ORDER BY table_schema, table_name |] -tableFromRow :: (Text, Text, Bool) -> Table -tableFromRow (s, n, i) = Table s n i - -allColumns :: [Table] -> H.Session [Column] +allColumns :: [Table] -> H.Query () [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 + 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 @@ -363,9 +403,11 @@ columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> tab parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str -allRelations :: [Table] -> [Column] -> H.Session [Relation] +allRelations :: [Table] -> [Column] -> H.Query () [Relation] allRelations tabs cols = do - rels <- H.listEx $ [H.stmt| + 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, @@ -389,9 +431,7 @@ allRelations tabs cols = do 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) = @@ -404,119 +444,121 @@ relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) = cols = mapM (findCol rs rt) rcs colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Session [PrimaryKey] +allPrimaryKeys :: [Table] -> H.Query () [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 + 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.Session [(Column,Column)] -allSynonyms allCols = do - syns <- H.listEx $ [H.stmt| +allSynonyms :: [Column] -> H.Query () [(Column,Column)] +allSynonyms cols = do + 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 @@ -578,9 +620,7 @@ allSynonyms allCols = do 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 From abc30d51703ecbae7cc3b7d11b7bb47f675414d1 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 10:10:40 -0800 Subject: [PATCH 07/26] DbStructure compiles --- src/PostgREST/DbStructure.hs | 24 +++++++++++------------- src/PostgREST/Types.hs | 7 ++++--- 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 84843c520..162d245a9 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -15,9 +15,8 @@ import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD import Control.Applicative -import Control.Monad (join) +import Control.Monad (join, replicateM) import Data.Functor.Contravariant (contramap) -import Data.Functor.Identity import Text.InterpolatedString.Perl6 (q) import Data.List (elemIndex, find, subsequences, sort, transpose) import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe) @@ -30,13 +29,13 @@ import GHC.Exts (groupWith) import GHC.Int (Int32) import Prelude -getDbStructure :: Schema -> H.Query () 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 @@ -83,10 +82,10 @@ decodeRelations tables cols = relRow = (,,,,,) <$> HD.value HD.text <*> HD.value HD.text - <*> HD.value (HD.array $ HD.arrayValue 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.arrayValue HD.text) + <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text))) decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables = @@ -132,7 +131,7 @@ doesProcReturnJWT = accessibleTables :: H.Query Schema [Table] accessibleTables = - H.statement sql (HE.value HE.text) (HD.rowsList (HD.value HD.text)) True + H.statement sql (HE.value HE.text) decodeTables True where sql = [q| select @@ -155,8 +154,7 @@ accessibleTables = 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 - |] + order by relname |] synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]] synonymousColumns allSyns cols = synCols' diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 5ee53d7cb..4eb8c3487 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import qualified Data.Vector as V import Data.Aeson +import GHC.Int (Int32) data DbStructure = DbStructure { dbTables :: [Table] @@ -31,12 +32,12 @@ data Column = 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 From 6122bc4108a53477c60102b49044cfb273d28b7f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 10:23:14 -0800 Subject: [PATCH 08/26] Middleware compiles --- src/PostgREST/Auth.hs | 9 +++++---- src/PostgREST/Middleware.hs | 8 +++----- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index f46da3c71..5cf3972e1 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -21,6 +21,7 @@ module PostgREST.Auth ( 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 @@ import qualified Data.HashMap.Lazy as H 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 {-| @@ -66,7 +67,7 @@ jwtClaims secret input time = customClaims = claim JWT.unregisteredClaims -- | Receives the name of a role and returns a SET ROLE statement -setRole :: Text -> Text +setRole :: Text -> BS.ByteString setRole role = "set local role " <> cs (pgFmtLit role) <> ";" diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 9aee017f3..4292e261c 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -24,27 +24,25 @@ import PostgREST.Error (errResponse) import Prelude hiding(concat) -import qualified Data.Vector as V import qualified Data.Map.Lazy as M -runWithClaims :: forall s. AppConfig -> NominalDiffTime -> +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 From cb3977679d918e6a364cf82ae6c83528f2b5f28f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 15:00:17 -0800 Subject: [PATCH 09/26] App.hs compiles (dubiously) Removed query body is no longer a maybe value --- src/PostgREST/App.hs | 68 +++++++++++++++++------------------ src/PostgREST/Config.hs | 2 +- src/PostgREST/DbStructure.hs | 2 +- src/PostgREST/QueryBuilder.hs | 49 +++++++++++++------------ src/PostgREST/RangeQuery.hs | 12 +++---- src/PostgREST/Types.hs | 2 +- 6 files changed, 68 insertions(+), 67 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 90853917b..2012ea65f 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -10,8 +10,6 @@ import Control.Applicative 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.Ord (comparing) @@ -33,7 +31,7 @@ import Data.Aeson import Data.Aeson.Types (emptyArray) import Data.Monoid import qualified Data.Vector as V -import qualified Hasql.Connection as H +import qualified Hasql.Session as H import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers @@ -47,8 +45,7 @@ import PostgREST.Types import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) -import PostgREST.QueryBuilder ( asJson - , callProc +import PostgREST.QueryBuilder ( callProc , addJoinConditions , sourceCTEName , requestToQuery @@ -56,11 +53,12 @@ import PostgREST.QueryBuilder ( asJson , 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) @@ -80,17 +78,17 @@ app dbStructure conf reqBody req = 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 + let frm = toInteger $ rangeOffset range + 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) @@ -102,46 +100,47 @@ app dbStructure conf reqBody req = "/" <> 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 @@ -158,25 +157,23 @@ app dbStructure conf reqBody req = (ActionInvoke, TargetIdent 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 (cs schema) + body <- encode <$> H.query schema accessibleTables return $ responseLBS status200 [jsonH] $ cs body (ActionUnknown _, _, _) -> return notFound @@ -204,14 +201,14 @@ app dbStructure conf reqBody req = 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 @@ -333,6 +330,5 @@ instance ToJSON TableOptions where , "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/Config.hs b/src/PostgREST/Config.hs index 91dd51fb5..f7392335e 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -42,7 +42,7 @@ data AppConfig = AppConfig { , configSchema :: String , configJwtSecret :: Secret , configPool :: Int - , configMaxRows :: Maybe Int + , configMaxRows :: Maybe Integer } argParser :: Parser AppConfig diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 162d245a9..dc620ed1d 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -26,7 +26,7 @@ import qualified Hasql.Session as H import PostgREST.Types import GHC.Exts (groupWith) -import GHC.Int (Int32) +import Data.Int (Int32) import Prelude getDbStructure :: Schema -> H.Session DbStructure diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 2b40f236e..54316f09e 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -15,7 +15,6 @@ Any function that outputs a SQL fragment should be in this module. module PostgREST.QueryBuilder ( addRelations , addJoinConditions - , asJson , callProc , createReadStatement , createWriteStatement @@ -26,6 +25,7 @@ module PostgREST.QueryBuilder ( , requestToCountQuery , sourceCTEName , unquoted + , ResultsWithCount ) where import qualified Hasql.Query as H @@ -62,7 +62,7 @@ import PostgREST.ApiRequest (PreferRepresentation (..)) {-| The generic query result format used by API responses -} -type ResultsWithCount = (Int64, Int64, BS.ByteString, BS.ByteString) +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 @@ -72,7 +72,14 @@ decodeStandard :: HD.Result ResultsWithCount decodeStandard = HD.singleRow standardRow where - standardRow = (,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 + 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 @@ -105,11 +112,11 @@ createReadStatement selectQuery countQuery range isSingle countTotal asCsv = createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation -> [Text] -> Bool -> Payload -> - H.Query UniformObjects ResultsWithCount + H.Query UniformObjects (Maybe ResultsWithCount) createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ mutateQuery _ None _ _ (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery}) @@ -117,7 +124,7 @@ createWriteStatement _ _ mutateQuery _ None createWriteStatement qi _ mutateQuery isSingle HeadersOnly pKeys _ (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) @@ -132,7 +139,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly createWriteStatement qi selectQuery mutateQuery isSingle Full pKeys asCsv (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) @@ -196,19 +203,18 @@ addJoinConditions schema (Node (query, (n, r)) forest) = updatedForest = mapM (addJoinConditions schema) forest addCond query' con = query'{flt_=con ++ flt_ query'} -asJson :: BS.ByteString -> BS.ByteString -asJson _sql = - [q| SELECT array_to_json( - coalesce(array_agg(row_to_json(t)), '{}') - )::character varying - from ({_sql}) t |] - -callProc :: QualifiedIdentifier -> JSON.Object -> BS.ByteString -callProc qi params = do - [qc| select * from {fromQi qi}({args}) |] +callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value) +callProc qi params = + H.statement sql HE.unit decodeObj True where - args = intercalate "," $ map assignment (HM.toList params) - assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v + sql = [q| 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 = [ @@ -327,7 +333,7 @@ requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects row "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 @@ -393,8 +399,7 @@ locationF pKeys = if null pKeys then "" else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')" - ) <> - ")" + ) <> ")" limitF :: NonnegRange -> SqlFragment limitF r = "LIMIT " <> limit <> " OFFSET " <> offset diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index c82a88b3d..e65ce4b3f 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -24,7 +24,7 @@ import Data.Maybe (fromMaybe, listToMaybe) import Prelude -type NonnegRange = Range Int +type NonnegRange = Range Integer rangeParse :: BS.ByteString -> NonnegRange rangeParse range = do @@ -41,28 +41,28 @@ rangeParse range = do 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 index 4eb8c3487..4b5473f8e 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -5,7 +5,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import qualified Data.Vector as V import Data.Aeson -import GHC.Int (Int32) +import Data.Int (Int32) data DbStructure = DbStructure { dbTables :: [Table] From 3844f3ee96d70825323d01567aba4843ca1f74fa Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 22:41:36 -0800 Subject: [PATCH 10/26] The app compiles but totally untested --- postgrest.cabal | 7 ++++- src/PostgREST/Error.hs | 10 +++--- src/PostgREST/Main.hs | 71 ++++++++++++++++++++++-------------------- 3 files changed, 48 insertions(+), 40 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index ea8acb100..09c6a9450 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -28,7 +28,7 @@ executable postgrest ghc-options: -Wall -W -O2 main-is: PostgREST/Main.hs - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase default-language: Haskell2010 build-depends: aeson >= 0.8 , base >= 4.8 && < 5 @@ -36,13 +36,16 @@ executable postgrest , case-insensitive , cassava , containers + , contravariant , errors , hasql >= 0.19.3.1 && < 0.20 + , interpolatedstring-perl6 , jwt , optparse-applicative >= 0.11 && < 0.13 , parsec , postgrest , regex-tdfa + , resource-pool , safe >= 0.3 && < 0.4 , scientific , string-conversions @@ -166,6 +169,7 @@ Test-Suite spec , case-insensitive , cassava , containers + , contravariant , errors , hasql , heredoc @@ -174,6 +178,7 @@ Test-Suite spec , hspec-wai , hspec-wai-json , http-types + , interpolatedstring-perl6 , jwt , optparse-applicative , packdeps diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 71ddafa3b..e6629f5dd 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (PgError, pgErrResponse, errResponse) where +module PostgREST.Error (pgErrResponse, errResponse) where import Data.Aeson ((.=)) @@ -16,16 +16,14 @@ import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) -type PgError = H.Error - 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 +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), @@ -53,7 +51,7 @@ instance JSON.ToJSON PgError where "message" .= ("Database client error"::String), "details" .= (fmap cs d::Maybe T.Text)] -httpStatus :: PgError -> HT.Status +httpStatus :: H.Error -> HT.Status httpStatus (H.ResultError (H.ServerError c _ _ _)) = case cs c of '0':'8':_ -> HT.status503 -- pg connection err diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 5061d9e19..a4075e3f2 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -9,19 +9,20 @@ import PostgREST.Config (AppConfig (..), prettyVersion, readOptions) import PostgREST.DbStructure -import PostgREST.Error (PgError, pgErrResponse) +import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Middleware 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.Middleware.RequestLogger (logStdout) @@ -36,13 +37,14 @@ import Control.Concurrent (myThreadId) 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 +60,43 @@ main = do 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 (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 From fec316b0879773fa1048663252500d9e15c348fe Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 21 Jan 2016 00:45:00 -0800 Subject: [PATCH 11/26] WIP: fixing compiler errors in specs --- postgrest.cabal | 3 +- test/Feature/AuthSpec.hs | 7 ++-- test/Feature/CorsSpec.hs | 7 ++-- test/Feature/DeleteSpec.hs | 7 ++-- test/Feature/InsertSpec.hs | 7 ++-- test/Feature/QueryLimitedSpec.hs | 7 ++-- test/Feature/QuerySpec.hs | 7 ++-- test/Feature/RangeSpec.hs | 7 ++-- test/Feature/StructureSpec.hs | 7 ++-- test/Main.hs | 2 +- test/SpecHelper.hs | 59 ++++++++------------------------ 11 files changed, 42 insertions(+), 78 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 09c6a9450..89d831cb4 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -134,7 +134,7 @@ library 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 @@ -185,6 +185,7 @@ Test-Suite spec , parsec , process , regex-tdfa + , resource-pool , safe , scientific , string-conversions diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 35595153d..fe77fb329 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -1,19 +1,18 @@ module Feature.AuthSpec where -- {{{ Imports +import Data.Pool import Test.Hspec 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = around (withApp cfgDefault struct pool) $ describe "authorization" $ do diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 8bc7f600c..a59e71b6e 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -1,13 +1,12 @@ module Feature.CorsSpec where -- {{{ Imports +import Data.Pool import Test.Hspec 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,7 +14,7 @@ import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -- }}} -spec :: DbStructure -> H.Pool P.Postgres -> Spec +spec :: DbStructure -> Pool H.Connection -> Spec spec struct pool = around (withApp cfgDefault struct pool) $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs index 23751141f..8f9f9761f 100644 --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -1,18 +1,17 @@ module Feature.DeleteSpec where +import Data.Pool import Test.Hspec 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = beforeAll resetDb . around (withApp cfgDefault struct pool) $ describe "Deleting" $ do diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 17ea3aa04..4a8478daf 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -5,22 +5,21 @@ import Test.Hspec.Wai 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(..)) import qualified Data.Aeson as JSON import Data.Maybe (fromJust) +import Data.Pool import Text.Heredoc 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = beforeAll_ resetDb $ around (withApp cfgDefault struct pool) $ do describe "Posting new record" $ do context "disparate csv types" $ do diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs index aad13bb3f..50c404fb1 100644 --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -1,18 +1,17 @@ module Feature.QueryLimitedSpec where +import Data.Pool import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = beforeAll resetDb . around (withApp (cfgLimitRows 3) struct pool) $ diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 4cdfcf86f..2e8e72b50 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -1,19 +1,18 @@ module Feature.QuerySpec where +import Data.Pool import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = around (withApp cfgDefault struct pool) $ do describe "Querying a table with a column called count" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index a8e276272..c75cd4762 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -1,18 +1,17 @@ module Feature.RangeSpec where +import Data.Pool import Test.Hspec import Test.Hspec.Wai 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = beforeAll resetDb . around (withApp cfgDefault struct pool) $ describe "GET /items" $ do diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 3fca1ce3f..5e7054f31 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -1,18 +1,17 @@ module Feature.StructureSpec where +import Data.Pool 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 :: DbStructure -> Pool H.Connection -> Spec spec struct pool = around (withApp cfgDefault struct pool) $ do describe "GET /" $ do it "lists views in schema" $ diff --git a/test/Main.hs b/test/Main.hs index 81d483a62..234713bd0 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -18,7 +18,7 @@ main :: IO () main = do setupDb - pool <- specDbPool + pool <- testPool dbStructure <- specDbStructure pool -- Not using hspec-discover because we want to precompute diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index ea0de9db5..cbaaeb1a2 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -2,16 +2,8 @@ module SpecHelper where 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,44 @@ import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization, hAccept) import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..)) -import Data.Maybe (fromMaybe) +import Data.Pool 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 dbString :: String dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" -cfg :: String -> Maybe Int -> AppConfig +cfg :: String -> Maybe Integer -> AppConfig cfg conStr = AppConfig conStr 3000 "postgrest_test_anonymous" "test" (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 -> Pool H.Connection -> ActionWith Application -> IO () withApp config dbStructure pool perform = do - perform $ middle $ \req resp -> do + 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 (runWithClaims config time (app dbStructure config body) req) - where middle = defaultMiddle + withResource pool $ \c -> do + resOrError <- handleReq c + either (resp . pgErrResponse) resp resOrError setupDb :: IO () setupDb = do @@ -107,14 +86,6 @@ 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) +testPool :: IO (Pool (Either H.ConnectionError H.Connection)) +testPool = createPool (H.acquire . cs $ dbString) + (either (const $ return ()) H.release) 1 1 1 From b9fd083c772831106f82c055832cc70f15e2ffbd Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 21 Jan 2016 15:55:57 -0800 Subject: [PATCH 12/26] It all compiles but all requests give a postgres error --- test/Feature/AuthSpec.hs | 5 ++--- test/Feature/CorsSpec.hs | 5 ++--- test/Feature/DeleteSpec.hs | 7 +++---- test/Feature/InsertSpec.hs | 5 ++--- test/Feature/QueryLimitedSpec.hs | 7 +++---- test/Feature/QuerySpec.hs | 5 ++--- test/Feature/RangeSpec.hs | 7 +++---- test/Feature/StructureSpec.hs | 5 ++--- test/Main.hs | 35 ++++++++++++++++++-------------- test/SpecHelper.hs | 9 ++++---- 10 files changed, 43 insertions(+), 47 deletions(-) diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index fe77fb329..f678ae269 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -1,7 +1,6 @@ module Feature.AuthSpec where -- {{{ Imports -import Data.Pool import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -12,8 +11,8 @@ import SpecHelper import PostgREST.Types (DbStructure(..)) -- }}} -spec :: DbStructure -> Pool H.Connection -> 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 index a59e71b6e..811af712a 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -1,7 +1,6 @@ module Feature.CorsSpec where -- {{{ Imports -import Data.Pool import Test.Hspec import Test.Hspec.Wai import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) @@ -14,8 +13,8 @@ import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -- }}} -spec :: DbStructure -> Pool H.Connection -> 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 index 8f9f9761f..ba9c60eea 100644 --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -1,6 +1,5 @@ module Feature.DeleteSpec where -import Data.Pool import Test.Hspec import Test.Hspec.Wai import Text.Heredoc @@ -11,9 +10,9 @@ import qualified Hasql.Connection as H import Network.HTTP.Types -spec :: DbStructure -> Pool H.Connection -> 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 index 4a8478daf..54eb3be79 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -10,7 +10,6 @@ import PostgREST.Types (DbStructure(..)) import qualified Data.Aeson as JSON import Data.Maybe (fromJust) -import Data.Pool import Text.Heredoc import Network.HTTP.Types.Header import Network.HTTP.Types @@ -19,8 +18,8 @@ import qualified Hasql.Connection as H import TestTypes(IncPK(..), CompoundPK(..)) -spec :: DbStructure -> Pool H.Connection -> 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 it "accepts disparate json types" $ do diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs index 50c404fb1..71e6aa714 100644 --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -1,6 +1,5 @@ module Feature.QueryLimitedSpec where -import Data.Pool import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -11,10 +10,10 @@ import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) -spec :: DbStructure -> Pool H.Connection -> Spec -spec struct pool = +spec :: DbStructure -> H.Connection -> Spec +spec struct c = beforeAll resetDb - . around (withApp (cfgLimitRows 3) struct pool) $ + . around (withApp (cfgLimitRows 3) struct c) $ describe "Requesting many items with server limits enabled" $ do it "restricts results" $ get "/items" diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 2e8e72b50..4de2b6061 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -1,6 +1,5 @@ module Feature.QuerySpec where -import Data.Pool import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -12,8 +11,8 @@ import SpecHelper import PostgREST.Types (DbStructure(..)) import Text.Heredoc -spec :: DbStructure -> Pool H.Connection -> 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" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index c75cd4762..0ab998712 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -1,6 +1,5 @@ module Feature.RangeSpec where -import Data.Pool import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -11,9 +10,9 @@ import qualified Hasql.Connection as H import SpecHelper import PostgREST.Types (DbStructure(..)) -spec :: DbStructure -> Pool H.Connection -> 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 index 5e7054f31..6fe0a80e4 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -1,6 +1,5 @@ module Feature.StructureSpec where -import Data.Pool import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -11,8 +10,8 @@ import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -spec :: DbStructure -> Pool H.Connection -> 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 "/" [] "" diff --git a/test/Main.hs b/test/Main.hs index 234713bd0..19fff8523 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,7 +3,10 @@ module Main where import Test.Hspec import SpecHelper ---import PostgREST.Types (DbStructure(..)) +import Data.Pool +import qualified Hasql.Session as H + +import PostgREST.DbStructure (getDbStructure) import qualified Feature.AuthSpec import qualified Feature.CorsSpec @@ -19,19 +22,21 @@ main = do setupDb pool <- testPool - 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 + withResource pool $ \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 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 index cbaaeb1a2..11dd12d2a 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -38,17 +38,16 @@ cfgDefault = cfg dbString Nothing cfgLimitRows :: Integer -> AppConfig cfgLimitRows = cfg dbString . Just -withApp :: AppConfig -> DbStructure -> Pool H.Connection +withApp :: AppConfig -> DbStructure -> H.Connection -> ActionWith Application -> IO () -withApp config dbStructure pool perform = do +withApp config dbStructure c perform = do perform $ defaultMiddle $ \req resp -> do time <- getPOSIXTime body <- strictRequestBody req let handleReq = H.run (runWithClaims config time (app dbStructure config body) req) - withResource pool $ \c -> do - resOrError <- handleReq c - either (resp . pgErrResponse) resp resOrError + resOrError <- handleReq c + either (resp . pgErrResponse) resp resOrError setupDb :: IO () setupDb = do From 3be04d7f30ca581e4d77fa7c4f6260d024c7b2c3 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 22 Jan 2016 09:49:52 -0800 Subject: [PATCH 13/26] Upgrade hasql to fix connection error --- postgrest.cabal | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 89d831cb4..4f0d3203c 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -38,7 +38,7 @@ executable postgrest , containers , contravariant , errors - , hasql >= 0.19.3.1 && < 0.20 + , hasql >= 0.19.3.2 && < 0.20 , interpolatedstring-perl6 , jwt , optparse-applicative >= 0.11 && < 0.13 diff --git a/stack.yaml b/stack.yaml index f9f57e7b1..ec993a8af 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ flags: {} packages: - '.' extra-deps: - - hasql-0.19.3.1 + - hasql-0.19.3.2 - Ranged-sets-0.3.0 - packdeps-0.4.1 resolver: lts-4.1 From 8b13e7dd7377c2cfab0e7f2049a1f905d7409db5 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 22 Jan 2016 11:47:55 -0800 Subject: [PATCH 14/26] Header cannot be null even when it is n/a --- src/PostgREST/QueryBuilder.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 54316f09e..ea082642f 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -102,7 +102,7 @@ createReadStatement selectQuery countQuery range isSingle countTotal asCsv = cols = intercalate ", " [ countResultF <> " AS total_result_set", "pg_catalog.count(t) AS page_total", - "null AS header", + "'' AS header", bodyF <> " AS body" ] bodyF From ac73e8d77b6b586106f56f2579e15d5009393fb4 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 22 Jan 2016 11:53:47 -0800 Subject: [PATCH 15/26] Remove connection pooling in test --- test/Main.hs | 7 ++++--- test/SpecHelper.hs | 4 ---- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 19fff8523..6256f5d98 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,10 +3,11 @@ module Main where import Test.Hspec import SpecHelper -import Data.Pool 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 @@ -21,14 +22,14 @@ main :: IO () main = do setupDb - pool <- testPool - withResource pool $ \case + 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 conn dbStructure = do diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 11dd12d2a..4d53839c3 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -84,7 +84,3 @@ authHeaderBasic u p = authHeaderJWT :: String -> Header authHeaderJWT token = (hAuthorization, cs $ "Bearer " ++ token) - -testPool :: IO (Pool (Either H.ConnectionError H.Connection)) -testPool = createPool (H.acquire . cs $ dbString) - (either (const $ return ()) H.release) 1 1 1 From 51f71eb53d62cb5201a0ec5746a6ee26a4a5fc2b Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 23 Jan 2016 12:10:00 -0800 Subject: [PATCH 16/26] Run queries in a transaction again --- src/PostgREST/Main.hs | 4 +++- src/PostgREST/QueryBuilder.hs | 20 ++++++++++++++++++++ test/SpecHelper.hs | 4 +++- 3 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index a4075e3f2..dcfb4e4ee 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -11,6 +11,7 @@ import PostgREST.Config (AppConfig (..), import PostgREST.DbStructure import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Middleware +import PostgREST.QueryBuilder (inTransaction, Isolation(..)) import Control.Monad (unless, void) import Data.Monoid ((<>)) @@ -94,7 +95,8 @@ main = do runSettings appSettings $ middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req - let handleReq = H.run (runWithClaims conf time (app dbStructure conf body) req) + 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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index ea082642f..4eb7d2dee 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -18,6 +18,7 @@ module PostgREST.QueryBuilder ( , callProc , createReadStatement , createWriteStatement + , inTransaction , operators , pgFmtIdent , pgFmtLit @@ -26,9 +27,11 @@ module PostgREST.QueryBuilder ( , sourceCTEName , unquoted , ResultsWithCount + , Isolation(..) ) where import qualified Hasql.Query as H +import qualified Hasql.Session as H import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD @@ -501,3 +504,20 @@ pgFmtAsJsonPath (Just xx) = " AS " <> last xx 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 "end;" + return r + where + isolate = case lvl of + ReadCommitted -> "ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ" + Serializable -> "ISOLATION LEVEL SERIALIZABLE" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 4d53839c3..6e5edcb40 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -25,6 +25,7 @@ import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(pgErrResponse) import PostgREST.Types +import PostgREST.QueryBuilder (inTransaction, Isolation(..)) dbString :: String dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" @@ -44,7 +45,8 @@ withApp config dbStructure c perform = do perform $ defaultMiddle $ \req resp -> do time <- getPOSIXTime body <- strictRequestBody req - let handleReq = H.run (runWithClaims config time (app dbStructure config body) req) + let handleReq = H.run $ inTransaction ReadCommitted + (runWithClaims config time (app dbStructure config body) req) resOrError <- handleReq c either (resp . pgErrResponse) resp resOrError From 1f557a92a4d1b4120cdd0544233c7c80810616ed Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 23 Jan 2016 12:11:06 -0800 Subject: [PATCH 17/26] Pass query args properly --- src/PostgREST/DbStructure.hs | 8 ++++---- src/PostgREST/QueryBuilder.hs | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index dc620ed1d..1c8738781 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -111,8 +111,8 @@ doesProcExist = 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 :: H.Query QualifiedIdentifier Bool @@ -124,8 +124,8 @@ doesProcReturnJWT = 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' ) |] diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 4eb7d2dee..8f1916c99 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -53,7 +53,7 @@ import Data.Tree (Tree(..)) import qualified Data.Vector as V import PostgREST.Types import qualified Data.Map as M -import Text.InterpolatedString.Perl6 (qc, q) +import Text.InterpolatedString.Perl6 (qc) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Data.Scientific ( FPFormat (..) @@ -210,8 +210,8 @@ callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value) callProc qi params = H.statement sql HE.unit decodeObj True where - sql = [q| SELECT array_to_json( - coalesce(array_agg(row_to_json(t)), '{}') + 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) From a0b390e73548d348be1b2e15f8adf33297ba99d7 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 23 Jan 2016 12:11:46 -0800 Subject: [PATCH 18/26] Avoid possibilities of null for our chosen decoder --- src/PostgREST/QueryBuilder.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 8f1916c99..78b5b45bd 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -123,7 +123,7 @@ createWriteStatement _ _ mutateQuery _ None where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery}) - SELECT null, 0, null, null |] + SELECT '', 0, '', '' |] createWriteStatement qi _ mutateQuery isSingle HeadersOnly pKeys _ (PayloadJSON (UniformObjects _)) = @@ -134,10 +134,10 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly SELECT {cols} FROM (SELECT 1 FROM {sourceCTEName}) t |] cols = intercalate ", " [ - "null AS total_result_set", + "'' AS total_result_set", "pg_catalog.count(t) AS page_total", - if isSingle then locationF pKeys else "null", - "null" + if isSingle then locationF pKeys else "''", + "''" ] createWriteStatement qi selectQuery mutateQuery isSingle Full @@ -149,9 +149,9 @@ createWriteStatement qi selectQuery mutateQuery isSingle Full SELECT {cols} FROM ({selectQuery}) t |] cols = intercalate ", " [ - "null AS total_result_set", -- when updateing it does not make sense + "'' 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" ] bodyF @@ -387,7 +387,7 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF 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 " From bbf8365cd22ede5a731deeec688d39df21903c24 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 09:45:21 -0800 Subject: [PATCH 19/26] Upgrade hasql --- postgrest.cabal | 2 +- stack.yaml | 2 +- test/SpecHelper.hs | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 4f0d3203c..049c660a5 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -38,7 +38,7 @@ executable postgrest , containers , contravariant , errors - , hasql >= 0.19.3.2 && < 0.20 + , hasql >= 0.19.3.3 && < 0.20 , interpolatedstring-perl6 , jwt , optparse-applicative >= 0.11 && < 0.13 diff --git a/stack.yaml b/stack.yaml index ec993a8af..167bdfc4f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ flags: {} packages: - '.' extra-deps: - - hasql-0.19.3.2 + - hasql-0.19.3.3 - Ranged-sets-0.3.0 - packdeps-0.4.1 resolver: lts-4.1 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 6e5edcb40..40be3e9bc 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -11,7 +11,6 @@ import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization, hAccept) import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..)) -import Data.Pool import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import System.Process (readProcess) From 616541aaee23f35ed8151ca43f83b7aea3de34aa Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 15:57:55 -0800 Subject: [PATCH 20/26] Use reorder-goals in CI to make vanilla cabal work --- circle.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/circle.yml b/circle.yml index fe35c157e..f512b7ad7 100644 --- a/circle.yml +++ b/circle.yml @@ -8,7 +8,7 @@ dependencies: override: - cabal update - cabal sandbox init - - cabal install --upgrade-dependencies --constraint="template-haskell installed" --dependencies-only --enable-tests + - cabal install --upgrade-dependencies --constraint="template-haskell installed" --dependencies-only --enable-tests --reorder-goals - cabal configure --enable-tests -f ci test: post: From cbb2ba7d4280a34b813c6cf69fa59a2fb8a76e96 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 17:05:46 -0800 Subject: [PATCH 21/26] Appease hlint --- src/PostgREST/App.hs | 10 +++++----- src/PostgREST/Auth.hs | 4 ++-- src/PostgREST/DbStructure.hs | 16 ++++++++-------- src/PostgREST/QueryBuilder.hs | 18 +++++++++--------- 4 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 2012ea65f..623a5890f 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -86,7 +86,7 @@ app dbStructure conf reqBody req = else responseLBS status200 [contentTypeH] (cs body) else do let frm = toInteger $ rangeOffset range - to = frm+(toInteger queryTotal)-1 + 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)? @@ -138,7 +138,7 @@ app dbStructure conf reqBody req = Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let emptyUniform = UniformObjects V.empty - let fakeload = PayloadJSON $ emptyUniform + let fakeload = PayloadJSON emptyUniform let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload row <- H.query emptyUniform stm let (_, queryTotal, _, _) = extractQueryResult row @@ -151,7 +151,7 @@ app dbStructure conf reqBody req = 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 sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb filterCol _ _ _ = False return $ responseLBS status200 [jsonH, allOrigins] $ cs body @@ -166,7 +166,7 @@ app dbStructure conf reqBody req = bodyJson <- H.query () (callProc qi p) returnJWT <- H.query qi doesProcReturnJWT return $ responseLBS status200 [jsonH] - (let body = fromMaybe emptyArray $ bodyJson in + (let body = fromMaybe emptyArray bodyJson in if returnJWT then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" else cs $ encode body) @@ -293,7 +293,7 @@ buildMutateRequest apiRequest = 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 diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 5cf3972e1..6a79a88cd 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -66,9 +66,9 @@ jwtClaims secret input time = claim prop = prop . JWT.claims <$> decoded customClaims = claim JWT.unregisteredClaims --- | Receives the name of a role and returns a SET ROLE statement +{-| Receives the name of a role and returns a SET ROLE statement -} setRole :: Text -> BS.ByteString -setRole role = "set local role " <> cs (pgFmtLit role) <> ";" +setRole r = "set local role " <> cs (pgFmtLit r) <> ";" {-| diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 1c8738781..26a55e939 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -31,7 +31,7 @@ import Prelude getDbStructure :: Schema -> H.Session DbStructure getDbStructure schema = do - tabs <- H.query () $ allTables + tabs <- H.query () allTables cols <- H.query () $ allColumns tabs syns <- H.query () $ allSynonyms cols rels <- H.query () $ allRelations tabs cols @@ -172,9 +172,9 @@ addForeignKeys rels = map addFk 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 @@ -196,7 +196,7 @@ addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation 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' @@ -251,7 +251,7 @@ allTables = ORDER BY table_schema, table_name |] allColumns :: [Table] -> H.Query () [Column] -allColumns tabs = do +allColumns tabs = H.statement sql HE.unit (decodeColumns tabs) True where sql = [q| @@ -402,7 +402,7 @@ columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> tab parseEnum str = fromMaybe [] $ split (==',') <$> str allRelations :: [Table] -> [Column] -> H.Query () [Relation] -allRelations tabs cols = do +allRelations tabs cols = H.statement sql HE.unit (decodeRelations tabs cols) True where sql = [q| @@ -443,7 +443,7 @@ relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) = colsF = mapM (findCol frs frt) frcs allPrimaryKeys :: [Table] -> H.Query () [PrimaryKey] -allPrimaryKeys tabs = do +allPrimaryKeys tabs = H.statement sql HE.unit (decodePks tabs) True where sql = [q| @@ -553,7 +553,7 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs allSynonyms :: [Column] -> H.Query () [(Column,Column)] -allSynonyms cols = do +allSynonyms cols = H.statement sql HE.unit (decodeSynonyms cols) True where sql = [q| diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 78b5b45bd..f1c252cd9 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -187,9 +187,9 @@ addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest 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 query' = addCond updatedQuery (getJoinConditions rel) @@ -201,7 +201,7 @@ addJoinConditions schema (Node (query, (n, r)) forest) = 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 query' con = query'{flt_=con ++ flt_ query'} @@ -259,8 +259,8 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _)) ("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 @@ -305,19 +305,19 @@ requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nod 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<>"))) " From 75ebd1bd24335cb223682e9825cb5b601b302e35 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 17:22:11 -0800 Subject: [PATCH 22/26] Derp, it is "commit" not "end" --- src/PostgREST/QueryBuilder.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index f1c252cd9..5acfbd37b 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -514,7 +514,7 @@ inTransaction :: Isolation -> H.Session a -> H.Session a inTransaction lvl f = do H.sql $ "begin " <> isolate <> ";" r <- f - H.sql "end;" + H.sql "commit;" return r where isolate = case lvl of From f634b7fe98ceef8edc9fe539d6d7e9d593668b74 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 17:51:17 -0800 Subject: [PATCH 23/26] Rollback test connection on errors --- test/SpecHelper.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 40be3e9bc..3dc123bd6 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -47,8 +47,11 @@ withApp config dbStructure c perform = do let handleReq = H.run $ inTransaction ReadCommitted (runWithClaims config time (app dbStructure config body) req) - resOrError <- handleReq c - either (resp . pgErrResponse) resp resOrError + handleReq c >>= \case + Left err -> do + void $ H.run (H.sql "rollback;") c + resp $ pgErrResponse err + Right res -> resp res setupDb :: IO () setupDb = do From b85fc37130dfe3c7f44b5b6b0b8f2b62fdb8b6ad Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 17:51:37 -0800 Subject: [PATCH 24/26] Protect against nulls that choke our decoder --- src/PostgREST/QueryBuilder.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 5acfbd37b..0da811869 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -376,7 +376,7 @@ asCsvF :: SqlFragment 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 ( " <> @@ -390,7 +390,7 @@ asJsonF :: SqlFragment 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 = From 677c73cfe55d4e22ebbaa60df4a498fc3f61c638 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 24 Jan 2016 17:58:14 -0800 Subject: [PATCH 25/26] New versions of Warp do not export Connection --- postgrest.cabal | 2 +- src/PostgREST/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 049c660a5..8d855be62 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -58,7 +58,7 @@ executable postgrest , wai-cors , wai-extra , wai-middleware-static >= 0.6.0 - , warp >= 3.0.2 + , warp >= 3.1.0 , HTTP, http-types , MissingH , Ranged-sets diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index dcfb4e4ee..b0c038ca0 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -25,7 +25,7 @@ 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, From dac31c4f2eb8f38796aa1b35522424ee6f57c965 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 27 Jan 2016 11:00:40 -0800 Subject: [PATCH 26/26] Use newer LTS to avoid potential aeson problem --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 167bdfc4f..2adf4b173 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,5 +4,5 @@ packages: extra-deps: - hasql-0.19.3.3 - Ranged-sets-0.3.0 - - packdeps-0.4.1 -resolver: lts-4.1 + - packdeps-0.4.2.1 +resolver: lts-5.0