diff --git a/circle.yml b/circle.yml index 66200b110..4ba35a9a5 100644 --- a/circle.yml +++ b/circle.yml @@ -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 diff --git a/postgrest.cabal b/postgrest.cabal index b2fcc58c4..2f365c6d0 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index d43b4694c..01972b8a8 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 4c5f208a0..4af66137c 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} module Feature.AuthSpec where -- {{{ Imports diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 4c50c023d..4196fcb00 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} module Feature.InsertSpec where import Test.Hspec diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 37eb234d9..9de45f565 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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"] } diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 98adf05c6..a9001dcd6 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Feature.StructureSpec where import Test.Hspec hiding (pendingWith) diff --git a/test/Main.hs b/test/Main.hs index ccd6171c1..ab3a1f17f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} module Main where import Test.Hspec diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 1de74ea76..e12c7f76b 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} - module SpecHelper where import Network.Wai