version changed to 3, circle ci to use ghc 7.10.1, stricter import/export in PgQuery and remove of dead code
This commit is contained in:
Ruslan Talpa
+161
-156
@@ -3,14 +3,57 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module PostgREST.PgQuery where
|
||||
module PostgREST.PgQuery (
|
||||
fromQi
|
||||
, insertableValue
|
||||
, wrapQuery
|
||||
, asJson
|
||||
, callProc
|
||||
, iffNotT
|
||||
, update
|
||||
, insertSelect
|
||||
, deleteFrom
|
||||
, asCsvWithCount
|
||||
, asJsonWithCount
|
||||
, unquoted
|
||||
|
||||
-- format functions
|
||||
, pgFmtLit
|
||||
, pgFmtIdent
|
||||
, pgFmtValue
|
||||
, pgFmtCondition
|
||||
, pgFmtColumn
|
||||
, pgFmtJsonPath
|
||||
, pgFmtTable
|
||||
, pgFmtField
|
||||
, pgFmtSelectItem
|
||||
, pgFmtAsJsonPath
|
||||
|
||||
-- query transformers (to be removed)
|
||||
, withT
|
||||
, countT
|
||||
, returningStarT
|
||||
, whereT
|
||||
|
||||
-- query fragments
|
||||
, orderF
|
||||
, countNoneF
|
||||
, countAllF
|
||||
, countF
|
||||
, locationF
|
||||
, asCsvF
|
||||
, asJsonSingleF
|
||||
, asJsonF
|
||||
|
||||
, 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 (OrderTerm (..), QualifiedIdentifier(..))
|
||||
import PostgREST.Types
|
||||
|
||||
import Control.Monad (join)
|
||||
import qualified Data.Aeson as JSON
|
||||
@@ -25,7 +68,6 @@ import Data.Scientific (FPFormat (..), formatScientific,
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import Data.Vector (empty)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Network.HTTP.Types.URI as Net
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
@@ -37,14 +79,12 @@ instance Monoid PStmt where
|
||||
B.Stmt (query <> query') (params <> params') (prep && prep')
|
||||
mempty = B.Stmt "" empty True
|
||||
type StatementT = PStmt -> PStmt
|
||||
|
||||
|
||||
limitT :: Maybe NonnegRange -> StatementT
|
||||
limitT r q =
|
||||
q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
|
||||
where
|
||||
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
|
||||
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
|
||||
data JsonbPath =
|
||||
ColIdentifier T.Text
|
||||
| KeyIdentifier T.Text
|
||||
| SingleArrow JsonbPath JsonbPath
|
||||
| DoubleArrow JsonbPath JsonbPath
|
||||
deriving (Show)
|
||||
|
||||
whereT :: QualifiedIdentifier -> Net.Query -> StatementT
|
||||
whereT table params q =
|
||||
@@ -62,24 +102,6 @@ withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
|
||||
(ep <> wp)
|
||||
(epre && wpre)
|
||||
|
||||
orderT :: [OrderTerm] -> StatementT
|
||||
orderT ts q =
|
||||
if L.null ts
|
||||
then q
|
||||
else q <> B.Stmt " order by " empty True <> clause
|
||||
where
|
||||
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
|
||||
queryTerm :: OrderTerm -> PStmt
|
||||
queryTerm t = B.Stmt
|
||||
(" " <> cs (pgFmtIdent $ otTerm t) <> " "
|
||||
<> cs (otDirection t) <> " "
|
||||
<> maybe "" cs (otNullOrder t) <> " ")
|
||||
empty True
|
||||
|
||||
parentheticT :: StatementT
|
||||
parentheticT s =
|
||||
s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
|
||||
|
||||
iffNotT :: PStmt -> StatementT
|
||||
iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
|
||||
B.Stmt
|
||||
@@ -92,36 +114,9 @@ countT :: StatementT
|
||||
countT s =
|
||||
s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" }
|
||||
|
||||
countRows :: QualifiedIdentifier -> PStmt
|
||||
countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True
|
||||
|
||||
countNone :: PStmt
|
||||
countNone = B.Stmt "select null" empty True
|
||||
|
||||
asCsvWithCount :: QualifiedIdentifier -> StatementT
|
||||
asCsvWithCount table = withCount . asCsv table
|
||||
|
||||
{--
|
||||
WITH source AS (
|
||||
SELECT * FROM projects
|
||||
)
|
||||
SELECT
|
||||
(
|
||||
SELECT string_agg(k.kk, ',')
|
||||
FROM (
|
||||
SELECT json_object_keys(j)::TEXT as kk
|
||||
FROM (
|
||||
SELECT row_to_json(source) as j from source limit 1
|
||||
) l
|
||||
) k
|
||||
)
|
||||
|| '\r' ||
|
||||
coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '')
|
||||
FROM (
|
||||
SELECT * FROM source
|
||||
) t;
|
||||
--}
|
||||
|
||||
asCsv :: QualifiedIdentifier -> StatementT
|
||||
asCsv table s = s {
|
||||
B.stmtTemplate =
|
||||
@@ -143,34 +138,12 @@ asJson s = s {
|
||||
withCount :: StatementT
|
||||
withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
|
||||
|
||||
asJsonRow :: StatementT
|
||||
asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
|
||||
|
||||
returningStarT :: StatementT
|
||||
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
|
||||
deleteFrom :: QualifiedIdentifier -> PStmt
|
||||
deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
|
||||
|
||||
insertInto :: QualifiedIdentifier
|
||||
-> V.Vector T.Text
|
||||
-> V.Vector (V.Vector JSON.Value)
|
||||
-> PStmt
|
||||
insertInto t cols vals
|
||||
| V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
| otherwise = B.Stmt
|
||||
("insert into " <> fromQi t <> " (" <>
|
||||
T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
|
||||
") values "
|
||||
<> T.intercalate ", "
|
||||
(V.toList $ V.map (\v -> "("
|
||||
<> T.intercalate ", " (V.toList $ V.map insertableValue v)
|
||||
<> ")"
|
||||
) vals
|
||||
)
|
||||
<> " returning row_to_json(" <> fromQi t <> ".*)")
|
||||
empty True
|
||||
|
||||
insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
insertSelect t [] _ = B.Stmt
|
||||
("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
@@ -200,7 +173,7 @@ callProc qi params = do
|
||||
wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
|
||||
wherePred table (col, predicate) =
|
||||
B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList value
|
||||
if opCode `elem` ["is","isnot"] then whiteList val
|
||||
else cs sqlValue)
|
||||
empty True
|
||||
|
||||
@@ -209,60 +182,18 @@ wherePred table (col, predicate) =
|
||||
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
opCode = hasNot (head rest) headPredicate
|
||||
notOp = hasNot headPredicate ""
|
||||
value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||
sqlValue = pgFmtValue opCode value
|
||||
val = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||
sqlValue = pgFmtValue opCode val
|
||||
op = pgFmtOperator opCode
|
||||
|
||||
|
||||
whiteList :: T.Text -> T.Text
|
||||
whiteList val = fromMaybe
|
||||
(cs (pgFmtLit val) <> "::unknown ")
|
||||
(L.find ((==) . T.toLower $ val) ["null","true","false"])
|
||||
|
||||
pgFmtValue :: T.Text -> T.Text -> T.Text
|
||||
pgFmtValue opCode value =
|
||||
case opCode of
|
||||
"like" -> unknownLiteral $ T.map star value
|
||||
"ilike" -> unknownLiteral $ T.map star value
|
||||
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||
"notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||
"@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
|
||||
_ -> unknownLiteral value
|
||||
where
|
||||
star c = if c == '*' then '%' else c
|
||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||
|
||||
pgFmtOperator :: T.Text -> T.Text
|
||||
pgFmtOperator opCode =
|
||||
case opCode of
|
||||
"eq" -> "="
|
||||
"gt" -> ">"
|
||||
"lt" -> "<"
|
||||
"gte" -> ">="
|
||||
"lte" -> "<="
|
||||
"neq" -> "<>"
|
||||
"like"-> "like"
|
||||
"ilike"-> "ilike"
|
||||
"in" -> "in"
|
||||
"notin" -> "not in"
|
||||
"is" -> "is"
|
||||
"isnot" -> "is not"
|
||||
"@@" -> "@@"
|
||||
_ -> "="
|
||||
|
||||
commaq :: PStmt
|
||||
commaq = B.Stmt ", " empty True
|
||||
|
||||
andq :: PStmt
|
||||
andq = B.Stmt " and " empty True
|
||||
|
||||
data JsonbPath =
|
||||
ColIdentifier T.Text
|
||||
| KeyIdentifier T.Text
|
||||
| SingleArrow JsonbPath JsonbPath
|
||||
| DoubleArrow JsonbPath JsonbPath
|
||||
deriving (Show)
|
||||
|
||||
parseJsonbPath :: T.Text -> Maybe JsonbPath
|
||||
parseJsonbPath p =
|
||||
case T.splitOn "->>" p of
|
||||
@@ -273,35 +204,6 @@ parseJsonbPath p =
|
||||
(KeyIdentifier b)
|
||||
_ -> Nothing
|
||||
|
||||
pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text
|
||||
pgFmtJsonbPath table p =
|
||||
pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
|
||||
where
|
||||
pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i
|
||||
pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i
|
||||
pgFmtJsonbPath' (SingleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b
|
||||
pgFmtJsonbPath' (DoubleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b
|
||||
|
||||
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
|
||||
|
||||
trimNullChars :: T.Text -> T.Text
|
||||
trimNullChars = T.takeWhile (/= '\x0')
|
||||
|
||||
@@ -325,10 +227,6 @@ insertableValue :: JSON.Value -> T.Text
|
||||
insertableValue JSON.Null = "null"
|
||||
insertableValue v = insertableText $ unquoted v
|
||||
|
||||
paramFilter :: JSON.Value -> T.Text
|
||||
paramFilter JSON.Null = "is.null"
|
||||
paramFilter v = "eq." <> unquoted v
|
||||
|
||||
wrapQuery :: T.Text -> [T.Text] -> Maybe NonnegRange -> T.Text
|
||||
wrapQuery source selectColumns range =
|
||||
withSourceF source <>
|
||||
@@ -337,6 +235,8 @@ wrapQuery source selectColumns range =
|
||||
" " <>
|
||||
fromF ( limitF range )
|
||||
|
||||
|
||||
-- query fragments
|
||||
withSourceF :: T.Text -> T.Text
|
||||
withSourceF s = "WITH source AS (" <> s <>")"
|
||||
|
||||
@@ -406,3 +306,108 @@ orderF ts =
|
||||
<> 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 =
|
||||
case opCode of
|
||||
"eq" -> "="
|
||||
"gt" -> ">"
|
||||
"lt" -> "<"
|
||||
"gte" -> ">="
|
||||
"lte" -> "<="
|
||||
"neq" -> "<>"
|
||||
"like"-> "like"
|
||||
"ilike"-> "ilike"
|
||||
"in" -> "in"
|
||||
"notin" -> "not in"
|
||||
"is" -> "is"
|
||||
"isnot" -> "is not"
|
||||
"@@" -> "@@"
|
||||
_ -> "="
|
||||
|
||||
pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text
|
||||
pgFmtJsonbPath table p =
|
||||
pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
|
||||
where
|
||||
pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i
|
||||
pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i
|
||||
pgFmtJsonbPath' (SingleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b
|
||||
pgFmtJsonbPath' (DoubleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b
|
||||
|
||||
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 ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc
|
||||
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user