Refactor to add operators in just one place, @> and <@ operators for #338 and #181

src/PostgREST/App.hs

@@ -20,12 +20,10 @@ import           Data.List                 (find, sortBy, delete, transpose)
 import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing, mapMaybe)
 import           Data.Ord                  (comparing)
 import           Data.Ranged.Ranges        (emptyRange)
---import qualified Data.Set                  as S
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
 import           Data.Tree
 import qualified Data.Map as M
---import           Data.Foldable             (forlrM)
 
 import           Text.Parsec.Error
 import           Text.ParserCombinators.Parsec (parse)
@@ -109,30 +107,6 @@ app dbstructure conf reqBody req =
         request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
         fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
 
-    -- ([table], "PUT") ->
-    --   handleJsonObj reqBody $ \obj -> do
-    --     let qt = qualify table
-    --         pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-    --         specifiedKeys = map (cs . fst) qq
-    --     if S.fromList pKeys /= S.fromList specifiedKeys
-    --       then return $ responseLBS status405 []
-    --         "You must speficy all and only primary keys as params"
-    --       else do
-    --         let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
-    --             cols = map cs $ HM.keys obj
-    --         if S.fromList tableCols == S.fromList cols
-    --           then do
-    --             let vals = HM.elems obj
-    --             H.unitEx $ iffNotT
-    --               (whereT qt qq $ update qt cols vals)
-    --               (insertSelect qt cols vals)
-    --             return $ responseLBS status204 [ jsonH ] ""
-    --
-    --           else return $ if Prelude.null tableCols
-    --             then responseLBS status404 [] ""
-    --             else responseLBS status400 []
-    --               "You must specify all columns in PUT request"
-
     ([table], "PATCH") -> do
       let echoRequested = hasPrefer "return=representation"
       case request of
@@ -269,23 +243,6 @@ contentTypeForAccept accept
     findInAccept = flip find $ parseHttpAccept acceptH
     has          = isJust . findInAccept . BS.isPrefixOf
 
--- handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
---               -> H.Tx P.Postgres s Response
--- handleJsonObj reqBody handler = do
---   let p = eitherDecode reqBody
---   case p of
---     Left err ->
---       return $ responseLBS status400 [jsonH] jErr
---       where
---         jErr = encode . object $
---           [("message", String $ "Failed to parse JSON payload. " <> cs err)]
---     Right (Object o) -> handler o
---     Right _ ->
---       return $ responseLBS status400 [jsonH] jErr
---       where
---         jErr = encode . object $
---           [("message", String "Expecting a JSON object")]
-
 parseCsvCell :: BL.ByteString -> Value
 parseCsvCell s = if s == "NULL" then Null else String $ cs s
 

src/PostgREST/Parsers.hs

@@ -4,16 +4,14 @@ module PostgREST.Parsers
 where
 
 import           Control.Applicative hiding ((<$>))
---import           Control.Monad                 (join)
---import           Data.List                     (delete, find)
---import           Data.Maybe
 import           Data.Monoid
 import           Data.String.Conversions       (cs)
 import           Data.Text                     (Text)
 import           Data.Tree
---import           Network.Wai                   (Request, pathInfo, queryString)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
+import           PostgREST.PgQuery (operators)
+
 
 pRequestSelect :: Text -> Parser ApiRequest
 pRequestSelect rootNodeName = do
@@ -50,8 +48,6 @@ pTreePath = do
   let pp = map cs p
       jpp = map cs <$> jp
   return (init pp, (last pp, jpp))
-  where
-
 
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
@@ -84,22 +80,8 @@ pSelect = lexeme $
     return ((s, Nothing), Nothing)
 
 pOperator :: Parser Operator
-pOperator = cs <$> ( try (string "lte") -- has to be before lt
+pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
-     <|> try (string "lt")
+  where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators
-     <|> try (string "eq")
-     <|> try (string "gte") -- has to be before gh
-     <|> try (string "gt")
-     <|> try (string "lt")
-     <|> try (string "neq")
-     <|> try (string "like")
-     <|> try (string "ilike")
-     <|> try (string "in")
-     <|> try (string "notin")
-     <|> try (string "is" )
-     <|> try (string "isnot")
-     <|> try (string "@@")
-     <?> "operator (eq, gt, ...)"
-     )
 
 pValue :: Parser FValue
 pValue = VText <$> (cs <$> many anyChar)

src/PostgREST/PgQuery.hs

@@ -9,13 +9,8 @@ module PostgREST.PgQuery (
 , wrapQuery
 , asJson
 , callProc
--- , iffNotT
--- , update
--- , insertSelect
--- , deleteFrom
--- , asCsvWithCount
--- , asJsonWithCount
 , unquoted
+, operators
 
 -- format functions
 , pgFmtLit
@@ -29,12 +24,6 @@ module PostgREST.PgQuery (
 , pgFmtSelectItem
 , pgFmtAsJsonPath
 
--- query transformers (to be removed)
--- , withT
--- , countT
--- , returningStarT
--- , whereT
-
 -- query fragments
 , sourceSubqueryName
 , orderF
@@ -70,7 +59,6 @@ import           Data.Scientific         (FPFormat (..), formatScientific,
 import           Data.String.Conversions (cs)
 import qualified Data.Text               as T
 import           Data.Vector             (empty)
---import qualified Network.HTTP.Types.URI  as Net
 import           Text.Regex.TDFA         ((=~))
 
 import           Prelude
@@ -89,100 +77,34 @@ data JsonbPath =
   | DoubleArrow JsonbPath JsonbPath
   deriving (Show)
 
-operators :: M.Map T.Text T.Text
+
-operators = M.fromList [
+operators :: [(T.Text, T.Text)]
+operators = [
   ("eq", "="),
+  ("gte", ">="), -- has to be before gt (parsers)
   ("gt", ">"),
+  ("lte", "<="), -- has to be before lt (parsers)
   ("lt", "<"),
-  ("gte", ">="),
-  ("lte", "<="),
   ("neq", "<>"),
   ("like", "like"),
   ("ilike", "ilike"),
   ("in", "in"),
   ("notin", "not in"),
+  ("isnot", "is not"), -- has to be before is (parsers)
   ("is", "is"),
-  ("isnot", "is not"),
+  ("@@", "@@"),
-  ("@@", "@@")
+  ("@>", "@>"),
+  ("<@", "<@")
   ]
 
+operatorsMap :: M.Map T.Text T.Text
+operatorsMap = M.fromList operators
 
--- whereT :: QualifiedIdentifier -> Net.Query -> StatementT
--- whereT table params q =
---   if L.null cols
---     then q
---     else q <> B.Stmt " where " empty True <> conjunction
---   where
---     cols = [ col | col <- params, fst col `notElem` ["order","select"] ]
---     wherePredTable = wherePred table
---     conjunction = mconcat $ L.intersperse andq (map wherePredTable cols)
---
--- withT :: PStmt -> T.Text -> StatementT
--- withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
---   B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)
---     (ep <> wp)
---     (epre && wpre)
---
--- iffNotT :: PStmt -> StatementT
--- iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
---   B.Stmt
---     ("WITH aaa AS (" <> aq <> " returning *) " <>
---       bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
---     (ap <> bp)
---     (apre && bpre)
---
--- countT :: StatementT
--- countT s =
---   s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" }
---
--- asCsvWithCount :: QualifiedIdentifier -> StatementT
--- asCsvWithCount table = withCount . asCsv table
---
--- asCsv :: QualifiedIdentifier -> StatementT
--- asCsv table s = s {
---   B.stmtTemplate =
---     "(select string_agg(quote_ident(column_name::text), ',') from "
---     <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '"
---     <> fromQi table <> "' order by ordinal_position) h) || '\r' || "
---     <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from ("
---     <> B.stmtTemplate s <> ") t" }
---
--- asJsonWithCount :: StatementT
--- asJsonWithCount = withCount . asJson
---
 asJson :: StatementT
 asJson s = s {
   B.stmtTemplate =
     "array_to_json(array_agg(row_to_json(t)))::character varying from ("
     <> B.stmtTemplate s <> ") t" }
---
--- withCount :: StatementT
--- withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
---
--- returningStarT :: StatementT
--- returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
---
--- deleteFrom :: QualifiedIdentifier -> PStmt
--- deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
---
--- insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
--- insertSelect t [] _ = B.Stmt
---   ("insert into " <> fromQi t <> " default values returning *") empty True
--- insertSelect t cols vals = B.Stmt
---   ("insert into " <> fromQi t <> " ("
---     <> T.intercalate ", " (map pgFmtIdent cols)
---     <> ") select "
---     <> T.intercalate ", " (map insertableValue vals))
---   empty True
---
--- update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
--- update t cols vals = B.Stmt
---   ("update " <> fromQi t <> " set ("
---     <> T.intercalate ", " (map pgFmtIdent cols)
---     <> ") = ("
---     <> T.intercalate ", " (map insertableValue vals)
---     <> ")")
---   empty True
 
 callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
 callProc qi params = do
@@ -191,40 +113,11 @@ callProc qi params = do
   where
     assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
 
--- wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
--- wherePred table (col, predicate) =
---   B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
---       if opCode `elem` ["is","isnot"] then whiteList val
---                                  else cs sqlValue)
---       empty True
---
---   where
---     headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
---     hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
---     opCode        = hasNot (head rest) headPredicate
---     notOp         = hasNot headPredicate ""
---     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"])
 
--- andq :: PStmt
--- andq = B.Stmt " and " empty True
-
--- parseJsonbPath :: T.Text -> Maybe JsonbPath
--- parseJsonbPath p =
---   case T.splitOn "->>" p of
---     [a,b] ->
---       let i:is = T.splitOn "->" a in
---       Just $ DoubleArrow
---         (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
---         (KeyIdentifier b)
---     _ -> Nothing
-
 trimNullChars :: T.Text -> T.Text
 trimNullChars = T.takeWhile (/= '\x0')
 
@@ -350,18 +243,7 @@ pgFmtValue opCode val =
    unknownLiteral = (<> "::unknown ") . pgFmtLit
 
 pgFmtOperator :: T.Text -> T.Text
-pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operators
+pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap
-
--- 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 =

test/Feature/QuerySpec.hs

@@ -7,6 +7,8 @@ import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders))
 
 import SpecHelper
+import Text.Heredoc
+
 
 spec :: Spec
 spec =
@@ -135,11 +137,20 @@ spec =
       get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith`
         "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1,\"name\":\"Design w7\"}]},{\"id\":2,\"tasks\":[{\"id\":3,\"name\":\"Design w10\"}]}]},{\"id\":2,\"projects\":[{\"id\":3,\"tasks\":[{\"id\":5,\"name\":\"Design IOS\"}]},{\"id\":4,\"tasks\":[{\"id\":7,\"name\":\"Design OSX\"}]}]}]"
 
+    it "matches with @> operator" $
+      get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`
+        [str|[{"id":2},{"id":3}]|]
+
+    it "matches with <@ operator" $
+      get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith`
+        [str|[{"id":1},{"id":2}]|]
+
+
   describe "Shaping response with select parameter" $ do
 
     it "selectStar works in absense of parameter" $
       get "/complex_items?id=eq.3" `shouldRespondWith`
-        "[{\"id\":3,\"name\":\"Three\",\"settings\":{\"foo\":{\"int\":1,\"bar\":\"baz\"}}}]"
+        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3]}]|]
 
     it "one simple column" $
       get "/complex_items?select=id" `shouldRespondWith`

test/SpecHelper.hs

@@ -151,10 +151,11 @@ createComplexItems = do
   void . liftIO $ H.session pool $ H.tx Nothing txn
   where
     txn = mapM_ H.unitEx stmts
-    stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings) values (?,?,?)|]
+    stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings, arr_data) values (?,?,?,?)|]
         <$> ZipList ([1..3]::[Int])
         <*> ZipList (["One", "Two", "Three"]::[Text])
         <*> ZipList [jobj,jobj,jobj]
+        <*> ZipList ([[1], [1,2], [1,2,3]]::[[Int]])
     jobj = J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]
 
 createNulls :: Int -> IO ()

test/fixtures/schema.sql

@@ -204,7 +204,8 @@ ALTER TABLE test.items OWNER TO postgrest_test;
 CREATE TABLE complex_items (
     id bigint NOT NULL,
     name text,
-    settings json
+    settings json,
+    arr_data INTEGER[]
 );