jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'like'

Browse Source 
Fixes #132
This commit is contained in:
Joe Nelson
2015-02-15 17:37:40 -08:00
parent 5280b9fd6d fa48c86195
commit 92daa7d11a
9 changed files with 81 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
circle.yml
+1 -1
View File
@@ -6,5 +6,5 @@ machine:
version: 7.8.3
test:
post:
- cabal exec hlint src/*.hs test/**/*.hs
- cabal exec hlint -- -X QuasiQuotes src/*.hs test/**/*.hs
- cabal exec packdeps postgrest.cabal
postgrest.cabal
+2 -4
View File
@@ -17,8 +17,7 @@ executable postgrest
main-is: Main.hs
ghc-options: -Wall -W -O2
default-language: Haskell2010
default-extensions: OverloadedStrings, ScopedTypeVariables
other-extensions: QuasiQuotes
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes
build-depends: base >=4.6 && <5
, hasql == 0.7.*, hasql-backend
, hasql-postgres == 0.10.*
@@ -57,8 +56,7 @@ executable postgrest
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
default-extensions: OverloadedStrings, ScopedTypeVariables
other-extensions: QuasiQuotes
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes
Hs-Source-Dirs: test, src
ghc-options: -Wall -W -Werror
Main-Is: Main.hs
src/PgQuery.hs
+34 -29
View File
@@ -9,7 +9,7 @@ import qualified Hasql as H
import qualified Hasql.Postgres as P
import qualified Hasql.Backend as B
import Data.Text hiding (map, empty)
import qualified Data.Text as T
import Text.Regex.TDFA ( (=~) )
import Text.Regex.TDFA.Text ()
import qualified Network.HTTP.Types.URI as Net
@@ -32,12 +32,12 @@ instance Monoid PStmt where
type StatementT = PStmt -> PStmt
data QualifiedTable = QualifiedTable {
qtSchema :: Text
, qtName :: Text
qtSchema :: T.Text
, qtName :: T.Text
} deriving (Show)
data OrderTerm = OrderTerm {
otTerm :: Text
otTerm :: T.Text
, otDirection :: BS.ByteString
}
@@ -106,33 +106,33 @@ returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
deleteFrom :: QualifiedTable -> PStmt
deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertInto :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
insertInto t [] _ = B.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertInto t cols vals = B.Stmt
("insert into " <> fromQt t <> " (" <>
intercalate ", " (map pgFmtIdent cols) <>
T.intercalate ", " (map pgFmtIdent cols) <>
") values ("
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> ") returning row_to_json(" <> fromQt t <> ".*)")
empty True
insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
insertSelect t [] _ = B.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertSelect t cols vals = B.Stmt
("insert into " <> fromQt t <> " ("
<> intercalate ", " (map pgFmtIdent cols)
<> T.intercalate ", " (map pgFmtIdent cols)
<> ") select "
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
<> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
empty True
update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
update t cols vals = B.Stmt
("update " <> fromQt t <> " set ("
<> intercalate ", " (map pgFmtIdent cols)
<> T.intercalate ", " (map pgFmtIdent cols)
<> ") = ("
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> ")")
empty True
@@ -142,8 +142,11 @@ wherePred (col, predicate) = B.Stmt
empty True
where
opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate
value = intercalate "." rest
opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
unStarredVal = T.intercalate "." rest
star c = if c == '*' then '%' else c
value = if opCode == "like" || opCode == "ilike"
then T.map star unStarredVal else unStarredVal
op = case opCode of
"eq" -> "="
"gt" -> ">"
@@ -151,17 +154,19 @@ wherePred (col, predicate) = B.Stmt
"gte" -> ">="
"lte" -> "<="
"neq" -> "<>"
"like"-> "like"
"ilike"-> "ilike"
_ -> "="
orderParse :: Net.Query -> [OrderTerm]
orderParse q =
mapMaybe orderParseTerm . split (==',') $ cs order
mapMaybe orderParseTerm . T.split (==',') $ cs order
where
order = fromMaybe "" $ join (lookup "order" q)
orderParseTerm :: Text -> Maybe OrderTerm
orderParseTerm :: T.Text -> Maybe OrderTerm
orderParseTerm s =
case split (=='.') s of
case T.split (=='.') s of
[c,d] ->
if d `elem` ["asc", "desc"]
then Just $ OrderTerm c $
@@ -175,31 +180,31 @@ commaq = B.Stmt ", " empty True
andq :: PStmt
andq = B.Stmt " and " empty True
pgFmtIdent :: Text -> Text
pgFmtIdent :: T.Text -> T.Text
pgFmtIdent x =
let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in
let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
if escaped =~ danger
then "\"" <> escaped <> "\""
else escaped
where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text
where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text
pgFmtLit :: Text -> Text
pgFmtLit :: T.Text -> T.Text
pgFmtLit x =
let trimmed = trimNullChars x
escaped = "'" <> replace "'" "''" trimmed <> "'"
slashed = replace "\\" "\\\\" escaped in
cs $ if escaped =~ ("\\\\" :: Text)
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
slashed = T.replace "\\" "\\\\" escaped in
cs $ if escaped =~ ("\\\\" :: T.Text)
then "E" <> slashed
else slashed
trimNullChars :: Text -> Text
trimNullChars = Data.Text.takeWhile (/= '\x0')
trimNullChars :: T.Text -> T.Text
trimNullChars = T.takeWhile (/= '\x0')
fromQt :: QualifiedTable -> Text
fromQt :: QualifiedTable -> T.Text
fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
unquoted :: JSON.Value -> Text
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
test/Feature/AuthSpec.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
module Feature.AuthSpec where
-- {{{ Imports
test/Feature/InsertSpec.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
module Feature.InsertSpec where
import Test.Hspec
test/Feature/QuerySpec.hs
+44 -15
View File
@@ -2,39 +2,68 @@ module Feature.QuerySpec where
import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Hasql as H
import Hasql.Postgres as H
import Control.Monad (void)
import Data.Text(Text)
import SpecHelper
testSet :: IO ()
testSet = do
clearTable "items" >> clearTable "no_pk"
createItems 15
pool <- H.acquirePool pgSettings testPoolOpts
void . liftIO $ H.session pool $ H.tx Nothing $ do
H.unitEx $ insertNoPk "xyyx" "u"
H.unitEx $ insertNoPk "xYYx" "v"
where
insertNoPk :: Text -> Text -> H.Stmt H.Postgres
insertNoPk = [H.stmt|insert into "1".no_pk (a, b) values (?,?)|]
spec :: Spec
spec = beforeAll (clearTable "items" >> createItems 15)
. afterAll_ (clearTable "items") . around withApp $ do
spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
describe "Querying a nonexistent table" $
it "causes a 404" $
get "/faketable" `shouldRespondWith` 404
describe "Filtering response" $
context "column equality" $
describe "Filtering response" $ do
it "matches with equality" $
get "/items?id=eq.5"
`shouldRespondWith` ResponseMatcher {
matchBody = Just [json| [{"id":5}] |]
, matchStatus = 200
, matchHeaders = ["Content-Range" <:> "0-0/1"]
}
it "matches the predicate" $
get "/items?id=eq.5"
`shouldRespondWith` ResponseMatcher {
matchBody = Just "[{\"id\":5}]"
, matchStatus = 200
, matchHeaders = ["Content-Range" <:> "0-0/1"]
}
it "matches with like" $ do
get "/no_pk?a=like.*yx" `shouldRespondWith` [json|
[{"a":"xyyx","b":"u"}]|]
get "/no_pk?a=like.xy*" `shouldRespondWith` [json|
[{"a":"xyyx","b":"u"}]|]
get "/no_pk?a=like.*YY*" `shouldRespondWith` [json|
[{"a":"xYYx","b":"v"}]|]
it "matches with ilike" $ do
get "/no_pk?a=ilike.xy*&order=b.asc" `shouldRespondWith` [json|
[{"a":"xyyx","b":"u"},{"a":"xYYx","b":"v"}]|]
get "/no_pk?a=ilike.*YY*&order=b.asc" `shouldRespondWith` [json|
[{"a":"xyyx","b":"u"},{"a":"xYYx","b":"v"}]|]
describe "ordering response" $ do
it "by a column asc" $
get "/items?id=lte.2&order=id.asc"
`shouldRespondWith` ResponseMatcher {
matchBody = Just "[{\"id\":1},{\"id\":2}]"
matchBody = Just [json| [{"id":1},{"id":2}] |]
, matchStatus = 200
, matchHeaders = ["Content-Range" <:> "0-1/2"]
}
it "by a column desc" $
get "/items?id=lte.2&order=id.desc"
`shouldRespondWith` ResponseMatcher {
matchBody = Just "[{\"id\":2},{\"id\":1}]"
matchBody = Just [json| [{"id":2},{"id":1}] |]
, matchStatus = 200
, matchHeaders = ["Content-Range" <:> "0-1/2"]
}
@@ -52,9 +81,9 @@ spec = beforeAll (clearTable "items" >> createItems 15)
}
it "Omits question mark when there are no params" $
get "/no_pk"
get "/simple_pk"
`shouldRespondWith` ResponseMatcher {
matchBody = Just "[]"
, matchStatus = 200
, matchHeaders = ["Content-Location" <:> "/no_pk"]
, matchHeaders = ["Content-Location" <:> "/simple_pk"]
}
test/Feature/StructureSpec.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
module Feature.StructureSpec where
import Test.Hspec hiding (pendingWith)
test/Main.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Test.Hspec
test/SpecHelper.hs
-2
View File
@@ -1,5 +1,3 @@
{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
module SpecHelper where
import Network.Wai