diff --git a/circle.yml b/circle.yml index 84c32bb12..74c1982c8 100644 --- a/circle.yml +++ b/circle.yml @@ -3,7 +3,7 @@ machine: - createuser --superuser --no-password postgrest_test - createdb -O postgrest_test -U ubuntu postgrest_test ghc: - version: 7.8.3 + version: 7.10.1 dependencies: override: - cabal update diff --git a/postgrest.cabal b/postgrest.cabal index 38f5bf364..943aa0513 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ name: postgrest description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.11.1 +version: 0.3.0.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -22,6 +22,11 @@ Flag CI Default: False executable postgrest + if flag(ci) + ghc-options: -Wall -W -Werror + else + ghc-options: -Wall -W -O2 + main-is: PostgREST/Main.hs default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes default-language: Haskell2010 diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 94e36d90b..c5c09714f 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -19,8 +19,8 @@ module PostgREST.Auth ( ) where --line needed for ghc 7.8 -import Data.Functor ((<$>)) - +--import Data.Functor ((<$>)) + import Data.Aeson (Value (..), Object) import Data.Aeson.Types (emptyObject, emptyArray) import Data.Vector as V (null, head) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index fd6bf26a5..c83d304d6 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -13,7 +13,7 @@ import PostgREST.Types import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) -import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Aeson (encode) import Data.Functor.Identity import Data.Monoid ((<>)) import Data.String.Conversions (cs) @@ -34,7 +34,7 @@ isServerVersionSupported = do return $ read (cs row) >= minimumPgVersion hasqlError :: PgError -> IO a -hasqlError = error . cs . encodePretty +hasqlError = error . cs . encode main :: IO () main = do @@ -71,11 +71,12 @@ main = do <> show minimumPgVersion) ) supportedOrError - roleOrError <- H.session pool $ do - Identity (role :: Text) <- H.tx Nothing $ H.singleEx - [H.stmt|SELECT SESSION_USER|] - return role - authenticator <- either hasqlError return roleOrError + -- what was this code for? + -- roleOrError <- H.session pool $ do + -- Identity (role :: Text) <- H.tx Nothing $ H.singleEx + -- [H.stmt|SELECT SESSION_USER|] + -- return role + -- authenticator <- either hasqlError return roleOrError let txSettings = Just (H.ReadCommitted, Just True) metadata <- H.session pool $ H.tx txSettings $ do diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 90b71a40e..5fa540a9b 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -4,7 +4,7 @@ module PostgREST.Middleware where -- needed for ghc 7.8 -import Data.Functor ((<$>)) +-- import Data.Functor ((<$>)) import Data.Maybe (fromMaybe, isNothing) import Data.Monoid diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index ba0d2bc24..f3d393c72 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -5,8 +5,8 @@ where import Control.Applicative hiding ((<$>)) --lines needed for ghc 7.8 -import Data.Functor ((<$>)) -import Data.Traversable (traverse) +-- import Data.Functor ((<$>)) +-- import Data.Traversable (traverse) --import Control.Monad (join) --import Data.List (delete, find) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index d0e3d2533..1ea572a59 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 1044cdf8a..60521839b 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -10,9 +10,9 @@ import Data.Text hiding (filter, find, foldr, head, last, map, null, zipWith) import Control.Applicative import Data.Tree -import PostgREST.PgQuery (fromQi, - pgFmtIdent, pgFmtLit, pgFmtOperator, - pgFmtValue, whiteList, insertableValue, orderF) +import PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem, + pgFmtIdent, pgFmtCondition, + insertableValue, orderF) import PostgREST.Types --import qualified Data.Vector as V (empty) --import qualified Hasql.Backend as B @@ -161,47 +161,3 @@ requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) = -- ) vals -- ) -- <> " returning row_to_json(" <> fromQi t <> ".*)") - - -pgFmtCondition :: QualifiedIdentifier -> Filter -> 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 = 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 -> Text -> Text -pgFmtColumn table "*" = fromQi table <> ".*" -pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c - -pgFmtJsonPath :: Maybe JsonPath -> Text -pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x -pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) -pgFmtJsonPath _ = "" - -pgFmtTable :: Table -> Text -pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n - -pgFmtField :: QualifiedIdentifier -> Field -> Text -pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp - -pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text -pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> asJsonPath jp -pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> asJsonPath jp - -asJsonPath :: Maybe JsonPath -> Text -asJsonPath Nothing = "" -asJsonPath (Just xx) = " AS " <> last xx