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

Merge pull request #331 from ruslantalpa/v3

Browse Source 
Code refactoring POST/PUT/PATCH to be more like GET and use internal data type
This commit is contained in:
Joe Nelson
2015-10-31 00:02:39 -07:00
parent 97d612a60d 246c47dba4
commit 6b7e833023
15 changed files with 1154 additions and 676 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+6 -1
View File
@@ -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
src/PostgREST/App.hs
+308 -202
View File
@@ -1,42 +1,40 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
--module PostgREST.App where
module PostgREST.App (
app
, sqlError
, isSqlError
, contentTypeForAccept
, jsonH
, TableOptions(..)
) where
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative
import Control.Arrow (second, (***))
import Control.Arrow ((***))
import Control.Monad (join)
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (original)
import qualified Data.Csv as CSV
import Data.Functor.Identity
import qualified Data.HashMap.Strict as M
import Data.List (find, sortBy)
import Data.Maybe (fromMaybe, isJust, isNothing,
mapMaybe)
import qualified Data.HashMap.Strict as HM
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 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)
import Network.HTTP.Base (urlEncodeVars)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai
import Network.Wai.Internal (Response (..))
import Network.Wai.Parse (parseHttpAccept)
import Data.Aeson
@@ -62,41 +60,20 @@ app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s
app dbstructure conf reqBody req =
case (path, verb) of
([], _) -> do
Identity (dbrole :: Text) <- H.singleEx $ [H.stmt|SELECT current_user|]
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
return $ responseLBS status200 [jsonH] $ cs body
([table], "OPTIONS") -> do
let cols = filter (filterCol schema table) allCols
pkeys = map pkName $ filter (filterPk schema table) allPrKeys
body = encode (TableOptions cols pkeys)
return $ responseLBS status200 [jsonH, allOrigins] $ cs body
([table], "GET") ->
if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error"
else
case queries of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right (qs, cqs) -> do
let qt = qualify table
count = if hasPrefer "count=none"
then countNone
else cqs
q = B.Stmt "select " V.empty True <>
parentheticT count
<> commaq <> (
bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
. limitT range
$ qs
)
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, _, _) -> do
let q = B.Stmt (createStatement selectQuery Nothing True range [] (not $ hasPrefer "count=none") isCsv) V.empty True
row <- H.maybeEx q
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe Text) row
to = from+queryTotal-1
contentRange = contentRangeH from to tableTotal
status = rangeStatus from to tableTotal
canonical = urlEncodeVars
let (tableTotal, queryTotal, _ , body) = extractQueryResult row
to = frm+queryTotal-1
contentRange = contentRangeH frm to tableTotal
status = rangeStatus frm to tableTotal
canonical = urlEncodeVars -- should this be moved to the db (location)?
. sortBy (comparing fst)
. map (join (***) cs)
. parseSimpleQuery
@@ -107,65 +84,88 @@ app dbstructure conf reqBody req =
"/" <> cs table <>
if Prelude.null canonical then "" else "?" <> cs canonical
)
] (cs $ fromMaybe "[]" body)
] (fromMaybe "[]" body)
where
from = fromMaybe 0 $ rangeOffset <$> range
apiRequest = first formatParserError (parseGetRequest req)
>>= first formatRelationError . addRelations schema allRels Nothing
>>= addJoinConditions schema allCols
where
formatRelationError :: Text -> Text
formatRelationError e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String),
"details" .= e]
formatParserError :: ParseError -> Text
formatParserError e = cs $ encode $ object [
"message" .= message,
"details" .= details]
where
message = show (errorPos e)
details = strip $ replace "\n" " " $ cs
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
query = requestToQuery schema <$> apiRequest
countQuery = requestToCountQuery schema <$> apiRequest
queries = (,) <$> query <*> countQuery
frm = fromMaybe 0 $ rangeOffset <$> range
request = parseRequest schema allRels table req reqBody
([table], "POST") -> do
let qt = qualify table
echoRequested = hasPrefer "return=representation"
parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
parsed = if lookupHeader "Content-Type" == Just csvMT
then do
rows <- CSV.decode CSV.NoHeader reqBody
if V.null rows then Left "CSV requires header"
else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
else eitherDecode reqBody >>= \val ->
case val of
Object obj -> Right . second V.singleton . V.unzip . V.fromList $
M.toList obj
_ -> Left "Expecting single JSON object or CSV rows"
case parsed of
Left err -> return $ responseLBS status400 [] $
encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
Right toBeInserted -> do
rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
responses = flip map inserted $ \obj -> do
let primaries =
if Prelude.null pKeys
then obj
else M.filterWithKey (const . (`elem` pKeys)) obj
let params = urlEncodeVars
$ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
$ sortBy (comparing fst) $ M.toList primaries
responseLBS status201
[ jsonH
, (hLocation, "/" <> cs table <> "?" <> cs params)
] $ if echoRequested then encode obj else ""
return $ multipart status201 responses
let echoRequested = hasPrefer "return=representation"
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, mutateQuery, isSingle) -> do
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
q = B.Stmt (createStatement selectQuery (Just (mutateQuery, isSingle)) echoRequested Nothing pKeys False isCsv) V.empty True
row <- H.maybeEx q
let (_, _, location, body) = extractQueryResult row
return $ responseLBS status201
[
contentTypeH,
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
]
$ if echoRequested then fromMaybe "[]" body else ""
where
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
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, mutateQuery, _) -> do
let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) echoRequested Nothing [] False isCsv) V.empty True
row <- H.maybeEx q
let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404
| echoRequested -> status200
| otherwise -> status204
return $ responseLBS s [contentTypeH, r]
$ if echoRequested then fromMaybe "[]" body else ""
where
request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
([table], "DELETE") ->
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, mutateQuery, _) -> do
let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) False Nothing [] True isCsv) V.empty True
row <- H.maybeEx q
let (_, queryTotal, _, _) = extractQueryResult row
return $ if queryTotal == 0
then responseLBS status404 [] ""
else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
where
request = parseRequest schema allRels table req reqBody
(["rpc", proc], "POST") -> do
let qi = QualifiedIdentifier schema (cs proc)
@@ -173,7 +173,7 @@ app dbstructure conf reqBody req =
if exists
then do
let call = B.Stmt "select " V.empty True <>
asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
asJson (callProc qi $ fromMaybe HM.empty (decode reqBody))
bodyJson :: Maybe (Identity Value) <- H.maybeEx call
returnJWT <- doesProcReturnJWT schema proc
return $ responseLBS status200 [jsonH]
@@ -187,61 +187,16 @@ app dbstructure conf reqBody req =
-- check that arg names are all specified
-- select * from public.proc(a := "foo"::undefined) where whereT limit limitT
([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 $ M.keys obj
if S.fromList tableCols == S.fromList cols
then do
let vals = M.elems obj
H.unitEx $ iffNotT
(whereT qt qq $ update qt cols vals)
(insertSelect qt cols vals)
return $ responseLBS status204 [ jsonH ] ""
([], _) -> do
Identity (dbrole :: Text) <- H.singleEx $ [H.stmt|SELECT current_user|]
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
return $ responseLBS status200 [jsonH] $ cs body
else return $ if Prelude.null tableCols
then responseLBS status404 [] ""
else responseLBS status400 []
"You must specify all columns in PUT request"
([table], "PATCH") ->
handleJsonObj reqBody $ \obj -> do
let qt = qualify table
up = returningStarT
. whereT qt qq
$ update qt (map cs $ M.keys obj) (M.elems obj)
patch = withT up "t" $ B.Stmt
"select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"
V.empty True
row <- H.maybeEx patch
let (queryTotal, body) =
fromMaybe (0 :: Int, Just "" :: Maybe Text) row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
echoRequested = hasPrefer "return=representation"
s = case () of _ | queryTotal == 0 -> status404
| echoRequested -> status200
| otherwise -> status204
return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
([table], "DELETE") -> do
let qt = qualify table
del = countT
. returningStarT
. whereT qt qq
$ deleteFrom qt
row <- H.maybeEx del
let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
return $ if deletedCount == 0
then responseLBS status404 [] ""
else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
([table], "OPTIONS") -> do
let cols = filter (filterCol schema table) allCols
pkeys = map pkName $ filter (filterPk schema table) allPrKeys
body = encode (TableOptions cols pkeys)
return $ responseLBS status200 [jsonH, allOrigins] $ cs body
(_, _) ->
return $ responseLBS status404 [] ""
@@ -259,8 +214,8 @@ app dbstructure conf reqBody req =
filterTableAcl r (Table{tableAcl=a}) = r `elem` a
path = pathInfo req
verb = requestMethod req
qq = queryString req
qualify = QualifiedIdentifier schema
--qq = queryString req
--qualify = QualifiedIdentifier schema
hdrs = requestHeaders req
lookupHeader = flip lookup hdrs
hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
@@ -270,32 +225,27 @@ app dbstructure conf reqBody req =
range = rangeRequested hdrs
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
contentType = fromMaybe "application/json" $ contentTypeForAccept accept
isCsv = contentType == csvMT
contentTypeH = (hContentType, contentType)
sqlError :: t
sqlError = undefined
isSqlError :: t
isSqlError = undefined
rangeStatus :: Int -> Int -> Maybe Int -> Status
rangeStatus _ _ Nothing = status200
rangeStatus from to (Just total)
| from > total = status416
| (1 + to - from) < total = status206
rangeStatus frm to (Just total)
| frm > total = status416
| (1 + to - frm) < total = status206
| otherwise = status200
contentRangeH :: Int -> Int -> Maybe Int -> Header
contentRangeH from to total =
contentRangeH frm to total =
("Content-Range", cs headerValue)
where
headerValue = rangeString <> "/" <> totalString
rangeString
| totalNotZero && fromInRange = show from <> "-" <> cs (show to)
| totalNotZero && fromInRange = show frm <> "-" <> cs (show to)
| otherwise = "*"
totalString = fromMaybe "*" (show <$> total)
totalNotZero = fromMaybe True ((/=) 0 <$> total)
fromInRange = from <= to
fromInRange = frm <= to
jsonMT :: BS.ByteString
jsonMT = "application/json"
@@ -319,48 +269,137 @@ contentTypeForAccept accept
findInAccept = flip find $ parseHttpAccept acceptH
has = isJust . findInAccept . BS.isPrefixOf
bodyForAccept :: BS.ByteString -> QualifiedIdentifier -> StatementT
bodyForAccept contentType table
| contentType == csvMT = asCsvWithCount table
| otherwise = asJsonWithCount -- defaults to JSON
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")]
-- 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
multipart :: Status -> [Response] -> Response
multipart _ [] = responseLBS status204 [] ""
multipart _ [r] = r
multipart s rs =
responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $
BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)
formatRelationError :: Text -> Text
formatRelationError e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String),
"details" .= e]
formatParserError :: ParseError -> Text
formatParserError e = cs $ encode $ object [
"message" .= message,
"details" .= details]
where
renderHeader :: Header -> BL.ByteString
renderHeader (k, v) = cs (original k) <> ": " <> cs v
message = show (errorPos e)
details = strip $ replace "\n" " " $ cs
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
renderResponseBody :: Response -> BL.ByteString
renderResponseBody (ResponseBuilder _ headers b) =
BL.intercalate "\n" (map renderHeader headers)
<> "\n\n" <> BB.toLazyByteString b
renderResponseBody _ = error
"Unable to create multipart response from non-ResponseBuilder"
parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
parseRequestBody isCsv reqBody = first cs $
checkStructure =<<
if isCsv
then do
rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row)
else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
else eitherDecode reqBody >>= convertJson
where
checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]])
checkStructure v
| headerMatchesContent v = Right v
| isCsv = Left "CSV header does not match rows length"
| otherwise = Left "The number of keys in objects do not match"
headerMatchesContent :: ([Text], [[Value]]) -> Bool
headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
where headerLength = length header
convertJson :: Value -> Either String ([Text],[[Value]])
convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
where
invalidMsg = "Expecting single JSON object or JSON array of objects"
normalized :: Either String [(Text, [Value])]
normalized = groupByKey =<< normalizeValue v
vals :: [(Text, [Value])] -> [[Value]]
vals = transpose . map snd
header :: [(Text, [Value])] -> [Text]
header = map fst
groupByKey :: Value -> Either String [(Text,[Value])]
groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps
where
maps :: Either String [HM.HashMap Text [Value]]
maps = mapM getElems $ V.toList a
getElems (Object o) = Right $ HM.map (:[]) o
getElems _ = Left invalidMsg
groupByKey _ = Left invalidMsg
normalizeValue :: Value -> Either String Value
normalizeValue val =
case val of
Object obj -> Right $ Array (V.fromList[Object obj])
a@(Array _) -> Right a
_ -> Left invalidMsg
augumentRequestWithJoin :: Text -> [Relation] -> ApiRequest -> Either Text ApiRequest
augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request
>>= addJoinConditions schema
-- we use strings here because most of this data will be sent to parsers (which need strings for now)
queryParams :: Request -> [(String, Maybe String)]
queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
selectStr :: [(String, Maybe String)] -> String
selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
whereFilters :: [(String, Maybe String)] -> [(String, String)]
whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
orderStr :: [(String, Maybe String)] -> Maybe String
orderStr qParams = join $ lookup "order" qParams
buildSelectApiRequest :: Text -> String -> [(String, String)] -> Maybe String -> Either Text ApiRequest
buildSelectApiRequest rootTableName sel wher orderS =
first formatParserError $ foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
where
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++sel++">>") sel
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
flts = mapM pRequestFilter wher
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
addFilter (path, flt) (Node rn forest) =
case targetNode of
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
where
targetNodeName:remainingPath = path
(targetNode,restForest) = splitForest targetNodeName forest
splitForest name forst =
case maybeNode of
Nothing -> (Nothing,forest)
Just node -> (Just node, delete node forest)
where maybeNode = find ((name==).fst.snd.rootLabel) forst
toSourceRelation :: Text -> Relation -> Maybe Relation
toSourceRelation mt r@(Relation _ t _ ft _ _ rt _ _)
| mt == t = Just $ r {relTable=sourceSubqueryName}
| mt == ft = Just $ r {relFTable=sourceSubqueryName}
| Just mt == rt = Just $ r {relLTable=Just sourceSubqueryName}
| otherwise = Nothing
data TableOptions = TableOptions {
tblOptcolumns :: [Column]
@@ -371,3 +410,70 @@ instance ToJSON TableOptions where
toJSON t = object [
"columns" .= tblOptcolumns t
, "pkey" .= tblOptpkey t ]
parseRequest :: Text -> [Relation] -> NodeName -> Request -> BL.ByteString -> Either Text (Text, Text, Bool)
parseRequest schema allRels rootTableName httpRequest reqBody =
(,,) <$> selectQuery
<*> (if method == "GET" then pure "" else mutateQuery)
<*> (if method == "GET" then pure False else pure isSingleRecord)
where
hdrs = requestHeaders httpRequest
lookupHeader = flip lookup hdrs
isCsv = lookupHeader "Content-Type" == Just csvMT
method = requestMethod httpRequest
qParams = queryParams httpRequest
parsedBody = parseRequestBody isCsv reqBody
isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
parseField f = parse pField ("failed to parse field <<"++f++">>") f
flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
vals = snd <$> parsedBody
setWith = if isSingleRecord
then M.fromList <$> (zip <$> flds <*> (head <$> vals))
else Left "Expecting a sigle CSV line with header or a JSON object"
allFilters = whereFilters qParams
mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table
cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
selectApiRequest = augumentRequestWithJoin schema allRels
=<< buildSelectApiRequest rootName sel filters (orderStr qParams)
where
sel = if method == "DELETE"
then "*" -- we are not returning the records so no need to consider nested items
else selectStr qParams
rootName = if method == "GET"
then rootTableName
else sourceSubqueryName
filters = if method == "GET"
then allFilters
else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
selectQuery = requestToQuery schema <$> selectApiRequest
mutateQuery = requestToQuery schema <$> case method of
"POST" -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure []
"PATCH" -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
"DELETE" -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
_ -> undefined
createStatement :: Text -> Maybe (Text, Bool) -> Bool -> Maybe NonnegRange -> [Text] -> Bool -> Bool -> Text
createStatement selectQuery Nothing _ range _ countTable asCsv =
wrapQuery selectQuery [
if countTable then countAllF else countNoneF,
countF,
"null", -- location header can not be calucalted
if asCsv then asCsvF else asJsonF
] selectStarF range
createStatement selectQuery (Just (changeQuery, isSingle)) echoRequested _ pKeys _ asCsv =
wrapQuery changeQuery [
countNoneF, -- when updateing it does not make sense
countF,
if isSingle then locationF pKeys else "null",
if echoRequested
then
if asCsv
then asCsvF
else if isSingle then asJsonSingleF else asJsonF
else "null"
] selectQuery Nothing
extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
-> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")
src/PostgREST/Auth.hs
+1 -1
View File
@@ -12,7 +12,7 @@ In the test suite there is an example of simple login function that can be used
very simple authentication system inside the PostgreSQL database.
-}
module PostgREST.Auth (
setRole
setRole
, claimsToSQL
, jwtClaims
, tokenJWT
src/PostgREST/Config.hs
+1 -1
View File
@@ -96,4 +96,4 @@ readOptions = customExecParser parserPrefs opts
-- | Tells the minimum PostgreSQL version required by this version of PostgREST
minimumPgVersion :: Integer
minimumPgVersion = 90200
minimumPgVersion = 90300
src/PostgREST/Main.hs
+17 -8
View File
@@ -2,6 +2,7 @@ module Main where
import PostgREST.App
-- import PostgREST.QueryBuilder
import PostgREST.Config (AppConfig (..),
minimumPgVersion,
prettyVersion,
@@ -13,7 +14,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)
@@ -26,7 +27,7 @@ import Network.Wai.Middleware.RequestLogger (logStdout)
import System.IO (BufferMode (..),
hSetBuffering, stderr,
stdin, stdout)
-- import Data.Maybe (mapMaybe)
isServerVersionSupported :: H.Session P.Postgres IO Bool
isServerVersionSupported = do
@@ -34,7 +35,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 +72,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
@@ -85,8 +87,10 @@ main = do
keys <- allPrimaryKeys
return (tabs, rels, cols, keys)
dbstructure <- either hasqlError
(\(tabs, rels, cols, keys) ->
return DbStructure {
tables=tabs
, columns=cols
@@ -95,6 +99,11 @@ main = do
}
) metadata
-- let allRels = relations dbstructure
-- fakeRels = mapMaybe (toSourceRelation "projects") allRels
--
-- print $ findRelation (fakeRels ++ allRels) "test" "pg_source" "clients"
runSettings appSettings $ middle $ \ req respond -> do
body <- strictRequestBody req
resOrError <- liftIO $ H.session pool $ H.tx txSettings $
src/PostgREST/MainTest.hs
+131
View File
@@ -0,0 +1,131 @@
module Main where
import PostgREST.App
import PostgREST.Config (AppConfig (..),
minimumPgVersion,
prettyVersion,
readOptions)
import PostgREST.Error (errResponse, PgError)
import PostgREST.Middleware
import PostgREST.PgStructure
import PostgREST.Types
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (encode)
import Data.Functor.Identity
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Hasql as H
import qualified Hasql.Postgres as P
import Network.Wai
import Network.Wai.Handler.Warp hiding (Connection)
import Network.Wai.Middleware.RequestLogger (logStdout)
import System.IO (BufferMode (..),
hSetBuffering, stderr,
stdin, stdout)
-- import Data.Maybe (mapMaybe)
-- import Data.List (subsequences)
-- import Control.Monad (join)
-- import PostgREST.QueryBuilder
-- import GHC.Exts (groupWith)
isServerVersionSupported :: H.Session P.Postgres IO Bool
isServerVersionSupported = do
Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]
return $ read (cs row) >= minimumPgVersion
hasqlError :: PgError -> IO a
hasqlError = error . cs . encode
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
hSetBuffering stdin LineBuffering
hSetBuffering stderr NoBuffering
-- let dbString = "postgres://postgrest_test@localhost:5432/postgrest_test" :: String
-- conf = AppConfig dbString 3000 "postgrest_anonymous" "test" False "safe" 10 :: AppConfig
conf <- readOptions
let port = configPort conf
unless (configSecure conf) $
putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
unless ("secret" /= configJwtSecret conf) $
putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
Prelude.putStrLn $ "Listening on port " ++
(show $ configPort conf :: String)
let pgSettings = P.StringSettings $ cs (configDatabase conf)
appSettings = setPort port
. setServerName (cs $ "postgrest/" <> prettyVersion)
$ defaultSettings
middle = logStdout . defaultMiddle (configSecure conf)
poolSettings <- maybe (fail "Improper session settings") return $
H.poolSettings (fromIntegral $ configPool conf) 30
pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
supportedOrError <- H.session pool isServerVersionSupported
either hasqlError
(\supported ->
unless supported $
error (
"Cannot run in this PostgreSQL version, PostgREST needs at least "
<> show minimumPgVersion)
) supportedOrError
-- 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
tabs <- allTables
rels <- allRelations
cols <- allColumns rels
keys <- allPrimaryKeys
return (tabs, rels, cols, keys)
dbstructure <- either hasqlError
(\(tabs, rels, cols, keys) ->
return DbStructure {
tables=tabs
, columns=cols
, relations=rels
, primaryKeys=keys
}
) metadata
runSettings appSettings $ middle $ \ req respond -> do
body <- strictRequestBody req
resOrError <- liftIO $ H.session pool $ H.tx txSettings $
runWithClaims conf (app dbstructure conf body) req
either (respond . errResponse) respond resOrError
--let allRels = relations dbstructure
-- links = join $ map (combinations 2) $ filter ((>=1).length) $ groupWith groupFn $ filter ( (==Child). relType) allRels
-- combinations k ns = filter ((k==).length) (subsequences ns)
--print $ findRelation allRels "test" "projects" "users"
--mapM_ print $ mapMaybe link2Relation links
-- where
-- groupFn :: Relation -> Text
-- groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
-- link2Relation [
-- Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
-- Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}
-- ]
-- | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
-- | otherwise = Nothing
-- link2Relation _ = Nothing
src/PostgREST/Parsers.hs
+10 -37
View File
@@ -1,43 +1,30 @@
module PostgREST.Parsers
( parseGetRequest
)
-- ( parseGetRequest
-- )
where
import Control.Applicative hiding ((<$>))
import Control.Monad (join)
import Data.List (delete, find)
import Data.Maybe
--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 Network.Wai (Request, pathInfo, queryString)
import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>))
parseGetRequest :: Request -> Either ParseError ApiRequest
parseGetRequest httpRequest =
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
where
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
addOrder (Node r f) o = Node r{order=o} f
flts = mapM pRequestFilter whereFilters
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
orderStr = join $ lookup "order" qString
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
pRequestSelect :: Text -> Parser ApiRequest
pRequestSelect rootNodeName = do
fieldTree <- pFieldForest
return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree
return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
where
treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) =
treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
case fldForest of
[] -> Node (rNode {fields=fld:fields rNode}) rForest
_ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest)
[] -> Node (q {select=fld:select q}, i) rForest
_ -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -49,20 +36,6 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
op = fst <$> opVal
val = snd <$> opVal
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
addFilter (path, flt) (Node rn forest) =
case targetNode of
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
where
targetNodeName:remainingPath = path
(targetNode,restForest) = splitForest targetNodeName forest
splitForest name forst =
case maybeNode of
Nothing -> (Nothing,forest)
Just node -> (Just node, delete node forest)
where maybeNode = find ((name==).mainTable.rootLabel) forst
ws :: Parser Text
ws = cs <$> many (oneOf " \t")
src/PostgREST/PgQuery.hs
+348 -233
View File
@@ -3,14 +3,59 @@
{-# 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
, sourceSubqueryName
, orderF
, countNoneF
, countAllF
, countF
, locationF
, asCsvF
, asJsonSingleF
, asJsonF
, selectStarF
, 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 (..))
import PostgREST.Types
import Control.Monad (join)
import qualified Data.Aeson as JSON
@@ -25,11 +70,11 @@ 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 qualified Network.HTTP.Types.URI as Net
import Text.Regex.TDFA ((=~))
import Prelude
import qualified Data.Map as M
type PStmt = H.Stmt P.Postgres
instance Monoid PStmt where
@@ -37,142 +82,107 @@ instance Monoid PStmt where
B.Stmt (query <> query') (params <> params') (prep && prep')
mempty = B.Stmt "" empty True
type StatementT = PStmt -> PStmt
data JsonbPath =
ColIdentifier T.Text
| KeyIdentifier T.Text
| SingleArrow JsonbPath JsonbPath
| DoubleArrow JsonbPath JsonbPath
deriving (Show)
data QualifiedIdentifier = QualifiedIdentifier {
qiSchema :: T.Text
, qiName :: T.Text
} deriving (Show)
operators :: M.Map T.Text T.Text
operators = M.fromList [
("eq", "="),
("gt", ">"),
("lt", "<"),
("gte", ">="),
("lte", "<="),
("neq", "<>"),
("like", "like"),
("ilike", "ilike"),
("in", "in"),
("notin", "not in"),
("is", "is"),
("isnot", "is not"),
("@@", "@@")
]
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
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)
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
("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" }
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
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
-- 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 }
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
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
--
-- 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
@@ -181,116 +191,48 @@ 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 value
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 ""
value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
sqlValue = pgFmtValue opCode value
op = pgFmtOperator opCode
-- 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"])
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
-- andq :: PStmt
-- andq = B.Stmt " and " empty True
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
[a,b] ->
let i:is = T.splitOn "->" a in
Just $ DoubleArrow
(foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
(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
-- 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')
fromQi :: QualifiedIdentifier -> T.Text
fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t)
fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
where
n = qiName t
s = qiSchema t
unquoted :: JSON.Value -> T.Text
unquoted (JSON.String t) = t
@@ -306,6 +248,179 @@ 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] -> T.Text -> Maybe NonnegRange -> T.Text
wrapQuery source selectColumns returnSelect range =
withSourceF source <>
" SELECT " <>
T.intercalate ", " selectColumns <>
" " <>
fromF returnSelect ( limitF range )
-- query fragments
sourceSubqueryName :: T.Text
sourceSubqueryName = "pg_source"
withSourceF :: T.Text -> T.Text
withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"
countF :: T.Text
countF = "pg_catalog.count(t)"
countAllF :: T.Text
countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"
countNoneF :: T.Text
countNoneF = "null"
asJsonF :: T.Text
asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"
asJsonSingleF :: T.Text --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "
asCsvF :: T.Text
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
asCsvHeaderF :: T.Text
asCsvHeaderF =
"(SELECT string_agg(a.k, ',')" <>
" FROM (" <>
" SELECT json_object_keys(r)::TEXT as k" <>
" FROM ( " <>
" SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>
" ) s" <>
" ) a" <>
")"
asCsvBodyF :: T.Text
asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"
selectStarF :: T.Text
selectStarF = "SELECT * FROM " <> sourceSubqueryName
fromF :: T.Text -> T.Text -> T.Text
fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"
limitF :: Maybe NonnegRange -> T.Text
limitF r = "LIMIT " <> limit <> " OFFSET " <> offset
where
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
locationF :: [T.Text] -> T.Text
locationF pKeys =
"(" <>
" WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <>
" SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
" FROM s, json_each_text(s.r) AS json_data" <>
(
if null pKeys
then ""
else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')"
) <>
")"
orderF :: [OrderTerm] -> T.Text
orderF ts =
if L.null ts
then ""
else "ORDER BY " <> clause
where
clause = T.intercalate "," (map queryTerm ts)
queryTerm :: OrderTerm -> T.Text
queryTerm t = " "
<> 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 = fromMaybe "=" $ M.lookup opCode operators
-- 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 qi fc
where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft
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
src/PostgREST/PgStructure.hs
+56 -29
View File
@@ -6,8 +6,9 @@
module PostgREST.PgStructure where
import Control.Applicative
import Control.Monad (join)
import Data.Functor.Identity
import Data.List (find)
import Data.List (elemIndex, find, subsequences)
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Monoid
import Data.Text (Text, split)
@@ -66,8 +67,8 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
parseEnum str = fromMaybe [] $ split (==',') <$> str
relationFromRow :: (Text, Text, Text, Text, Text) -> Relation
relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc Child Nothing Nothing Nothing
relationFromRow :: (Text, Text, [Text], Text, [Text]) -> Relation
relationFromRow (s, t, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing
pkFromRow :: (Text, Text, Text) -> PrimaryKey
pkFromRow (s, t, n) = PrimaryKey s t n
@@ -109,61 +110,83 @@ allRelations :: H.Tx P.Postgres s [Relation]
allRelations = do
rels <- H.listEx $ [H.stmt|
WITH table_fk AS (
SELECT
tc.table_schema, tc.table_name, kcu.column_name,
ccu.table_name AS foreign_table_name,
ccu.column_name AS foreign_column_name
FROM information_schema.table_constraints AS tc
JOIN information_schema.key_column_usage AS kcu on tc.constraint_name = kcu.constraint_name
JOIN information_schema.constraint_column_usage AS ccu on ccu.constraint_name = tc.constraint_name
WHERE constraint_type = 'FOREIGN KEY'
AND tc.table_schema NOT IN ('pg_catalog', 'information_schema')
ORDER BY tc.table_schema, tc.table_name, kcu.column_name
SELECT ns.nspname AS table_schema,
tab.relname AS table_name,
column_info.cols AS columns,
other.relname AS foreign_table_name,
column_info.refs AS foreign_columns
FROM pg_constraint,
LATERAL (SELECT array_agg(cols.attname) AS cols,
array_agg(cols.attnum) AS nums,
array_agg(refs.attname) AS refs
FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
LATERAL (SELECT * FROM pg_attribute
WHERE attrelid = conrelid AND attnum = col)
AS cols,
LATERAL (SELECT * FROM pg_attribute
WHERE attrelid = confrelid AND attnum = ref)
AS refs)
AS column_info,
LATERAL (SELECT * FROM pg_namespace
WHERE pg_namespace.oid = connamespace) AS ns,
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other
WHERE confrelid != 0
ORDER BY (conrelid, column_info.nums)
)
SELECT * FROM table_fk
UNION
(
SELECT
vcu.table_schema, vcu.view_name AS table_name, vcu.column_name,
vcu.table_schema,
vcu.view_name AS table_name,
array_agg(vcu.column_name::text) AS columns,
table_fk.foreign_table_name,
table_fk.foreign_column_name
table_fk.foreign_columns
FROM information_schema.view_column_usage as vcu
JOIN table_fk ON
table_fk.table_schema = vcu.view_schema AND
table_fk.table_name = vcu.table_name AND
table_fk.column_name = vcu.column_name
vcu.column_name = ANY (table_fk.columns)
WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name
AND columns = table_fk.columns
GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns
)
UNION
(
SELECT
vcu.view_schema as table_schema,
table_fk.table_name,
table_fk.column_name,
table_fk.columns,
vcu.view_name as foreign_table_name,
vcu.column_name as foreign_column_name
array_agg(vcu.column_name::text) as foreign_columns
FROM information_schema.view_column_usage as vcu
JOIN table_fk ON
table_fk.table_schema = vcu.view_schema AND
table_fk.foreign_table_name = vcu.table_name AND
table_fk.foreign_column_name = vcu.column_name
vcu.column_name = ANY (table_fk.foreign_columns)
WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name
AND foreign_columns = table_fk.foreign_columns
GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns
)
|]
let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
links = join $ map (combinations 2) $ filter ((>=1).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
return $ simpleRelations ++ mapMaybe link2Relation links
where
groupFn :: Relation -> Text
groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
combinations k ns = filter ((k==).length) (subsequences ns)
link2Relation [
Relation{relSchema=sc, relTable=lt, relColumn=lc1, relFTable=t, relFColumn=c},
Relation{ relColumn=lc2, relFTable=ft, relFColumn=fc}
] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}
]
| lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
| otherwise = Nothing
link2Relation _ = Nothing
allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
allColumns rels = do
cols <- H.listEx $ [H.stmt|
@@ -210,12 +233,16 @@ allColumns rels = do
return $ map (addFK . columnFromRow) cols
where
addFK col = col { colFK = relToFk <$> find (lookupFn col) rels }
addFK col = col { colFK = fk col }
fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels
lookupFn :: Column -> Relation -> Bool
lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) =
cs==rs && ct==rt && cn==rc && rty==Child
lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) =
cs==rs && ct==rt && cn `elem` rc && rty==Child
lookupFn _ _ = False
relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c
relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c
where
pos = elemIndex cName cs
c = (fcs !!) <$> pos
allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
allPrimaryKeys = do
src/PostgREST/QueryBuilder.hs
+91 -105
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module PostgREST.QueryBuilder
where
@@ -6,159 +7,144 @@ import Control.Error
import Data.List (find)
import Data.Monoid
import Data.Text hiding (filter, find, foldr, head, last, map,
null)
null, zipWith)
import Control.Applicative
import Data.Tree
import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi,
orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
pgFmtValue, whiteList)
import PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
pgFmtIdent, pgFmtCondition,
insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
import PostgREST.Types
import qualified Data.Vector as V (empty)
import qualified Hasql.Backend as B
import qualified Data.Map as M
findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
findRelation allRelations s t1 t2 =
find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
case parentNode of
Nothing -> Node query{relation=Nothing} <$> updatedForest
(Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
Nothing -> Node (query, (table, Nothing)) <$> updatedForest
(Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest
where
rel = note ("no relation between " <> table <> " and " <> parentTable)
$ findRelation allRelations schema table parentTable
<|> findRelation allRelations schema parentTable table
addRel :: Query -> Relation -> Query
addRel q r = q{relation = Just r}
addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
addRel (q, (t, _)) r = (q, (t, Just r))
where
updatedForest = mapM (addRelations schema allRelations (Just node)) forest
addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
getJoinConditions :: Relation -> [Filter]
getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
case typ of
Child -> zipWith (toFilter t ft) cs fcs
Parent -> zipWith (toFilter t ft) cs fcs
Many -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
where
toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest
addJoinConditions schema (Node (query, (t, r)) forest) =
case r of
Nothing -> Node updatedQuery <$> updatedForest -- this is the root node
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
Nothing -> Node (updatedQuery, (t, r)) <$> updatedForest -- this is the root node
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(t,r)) <$> updatedForest
Just (Relation{relType=Parent}) -> Node (updatedQuery, (t,r)) <$> updatedForest
Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
Node <$> pure qq <*> updatedForest
Node (qq, (t, r)) <$> updatedForest
where
q = addCond updatedQuery (getJoinConditions rel)
qq = q{joinTables=linkTable:joinTables q}
qq = q{from=linkTable:from q}
_ -> Left "unknow relation"
where
-- add parentTable and parentJoinConditions to the query
updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions
updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions
where
parentJoinConditions = map (getJoinConditions.snd) parents
parentTables = map fst parents
parents = mapMaybe (getParents.rootLabel) forest
getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
getParents _ = Nothing
updatedForest = mapM (addJoinConditions schema allColumns) forest
getJoinConditions :: Relation -> [Filter]
getJoinConditions rel@(Relation _ _ c _ _ Child _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
getJoinConditions rel@(Relation _ _ c _ _ Parent _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
getJoinConditions (Relation s t c ft fc Many (Just lt) (Just lc1) (Just lc2)) =
[
Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 Child Nothing Nothing Nothing)),
Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 Child Nothing Nothing Nothing))
]
getJoinConditions _ = []
addCond q con = q{filters=con ++ filters q}
updatedForest = mapM (addJoinConditions schema) forest
addCond q con = q{where_=con ++ where_ q}
requestToCountQuery :: Text -> ApiRequest -> PStmt
requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
B.Stmt query V.empty True
emptyOnNull :: Text -> [a] -> Text
emptyOnNull val x = if null x then "" else val
requestToQuery :: Text -> ApiRequest -> Text
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
query
where
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
-- of our WITH query part
tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
toQi t = QualifiedIdentifier (tblSchema t) t
query = Data.Text.unwords [
"SELECT pg_catalog.count(1)",
"FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
]
emptyOnNull val x = if null x then "" else val
localConditions = filter fn conditions
where
fn (Filter{value=VText _}) = True
fn (Filter{value=VForeignKey _}) = False
requestToQuery :: Text -> ApiRequest -> PStmt
requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
orderT (fromMaybe [] ord) query
where
query = B.Stmt qStr V.empty True
qStr = Data.Text.unwords [
("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
"SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
"FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions
"SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
"FROM ", intercalate ", " (map (fromQi . toQi) tbls),
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
orderF (fromMaybe [] ord)
]
emptyOnNull val x = if null x then "" else val
(withs, selects) = foldr getQueryParts ([],[]) forest
getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s)
where subquery = requestToQuery schema (Node n forst)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
where
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
wit = table <> " AS ( " <> subquery <> " )"
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
where subquery = requestToQuery schema (Node n forst)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
-- the following is just to remove the warning
where subquery = requestToQuery schema (Node n forst)
--the following is just to remove the warning
--getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
--posible relations are Child Parent Many
getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined
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
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
query
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 (Relation s t c _ _ _ _ _ _) -> pgFmtColumn (QualifiedIdentifier s t) c
sqlValue = valToStr val
getInner v = case v of
VText s -> s
_ -> ""
valToStr v = case v of
VText s -> pgFmtValue opCode s
VForeignKey (Relation{relSchema=s, relFTable=ft, relFColumn=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
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
asJsonPath :: Maybe JsonPath -> Text
asJsonPath Nothing = ""
asJsonPath (Just xx) = " AS " <> last xx
qi = QualifiedIdentifier schema mainTbl
query = Data.Text.unwords [
"INSERT INTO ", fromQi qi,
" (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
"VALUES " <> intercalate ", "
( map (\v ->
"(" <>
intercalate ", " ( map insertableValue v ) <>
")"
) vals
),
"RETURNING " <> fromQi qi <> ".*"
]
requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
query
where
qi = QualifiedIdentifier schema mainTbl
query = Data.Text.unwords [
"UPDATE ", fromQi qi,
" SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
"RETURNING " <> fromQi qi <> ".*"
]
formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
query
where
qi = QualifiedIdentifier schema mainTbl
query = Data.Text.unwords [
"DELETE FROM ", fromQi qi,
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
"RETURNING " <> fromQi qi <> ".*"
]
src/PostgREST/Types.hs
+20 -15
View File
@@ -3,6 +3,7 @@ import Data.Text
import Data.Tree
import qualified Data.ByteString.Char8 as BS
import Data.Aeson
import Data.Map
data DbStructure = DbStructure {
tables :: [Table]
@@ -21,7 +22,7 @@ data Table = Table {
data ForeignKey = ForeignKey {
fkTable::Text, fkCol::Text
} deriving (Show)
} deriving (Show, Eq)
data Column = Column {
@@ -49,38 +50,42 @@ data OrderTerm = OrderTerm {
, otNullOrder :: Maybe BS.ByteString
} deriving (Show, Eq)
data QualifiedIdentifier = QualifiedIdentifier {
qiSchema :: Text
, qiName :: Text
} deriving (Show, Eq)
data RelationType = Child | Parent | Many deriving (Show, Eq)
data Relation = Relation {
relSchema :: Text
, relTable :: Text
, relColumn :: Text
, relColumns :: [Text]
, relFTable :: Text
, relFColumn :: Text
, relFColumns :: [Text]
, relType :: RelationType
, relLTable :: Maybe Text
, relLCol1 :: Maybe Text
, relLCol2 :: Maybe Text
, relLCols1 :: Maybe [Text]
, relLCols2 :: Maybe [Text]
} deriving (Show, Eq)
type Operator = Text
data FValue = VText Text | VForeignKey Relation deriving (Show, Eq)
data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
type FieldName = Text
type JsonPath = [Text]
type Field = (FieldName, Maybe JsonPath)
type Cast = Text
type NodeName = Text
type SelectItem = (Field, Maybe Cast)
type Path = [Text]
data Query = Select {
mainTable::Text
, fields::[SelectItem]
, joinTables::[Text]
, filters::[Filter]
, order::Maybe [OrderTerm]
, relation::Maybe Relation
} deriving (Show, Eq)
data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
| Insert { into::Text, fields::[Field], values::[[Value]] }
| Delete { from::[Text], where_::[Filter] }
| Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
type ApiRequest = Tree Query
type ApiNode = (Query, (NodeName, Maybe Relation))
type ApiRequest = Tree ApiNode
instance ToJSON Column where
src/mock.hs
+43
View File
@@ -0,0 +1,43 @@
arr = eitherDecode "[{\"a\":10},{\"a\":20}]" :: Either String Value
ob = eitherDecode "{\"a\":10}"::Either String Value
rc :: Request
rc = Request {
-- | Request method such as GET.
requestMethod = "POST"
, pathInfo = ["menagerie"]
, requestHeaders = [("Content-Type", "text/csv")] -- :: H.RequestHeaders
}
bc :: BL.ByteString
bc = [str|integer->sub->sub2,double,varchar,boolean,date,money,enum
|13,3.14159,testing!,false,1900-01-01,$3.99,foo
|12,0.1,NULL,true,1929-10-01,12,bar
|]
rj :: Request
rj = Request {
-- | Request method such as GET.
requestMethod = "POST"
, pathInfo = ["menagerie"]
, requestHeaders = [("Content-Type", "application/json")] -- :: H.RequestHeaders
}
bj :: BL.ByteString
bj = [str|{
| "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
| , "boolean": false, "date": "1900-01-01", "money": "$3.99"
| , "enum": "foo"
|}
|]
bj2 :: BL.ByteString
bj2 = [str|[
|{
| "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
| , "boolean": false, "date": "1900-01-01", "money": "$3.99"
| , "enum": "foo"
|},
|{
| "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
| , "boolean": false, "date": "1900-01-01", "money": "$3.99"
| , "enum": "foo"
|}]
|]
test/Feature/InsertSpec.hs
+111 -40
View File
@@ -1,6 +1,6 @@
module Feature.InsertSpec where
import Test.Hspec
import Test.Hspec hiding (pendingWith)
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
@@ -19,16 +19,38 @@ import TestTypes(IncPK(..), CompoundPK(..))
spec :: Spec
spec = afterAll_ resetDb $ around withApp $ do
describe "Posting new record" $ do
after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
p <- post "/menagerie"
[json| {
"integer": 13, "double": 3.14159, "varchar": "testing!"
, "boolean": false, "date": "1900-01-01", "money": "$3.99"
, "enum": "foo"
} |]
liftIO $ do
simpleBody p `shouldBe` ""
simpleStatus p `shouldBe` created201
after_ (clearTable "menagerie") . context "disparate csv types" $ do
it "accepts disparate json types" $ do
p <- post "/menagerie"
[json| {
"integer": 13, "double": 3.14159, "varchar": "testing!"
, "boolean": false, "date": "1900-01-01", "money": "$3.99"
, "enum": "foo"
} |]
liftIO $ do
simpleBody p `shouldBe` ""
simpleStatus p `shouldBe` created201
it "filters columns in result using &select" $
request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
[json| {
"integer": 14, "double": 3.14159, "varchar": "testing!"
, "boolean": false, "date": "1900-01-01", "money": "$3.99"
, "enum": "foo"
} |] `shouldRespondWith` ResponseMatcher {
matchBody = Just [str|{"integer":14,"varchar":"testing!"}|]
, matchStatus = 201
, matchHeaders = ["Content-Type" <:> "application/json"]
}
it "includes related data after insert" $
request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation")]
[str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
matchBody = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]
, matchStatus = 201
, matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"]
}
context "with no pk supplied" $ do
context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
@@ -92,55 +114,99 @@ spec = afterAll_ resetDb $ around withApp $ do
context "jsonb" . after_ (clearTable "json") $ do
it "serializes nested object" $ do
let inserted = [json| { "data": { "foo":"bar" } } |]
p <- request methodPost "json" [("Prefer", "return=representation")] inserted
liftIO $ do
simpleBody p `shouldBe` inserted
simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
simpleStatus p `shouldBe` created201
request methodPost "/json"
[("Prefer", "return=representation")]
inserted
`shouldRespondWith` ResponseMatcher {
matchBody = Just inserted
, matchStatus = 201
, matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]]
}
-- TODO! the test above seems right, why was the one below working before and not now
-- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
-- liftIO $ do
-- simpleBody p `shouldBe` inserted
-- simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
-- simpleStatus p `shouldBe` created201
it "serializes nested array" $ do
let inserted = [json| { "data": [1,2,3] } |]
p <- request methodPost "json" [("Prefer", "return=representation")] inserted
liftIO $ do
simpleBody p `shouldBe` inserted
simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
simpleStatus p `shouldBe` created201
request methodPost "/json"
[("Prefer", "return=representation")]
inserted
`shouldRespondWith` ResponseMatcher {
matchBody = Just inserted
, matchStatus = 201
, matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]]
}
-- TODO! the test above seems right, why was the one below working before and not now
-- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
-- liftIO $ do
-- simpleBody p `shouldBe` inserted
-- simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
-- simpleStatus p `shouldBe` created201
describe "CSV insert" $ do
after_ (clearTable "menagerie") . context "disparate csv types" $
it "succeeds with multipart response" $ do
p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
[str|integer,double,varchar,boolean,date,money,enum
|13,3.14159,testing!,false,1900-01-01,$3.99,foo
|12,0.1,a string,true,1929-10-01,12,bar
|]
liftIO $ do
simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
simpleStatus p `shouldBe` created201
pendingWith "Decide on what to do with CSV insert"
let inserted = [str|integer,double,varchar,boolean,date,money,enum
|13,3.14159,testing!,false,1900-01-01,$3.99,foo
|12,0.1,a string,true,1929-10-01,12,bar
|]
request methodPost "/menagerie" [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] inserted
`shouldRespondWith` ResponseMatcher {
matchBody = Just inserted
, matchStatus = 201
, matchHeaders = ["Content-Type" <:> "text/csv"]
}
-- p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
-- [str|integer,double,varchar,boolean,date,money,enum
-- |13,3.14159,testing!,false,1900-01-01,$3.99,foo
-- |12,0.1,a string,true,1929-10-01,12,bar
-- |]
-- liftIO $ do
-- simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
-- simpleStatus p `shouldBe` created201
after_ (clearTable "no_pk") . context "requesting full representation" $ do
it "returns full details of inserted record" $
request methodPost "/no_pk"
[("Content-Type", "text/csv"), ("Prefer", "return=representation")]
[("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
"a,b\nbar,baz"
`shouldRespondWith` ResponseMatcher {
matchBody = Just [json| { "a":"bar", "b":"baz" } |]
matchBody = Just "a,b\nbar,baz"
, matchStatus = 201
, matchHeaders = ["Content-Type" <:> "application/json",
, matchHeaders = ["Content-Type" <:> "text/csv",
"Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]
}
-- it "can post nulls (old way)" $ do
-- pendingWith "changed the response when in csv mode"
-- request methodPost "/no_pk"
-- [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
-- "a,b\nNULL,foo"
-- `shouldRespondWith` ResponseMatcher {
-- matchBody = Just [json| { "a":null, "b":"foo" } |]
-- , matchStatus = 201
-- , matchHeaders = ["Content-Type" <:> "application/json",
-- "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
-- }
it "can post nulls" $
request methodPost "/no_pk"
[("Content-Type", "text/csv"), ("Prefer", "return=representation")]
[("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
"a,b\nNULL,foo"
`shouldRespondWith` ResponseMatcher {
matchBody = Just [json| { "a":null, "b":"foo" } |]
matchBody = Just "a,b\n,foo"
, matchStatus = 201
, matchHeaders = ["Content-Type" <:> "application/json",
, matchHeaders = ["Content-Type" <:> "text/csv",
"Location" <:> "/no_pk?a=is.null&b=eq.foo"]
}
after_ (clearTable "no_pk") . context "with wrong number of columns" $ do
it "fails for too few" $ do
p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
@@ -159,7 +225,8 @@ spec = afterAll_ resetDb $ around withApp $ do
context "to a known uri" $ do
context "without a fully-specified primary key" $
it "is not an allowed operation" $
it "is not an allowed operation" $ do
pendingWith "Decide on PUT usefullness"
request methodPut "/compound_pk?k1=eq.12" []
[json| { "k1":12, "k2":42 } |]
`shouldRespondWith` 405
@@ -167,13 +234,15 @@ spec = afterAll_ resetDb $ around withApp $ do
context "with a fully-specified primary key" $ do
context "not specifying every column in the table" $
it "is rejected for lack of idempotence" $
it "is rejected for lack of idempotence" $ do
pendingWith "Decide on PUT usefullness"
request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
[json| { "k1":12, "k2":42 } |]
`shouldRespondWith` 400
context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
it "can create a new record" $ do
pendingWith "Decide on PUT usefullness"
p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
[json| { "k1":12, "k2":42, "extra":3 } |]
liftIO $ do
@@ -190,6 +259,7 @@ spec = afterAll_ resetDb $ around withApp $ do
compoundExtra record `shouldBe` Just 3
it "can update an existing record" $ do
pendingWith "Decide on PUT usefullness"
_ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
[json| { "k1":12, "k2":42, "extra":4 } |]
_ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
@@ -204,7 +274,8 @@ spec = afterAll_ resetDb $ around withApp $ do
context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $
it "succeeds with 204" $
it "succeeds with 204" $ do
pendingWith "Decide on PUT usefullness"
request methodPut "/auto_incrementing_pk?id=eq.1" []
[json| {
"id":1,
@@ -292,7 +363,7 @@ spec = afterAll_ resetDb $ around withApp $ do
[ auth, ("Prefer", "return=representation") ]
[json| { "secret": "nyancat" } |]
liftIO $ do
simpleBody p1 `shouldBe` [json| { "owner":"jdoe", "secret":"nyancat" } |]
simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|]
simpleStatus p1 `shouldBe` created201
p2 <- request methodPost "/authors_only"
@@ -300,5 +371,5 @@ spec = afterAll_ resetDb $ around withApp $ do
[ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]
[json| { "secret": "lolcat", "owner": "hacker" } |]
liftIO $ do
simpleBody p2 `shouldBe` [json| { "owner":"jroe", "secret":"lolcat" } |]
simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|]
simpleStatus p2 `shouldBe` created201
test/Feature/QuerySpec.hs
+4 -4
View File
@@ -11,6 +11,7 @@ import SpecHelper
spec :: Spec
spec =
beforeAll (clearTable "items" >> createItems 15)
. beforeAll clearProjectsTable
. beforeAll (clearTable "complex_items" >> createComplexItems)
. beforeAll (clearTable "nullable_integer" >> createNullInteger)
. beforeAll (
@@ -198,10 +199,9 @@ spec =
get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith`
"[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]"
it "requesting children with composite key" $ do
pendingWith "have to resolve issue #302"
it "requesting children with composite key" $
get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith`
[json| [{"user_id":2,"task_id":6,"comments":[{"content": "Needs to be delivered ASAP"}]}] |]
"[{\"user_id\":2,\"task_id\":6,\"comments\":[{\"content\":\"Needs to be delivered ASAP\"}]}]"
describe "ordering response" $ do
@@ -273,7 +273,7 @@ spec =
request methodGet "/simple_pk"
(acceptHdrs "text/csv; version=1") ""
`shouldRespondWith` ResponseMatcher {
matchBody = Just "k,extra\rxyyx,u\rxYYx,v"
matchBody = Just "k,extra\nxyyx,u\nxYYx,v"
, matchStatus = 200
, matchHeaders = ["Content-Type" <:> "text/csv"]
}
test/SpecHelper.hs
+7
View File
@@ -130,6 +130,13 @@ clearTable table = do
void . liftIO $ H.session pool $ H.tx Nothing $
H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True
clearProjectsTable :: IO ()
clearProjectsTable = do
pool <- testPool
void . liftIO $ H.session pool $ H.tx Nothing $
H.unitEx $ B.Stmt ("delete from test.projects where id > 4") V.empty True
createItems :: Int -> IO ()
createItems n = do
pool <- testPool