diff --git a/postgrest.cabal b/postgrest.cabal index 9db15172a..c0b2b81ac 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -69,7 +69,6 @@ executable postgrest , PostgREST.Error , PostgREST.Middleware , PostgREST.Parsers - , PostgREST.PgQuery , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery @@ -133,7 +132,6 @@ library , PostgREST.Error , PostgREST.Middleware , PostgREST.Parsers - , PostgREST.PgQuery , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery @@ -164,7 +162,6 @@ Test-Suite spec , PostgREST.Error , PostgREST.Middleware , PostgREST.Parsers - , PostgREST.PgQuery , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a395353a3..5afd08278 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -45,9 +45,23 @@ import qualified Hasql.Postgres as P import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers -import PostgREST.PgQuery import PostgREST.DbStructure -import PostgREST.QueryBuilder +import PostgREST.QueryBuilder ( asJson + , callProc + , asCsvF + , asJsonF + , selectStarF + , countF + , locationF + , asJsonSingleF + , addJoinConditions + , sourceSubqueryName + , requestToQuery + , wrapQuery + , countAllF + , countNoneF + , addRelations + ) import PostgREST.RangeQuery import PostgREST.Types import PostgREST.Auth (tokenJWT) diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index a608b684c..22d7de82a 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -27,7 +27,7 @@ import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Time.Clock (NominalDiffTime) -import PostgREST.PgQuery (pgFmtLit, pgFmtIdent, unquoted) +import PostgREST.QueryBuilder (pgFmtLit, pgFmtIdent, unquoted) import qualified Web.JWT as JWT import qualified Data.HashMap.Lazy as H diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 7eda5dc8a..81c96b059 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -20,7 +20,6 @@ import Data.Text (Text, split) import qualified Hasql as H import qualified Hasql.Postgres as P import qualified Hasql.Backend as B -import PostgREST.PgQuery () import PostgREST.Types import GHC.Exts (groupWith) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 19ed87e8a..933b6d970 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -10,7 +10,7 @@ import Data.Text (Text) import Data.Tree import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) -import PostgREST.PgQuery (operators) +import PostgREST.QueryBuilder (operators) pRequestSelect :: Text -> Parser ApiRequest pRequestSelect rootNodeName = do diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs deleted file mode 100644 index b9da99a49..000000000 --- a/src/PostgREST/PgQuery.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PostgREST.PgQuery ( - fromQi -, insertableValue -, wrapQuery -, asJson -, callProc -, unquoted -, operators - --- format functions -, pgFmtLit -, pgFmtIdent -, pgFmtValue -, pgFmtCondition -, pgFmtColumn -, pgFmtJsonPath -, pgFmtTable -, pgFmtField -, pgFmtSelectItem -, pgFmtAsJsonPath - --- query fragments -, sourceSubqueryName -, orderF -, countNoneF -, countAllF -, countF -, locationF -, asCsvF -, asJsonSingleF -, asJsonF -, selectStarF - -, StatementT -) where - - -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import PostgREST.RangeQuery -import PostgREST.Types - -import Control.Monad (join) -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -import Data.Functor -import qualified Data.HashMap.Strict as H -import qualified Data.List as L -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Scientific (FPFormat (..), formatScientific, - isInteger) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import Data.Vector (empty) -import Text.Regex.TDFA ((=~)) - -import Prelude -import qualified Data.Map as M - -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 -data JsonbPath = - ColIdentifier T.Text - | KeyIdentifier T.Text - | SingleArrow JsonbPath JsonbPath - | DoubleArrow JsonbPath JsonbPath - deriving (Show) - - -operators :: [(T.Text, T.Text)] -operators = [ - ("eq", "="), - ("gte", ">="), -- has to be before gt (parsers) - ("gt", ">"), - ("lte", "<="), -- has to be before lt (parsers) - ("lt", "<"), - ("neq", "<>"), - ("like", "like"), - ("ilike", "ilike"), - ("in", "in"), - ("notin", "not in"), - ("isnot", "is not"), -- has to be before is (parsers) - ("is", "is"), - ("@@", "@@"), - ("@>", "@>"), - ("<@", "<@") - ] - -operatorsMap :: M.Map T.Text T.Text -operatorsMap = M.fromList operators - -asJson :: StatementT -asJson s = s { - B.stmtTemplate = - "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from (" - <> B.stmtTemplate s <> ") t" } - -callProc :: QualifiedIdentifier -> JSON.Object -> PStmt -callProc qi params = do - let args = T.intercalate "," $ map assignment (H.toList params) - B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True - where - assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v - -whiteList :: T.Text -> T.Text -whiteList val = fromMaybe - (cs (pgFmtLit val) <> "::unknown ") - (L.find ((==) . T.toLower $ val) ["null","true","false"]) - -trimNullChars :: T.Text -> T.Text -trimNullChars = T.takeWhile (/= '\x0') - -fromQi :: QualifiedIdentifier -> T.Text -fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n - where - n = qiName t - s = qiSchema t - -unquoted :: JSON.Value -> T.Text -unquoted (JSON.String t) = t -unquoted (JSON.Number n) = - cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n -unquoted (JSON.Bool b) = cs . show $ b -unquoted v = cs $ JSON.encode v - -insertableText :: T.Text -> T.Text -insertableText = (<> "::unknown") . pgFmtLit - -insertableValue :: JSON.Value -> T.Text -insertableValue JSON.Null = "null" -insertableValue v = insertableText $ unquoted v - -wrapQuery :: T.Text -> [T.Text] -> T.Text -> Maybe NonnegRange -> T.Text -wrapQuery source selectColumns returnSelect range = - withSourceF source <> - " SELECT " <> - T.intercalate ", " selectColumns <> - " " <> - fromF returnSelect ( limitF range ) - - --- query fragments -sourceSubqueryName :: T.Text -sourceSubqueryName = "pg_source" - -withSourceF :: T.Text -> T.Text -withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")" - -countF :: T.Text -countF = "pg_catalog.count(t)" - -countAllF :: T.Text -countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )" - -countNoneF :: T.Text -countNoneF = "null" - -asJsonF :: T.Text -asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying" - -asJsonSingleF :: T.Text --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 " - -asCsvF :: T.Text -asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF - -asCsvHeaderF :: T.Text -asCsvHeaderF = - "(SELECT string_agg(a.k, ',')" <> - " FROM (" <> - " SELECT json_object_keys(r)::TEXT as k" <> - " FROM ( " <> - " SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <> - " ) s" <> - " ) a" <> - ")" - -asCsvBodyF :: T.Text -asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" - -selectStarF :: T.Text -selectStarF = "SELECT * FROM " <> sourceSubqueryName - -fromF :: T.Text -> T.Text -> T.Text -fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t" - -limitF :: Maybe NonnegRange -> T.Text -limitF r = "LIMIT " <> limit <> " OFFSET " <> offset - where - limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r - offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r - -locationF :: [T.Text] -> T.Text -locationF pKeys = - "(" <> - " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <> - " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> - " FROM s, json_each_text(s.r) AS json_data" <> - ( - if null pKeys - then "" - else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')" - ) <> - ")" - -orderF :: [OrderTerm] -> T.Text -orderF ts = - if L.null ts - then "" - else "ORDER BY " <> clause - where - clause = T.intercalate "," (map queryTerm ts) - queryTerm :: OrderTerm -> T.Text - queryTerm t = " " - <> cs (pgFmtIdent $ otTerm t) <> " " - <> cs (otDirection t) <> " " - <> maybe "" cs (otNullOrder t) <> " " - --- formating functions - -pgFmtValue :: T.Text -> T.Text -> T.Text -pgFmtValue opCode val = - case opCode of - "like" -> unknownLiteral $ T.map star val - "ilike" -> unknownLiteral $ T.map star val - "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") " - "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") " - "@@" -> "to_tsquery(" <> unknownLiteral val <> ") " - _ -> unknownLiteral val - where - star c = if c == '*' then '%' else c - unknownLiteral = (<> "::unknown ") . pgFmtLit - -pgFmtOperator :: T.Text -> T.Text -pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap - -pgFmtIdent :: T.Text -> T.Text -pgFmtIdent x = - let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in - if (cs escaped :: BS.ByteString) =~ danger - then "\"" <> escaped <> "\"" - else escaped - - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString - -pgFmtLit :: T.Text -> T.Text -pgFmtLit x = - let trimmed = trimNullChars x - escaped = "'" <> T.replace "'" "''" trimmed <> "'" - slashed = T.replace "\\" "\\\\" escaped in - if T.isInfixOf "\\\\" escaped - then "E" <> slashed - else slashed - -pgFmtCondition :: QualifiedIdentifier -> Filter -> T.Text -pgFmtCondition table (Filter (col,jp) ops val) = - notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <> - if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue - where - headPredicate:rest = T.split (=='.') ops - hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate - notOp = hasNot headPredicate "" - sqlCol = case val of - VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp - VForeignKey qi _ -> pgFmtColumn qi col - sqlValue = valToStr val - getInner v = case v of - VText s -> s - _ -> "" - valToStr v = case v of - VText s -> pgFmtValue opCode s - VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc - where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft - _ -> "" - -pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text -pgFmtColumn table "*" = fromQi table <> ".*" -pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c - -pgFmtJsonPath :: Maybe JsonPath -> T.Text -pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x -pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) -pgFmtJsonPath _ = "" - -pgFmtTable :: Table -> T.Text -pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n - -pgFmtField :: QualifiedIdentifier -> Field -> T.Text -pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp - -pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> T.Text -pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp -pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp - -pgFmtAsJsonPath :: Maybe JsonPath -> T.Text -pgFmtAsJsonPath Nothing = "" -pgFmtAsJsonPath (Just xx) = " AS " <> last xx diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 13cc88e8d..ca442a00f 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,21 +1,156 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module PostgREST.QueryBuilder ( addRelations , addJoinConditions , requestToQuery + , callProc + , pgFmtLit + , pgFmtIdent + , unquoted + , wrapQuery + , operators + , asJson + , asJsonF + , asJsonSingleF + , asCsvF + , countF + , selectStarF + , locationF + , sourceSubqueryName + , countAllF + , countNoneF ) where +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P + +import qualified Data.Aeson as JSON + +import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error +import Control.Monad (join) import Data.List (find) import Data.Monoid -import Data.Text hiding (filter, find, foldr, head, last, map, - null, zipWith, concatMap) +import Data.Text (Text) +import qualified Data.Text as T +import Data.String.Conversions (cs) +import qualified Data.HashMap.Strict as H import Control.Applicative import Data.Tree -import PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem, pgFmtCondition, insertableValue - , orderF, pgFmtJsonPath, sourceSubqueryName, pgFmtIdent) import PostgREST.Types import qualified Data.Map as M +import Text.Regex.TDFA ((=~)) +import qualified Data.ByteString.Char8 as BS +import Data.Scientific (FPFormat (..), formatScientific, + isInteger) + +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 + +sourceSubqueryName :: T.Text +sourceSubqueryName = "pg_source" + +countAllF :: T.Text +countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )" + +countNoneF :: T.Text +countNoneF = "null" + +asCsvHeaderF :: T.Text +asCsvHeaderF = + "(SELECT string_agg(a.k, ',')" <> + " FROM (" <> + " SELECT json_object_keys(r)::TEXT as k" <> + " FROM ( " <> + " SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <> + " ) s" <> + " ) a" <> + ")" + +asCsvBodyF :: T.Text +asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" + +selectStarF :: T.Text +selectStarF = "SELECT * FROM " <> sourceSubqueryName + +locationF :: [T.Text] -> T.Text +locationF pKeys = + "(" <> + " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <> + " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> + " FROM s, json_each_text(s.r) AS json_data" <> + ( + if null pKeys + then "" + else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')" + ) <> + ")" + +countF :: T.Text +countF = "pg_catalog.count(t)" + +asJsonSingleF :: T.Text --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 " + +asJsonF :: T.Text +asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying" + +asCsvF :: T.Text +asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF + +asJson :: StatementT +asJson s = s { + B.stmtTemplate = + "array_to_json(array_agg(row_to_json(t)))::character varying from (" + <> B.stmtTemplate s <> ") t" } + +operators :: [(T.Text, T.Text)] +operators = [ + ("eq", "="), + ("gte", ">="), -- has to be before gt (parsers) + ("gt", ">"), + ("lte", "<="), -- has to be before lt (parsers) + ("lt", "<"), + ("neq", "<>"), + ("like", "like"), + ("ilike", "ilike"), + ("in", "in"), + ("notin", "not in"), + ("isnot", "is not"), -- has to be before is (parsers) + ("is", "is"), + ("@@", "@@"), + ("@>", "@>"), + ("<@", "<@") + ] + +wrapQuery :: T.Text -> [T.Text] -> T.Text -> Maybe NonnegRange -> T.Text +wrapQuery source selectColumns returnSelect range = + withSourceF source <> + " SELECT " <> + T.intercalate ", " selectColumns <> + " " <> + fromF returnSelect ( limitF range ) + +unquoted :: JSON.Value -> T.Text +unquoted (JSON.String t) = t +unquoted (JSON.Number n) = + cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n +unquoted (JSON.Bool b) = cs . show $ b +unquoted v = cs $ JSON.encode v + +callProc :: QualifiedIdentifier -> JSON.Object -> PStmt +callProc qi params = do + let args = T.intercalate "," $ map assignment (H.toList params) + B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True + where + assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) = @@ -31,21 +166,7 @@ addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) for where updatedForest = mapM (addRelations schema allRelations (Just node)) forest findRelation s t1 t2 = - find (\r -> s == tableSchema r && t1 == relTable r && t2 == relFTable r) allRelations - -getJoinConditions :: Relation -> [Filter] -getJoinConditions (Relation t cs ft fcs typ lt lc1 lc2) = - case typ of - Child -> zipWith (toFilter tN ftN) cs fcs - Parent -> zipWith (toFilter tN ftN) cs fcs - Many -> zipWith (toFilter tN ltN) cs (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2) - where - s = tableSchema t - tN = tableName t - ftN = tableName ft - ltN = fromMaybe "" (tableName <$> lt) - toFilter :: Text -> Text -> Column -> Column -> Filter - toFilter tb ftb c fc = Filter (colName c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})) + find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest addJoinConditions schema (Node (query, (n, r)) forest) = @@ -80,11 +201,11 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _) tblSchema tbl = if tbl == sourceSubqueryName then "" else schema qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl toQi t = QualifiedIdentifier (tblSchema t) t - query = Data.Text.unwords [ - ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), - "FROM ", intercalate ", " (map (fromQi . toQi) tbls), - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + query = T.unwords [ + ("WITH " <> T.intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", T.intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), + "FROM ", T.intercalate ", " (map (fromQi . toQi) tbls), + ("WHERE " <> T.intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, orderF (fromMaybe [] ord) ] (withs, selects) = foldr getQueryParts ([],[]) forest @@ -116,13 +237,13 @@ requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) = query where qi = QualifiedIdentifier schema mainTbl - query = Data.Text.unwords [ + query = T.unwords [ "INSERT INTO ", fromQi qi, - " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ", - "VALUES " <> intercalate ", " + " (" <> T.intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ", + "VALUES " <> T.intercalate ", " ( map (\v -> "(" <> - intercalate ", " ( map insertableValue v ) <> + T.intercalate ", " ( map insertableValue v ) <> ")" ) vals ), @@ -132,10 +253,10 @@ requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) = query where qi = QualifiedIdentifier schema mainTbl - query = Data.Text.unwords [ + query = T.unwords [ "UPDATE ", fromQi qi, - " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ", - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + " SET " <> T.intercalate ", " (map formatSet (M.toList setWith)) <> " ", + ("WHERE " <> T.intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, "RETURNING " <> fromQi qi <> ".*" ] formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v @@ -143,22 +264,153 @@ requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) = query where qi = QualifiedIdentifier schema mainTbl - query = Data.Text.unwords [ + query = T.unwords [ "DELETE FROM ", fromQi qi, - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + ("WHERE " <> T.intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, "RETURNING " <> fromQi qi <> ".*" ] -- private functions -getJoinConditions :: Relation -> [Filter] -getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) = - case typ of - Child -> zipWith (toFilter t ft) cs fcs - Parent -> zipWith (toFilter t ft) cs fcs - Many -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2) +fromQi :: QualifiedIdentifier -> T.Text +fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n where - toFilter :: Text -> Text -> FieldName -> FieldName -> Filter - toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc)) + n = qiName t + s = qiSchema t + +getJoinConditions :: Relation -> [Filter] +getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) = + case typ of + Child -> zipWith (toFilter tN ftN) cols fcs + Parent -> zipWith (toFilter tN ftN) cols fcs + Many -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2) + where + s = tableSchema t + tN = tableName t + ftN = tableName ft + ltN = fromMaybe "" (tableName <$> lt) + toFilter :: Text -> Text -> Column -> Column -> Filter + toFilter tb ftb c fc = Filter (colName c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})) emptyOnNull :: Text -> [a] -> Text emptyOnNull val x = if null x then "" else val + +orderF :: [OrderTerm] -> T.Text +orderF ts = + if null ts + then "" + else "ORDER BY " <> clause + where + clause = T.intercalate "," (map queryTerm ts) + queryTerm :: OrderTerm -> T.Text + queryTerm t = " " + <> cs (pgFmtIdent $ otTerm t) <> " " + <> cs (otDirection t) <> " " + <> maybe "" cs (otNullOrder t) <> " " + +insertableText :: T.Text -> T.Text +insertableText = (<> "::unknown") . pgFmtLit + +insertableValue :: JSON.Value -> T.Text +insertableValue JSON.Null = "null" +insertableValue v = insertableText $ unquoted v + +whiteList :: T.Text -> T.Text +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (find ((==) . T.toLower $ val) ["null","true","false"]) + + +-- formating functions +pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c + +pgFmtField :: QualifiedIdentifier -> Field -> T.Text +pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp + +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> T.Text +pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp +pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp + +pgFmtCondition :: QualifiedIdentifier -> Filter -> T.Text +pgFmtCondition table (Filter (col,jp) ops val) = + notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <> + if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue + where + headPredicate:rest = T.split (=='.') ops + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + sqlCol = case val of + VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp + VForeignKey qi _ -> pgFmtColumn qi col + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" + valToStr v = case v of + VText s -> pgFmtValue opCode s + VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc + where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft + _ -> "" + +pgFmtValue :: T.Text -> T.Text -> T.Text +pgFmtValue opCode val = + case opCode of + "like" -> unknownLiteral $ T.map star val + "ilike" -> unknownLiteral $ T.map star val + "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") " + "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") " + "@@" -> "to_tsquery(" <> unknownLiteral val <> ") " + _ -> unknownLiteral val + where + star c = if c == '*' then '%' else c + unknownLiteral = (<> "::unknown ") . pgFmtLit + +pgFmtOperator :: T.Text -> T.Text +pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap + +pgFmtIdent :: T.Text -> T.Text +pgFmtIdent x = + let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in + if (cs escaped :: BS.ByteString) =~ danger + then "\"" <> escaped <> "\"" + else escaped + + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString + +pgFmtLit :: T.Text -> T.Text +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> T.replace "'" "''" trimmed <> "'" + slashed = T.replace "\\" "\\\\" escaped in + if T.isInfixOf "\\\\" escaped + then "E" <> slashed + else slashed + +pgFmtJsonPath :: Maybe JsonPath -> T.Text +pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x +pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) +pgFmtJsonPath _ = "" + +pgFmtAsJsonPath :: Maybe JsonPath -> T.Text +pgFmtAsJsonPath Nothing = "" +pgFmtAsJsonPath (Just xx) = " AS " <> last xx + +operatorsMap :: M.Map T.Text T.Text +operatorsMap = M.fromList operators + +trimNullChars :: T.Text -> T.Text +trimNullChars = T.takeWhile (/= '\x0') + +withSourceF :: T.Text -> T.Text +withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")" + +fromF :: T.Text -> T.Text -> T.Text +fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t" + +limitF :: Maybe NonnegRange -> T.Text +limitF r = "LIMIT " <> limit <> " OFFSET " <> offset + where + limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r + offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r