PUT path commented, DELETE rewritten, all statementT functions commented
This commit is contained in:
Ruslan Talpa
+65
-58
@@ -20,7 +20,7 @@ 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
|
||||
@@ -109,29 +109,29 @@ app dbstructure conf reqBody req =
|
||||
request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
|
||||
fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
|
||||
|
||||
([table], "PUT") ->
|
||||
handleJsonObj reqBody $ \obj -> do
|
||||
let qt = qualify table
|
||||
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
|
||||
specifiedKeys = map (cs . fst) qq
|
||||
if S.fromList pKeys /= S.fromList specifiedKeys
|
||||
then return $ responseLBS status405 []
|
||||
"You must speficy all and only primary keys as params"
|
||||
else do
|
||||
let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
|
||||
cols = map cs $ HM.keys obj
|
||||
if S.fromList tableCols == S.fromList cols
|
||||
then do
|
||||
let vals = HM.elems obj
|
||||
H.unitEx $ iffNotT
|
||||
(whereT qt qq $ update qt cols vals)
|
||||
(insertSelect qt cols vals)
|
||||
return $ responseLBS status204 [ jsonH ] ""
|
||||
|
||||
else return $ if Prelude.null tableCols
|
||||
then responseLBS status404 [] ""
|
||||
else responseLBS status400 []
|
||||
"You must specify all columns in PUT request"
|
||||
-- ([table], "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"
|
||||
@@ -153,16 +153,19 @@ app dbstructure conf reqBody req =
|
||||
fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
|
||||
|
||||
([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))] ""
|
||||
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)
|
||||
@@ -211,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
|
||||
@@ -266,22 +269,22 @@ contentTypeForAccept accept
|
||||
findInAccept = flip find $ parseHttpAccept acceptH
|
||||
has = isJust . findInAccept . BS.isPrefixOf
|
||||
|
||||
handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
|
||||
-> H.Tx P.Postgres s Response
|
||||
handleJsonObj reqBody handler = do
|
||||
let p = eitherDecode reqBody
|
||||
case p of
|
||||
Left err ->
|
||||
return $ responseLBS status400 [jsonH] jErr
|
||||
where
|
||||
jErr = encode . object $
|
||||
[("message", String $ "Failed to parse JSON payload. " <> cs err)]
|
||||
Right (Object o) -> handler o
|
||||
Right _ ->
|
||||
return $ responseLBS status400 [jsonH] jErr
|
||||
where
|
||||
jErr = encode . object $
|
||||
[("message", String "Expecting a JSON object")]
|
||||
-- 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
|
||||
@@ -428,11 +431,14 @@ parseRequest schema allRels rootTableName httpRequest reqBody =
|
||||
then M.fromList <$> (zip <$> flds <*> (head <$> vals))
|
||||
else Left "Expecting a sigle CSV line with header or a JSON object"
|
||||
allFilters = whereFilters qParams
|
||||
updateFilters = filter (not . ( '.' `elem` ) . fst) $ allFilters -- update filters can be only on the root table
|
||||
cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
|
||||
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 (selectStr qParams) filters (orderStr qParams)
|
||||
=<< 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
|
||||
@@ -441,9 +447,10 @@ parseRequest schema allRels rootTableName httpRequest reqBody =
|
||||
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 [])
|
||||
_ -> undefined
|
||||
"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 =
|
||||
|
||||
@@ -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
|
||||
+118
-118
@@ -9,12 +9,12 @@ module PostgREST.PgQuery (
|
||||
, wrapQuery
|
||||
, asJson
|
||||
, callProc
|
||||
, iffNotT
|
||||
, update
|
||||
, insertSelect
|
||||
, deleteFrom
|
||||
, asCsvWithCount
|
||||
, asJsonWithCount
|
||||
-- , iffNotT
|
||||
-- , update
|
||||
-- , insertSelect
|
||||
-- , deleteFrom
|
||||
-- , asCsvWithCount
|
||||
-- , asJsonWithCount
|
||||
, unquoted
|
||||
|
||||
-- format functions
|
||||
@@ -30,10 +30,10 @@ module PostgREST.PgQuery (
|
||||
, pgFmtAsJsonPath
|
||||
|
||||
-- query transformers (to be removed)
|
||||
, withT
|
||||
, countT
|
||||
, returningStarT
|
||||
, whereT
|
||||
-- , withT
|
||||
-- , countT
|
||||
-- , returningStarT
|
||||
-- , whereT
|
||||
|
||||
-- query fragments
|
||||
, sourceSubqueryName
|
||||
@@ -70,7 +70,7 @@ import Data.Scientific (FPFormat (..), formatScientific,
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import Data.Vector (empty)
|
||||
import qualified Network.HTTP.Types.URI as Net
|
||||
--import qualified Network.HTTP.Types.URI as Net
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
import Prelude
|
||||
@@ -107,82 +107,82 @@ operators = M.fromList [
|
||||
]
|
||||
|
||||
|
||||
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
|
||||
|
||||
-- whereT :: QualifiedIdentifier -> Net.Query -> StatementT
|
||||
-- whereT table params q =
|
||||
-- if L.null cols
|
||||
-- then q
|
||||
-- else q <> B.Stmt " where " empty True <> conjunction
|
||||
-- where
|
||||
-- cols = [ col | col <- params, fst col `notElem` ["order","select"] ]
|
||||
-- wherePredTable = wherePred table
|
||||
-- conjunction = mconcat $ L.intersperse andq (map wherePredTable cols)
|
||||
--
|
||||
-- withT :: PStmt -> T.Text -> StatementT
|
||||
-- withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
|
||||
-- B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)
|
||||
-- (ep <> wp)
|
||||
-- (epre && wpre)
|
||||
--
|
||||
-- iffNotT :: PStmt -> StatementT
|
||||
-- iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
|
||||
-- B.Stmt
|
||||
-- ("WITH aaa AS (" <> aq <> " returning *) " <>
|
||||
-- bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
|
||||
-- (ap <> bp)
|
||||
-- (apre && bpre)
|
||||
--
|
||||
-- countT :: StatementT
|
||||
-- countT s =
|
||||
-- s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" }
|
||||
--
|
||||
-- asCsvWithCount :: QualifiedIdentifier -> StatementT
|
||||
-- asCsvWithCount table = withCount . asCsv table
|
||||
--
|
||||
-- asCsv :: QualifiedIdentifier -> StatementT
|
||||
-- asCsv table s = s {
|
||||
-- B.stmtTemplate =
|
||||
-- "(select string_agg(quote_ident(column_name::text), ',') from "
|
||||
-- <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '"
|
||||
-- <> fromQi table <> "' order by ordinal_position) h) || '\r' || "
|
||||
-- <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from ("
|
||||
-- <> B.stmtTemplate s <> ") t" }
|
||||
--
|
||||
-- asJsonWithCount :: StatementT
|
||||
-- asJsonWithCount = withCount . asJson
|
||||
--
|
||||
asJson :: StatementT
|
||||
asJson s = s {
|
||||
B.stmtTemplate =
|
||||
"array_to_json(array_agg(row_to_json(t)))::character varying from ("
|
||||
<> B.stmtTemplate s <> ") t" }
|
||||
|
||||
withCount :: StatementT
|
||||
withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
|
||||
|
||||
returningStarT :: StatementT
|
||||
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
|
||||
deleteFrom :: QualifiedIdentifier -> PStmt
|
||||
deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
|
||||
|
||||
insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
insertSelect t [] _ = B.Stmt
|
||||
("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
insertSelect t cols vals = B.Stmt
|
||||
("insert into " <> fromQi t <> " ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") select "
|
||||
<> T.intercalate ", " (map insertableValue vals))
|
||||
empty True
|
||||
|
||||
update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
update t cols vals = B.Stmt
|
||||
("update " <> fromQi t <> " set ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") = ("
|
||||
<> T.intercalate ", " (map insertableValue vals)
|
||||
<> ")")
|
||||
empty True
|
||||
--
|
||||
-- withCount :: StatementT
|
||||
-- withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
|
||||
--
|
||||
-- returningStarT :: StatementT
|
||||
-- returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
--
|
||||
-- deleteFrom :: QualifiedIdentifier -> PStmt
|
||||
-- deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
|
||||
--
|
||||
-- insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
-- insertSelect t [] _ = B.Stmt
|
||||
-- ("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
-- insertSelect t cols vals = B.Stmt
|
||||
-- ("insert into " <> fromQi t <> " ("
|
||||
-- <> T.intercalate ", " (map pgFmtIdent cols)
|
||||
-- <> ") select "
|
||||
-- <> T.intercalate ", " (map insertableValue vals))
|
||||
-- empty True
|
||||
--
|
||||
-- update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
-- update t cols vals = B.Stmt
|
||||
-- ("update " <> fromQi t <> " set ("
|
||||
-- <> T.intercalate ", " (map pgFmtIdent cols)
|
||||
-- <> ") = ("
|
||||
-- <> T.intercalate ", " (map insertableValue vals)
|
||||
-- <> ")")
|
||||
-- empty True
|
||||
|
||||
callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
|
||||
callProc qi params = do
|
||||
@@ -191,39 +191,39 @@ callProc qi params = do
|
||||
where
|
||||
assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
|
||||
|
||||
wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
|
||||
wherePred table (col, predicate) =
|
||||
B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList val
|
||||
else cs sqlValue)
|
||||
empty True
|
||||
|
||||
where
|
||||
headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
|
||||
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
opCode = hasNot (head rest) headPredicate
|
||||
notOp = hasNot headPredicate ""
|
||||
val = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||
sqlValue = pgFmtValue opCode val
|
||||
op = pgFmtOperator opCode
|
||||
-- wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
|
||||
-- wherePred table (col, predicate) =
|
||||
-- B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
|
||||
-- if opCode `elem` ["is","isnot"] then whiteList val
|
||||
-- else cs sqlValue)
|
||||
-- empty True
|
||||
--
|
||||
-- where
|
||||
-- headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
|
||||
-- hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
-- opCode = hasNot (head rest) headPredicate
|
||||
-- notOp = hasNot headPredicate ""
|
||||
-- val = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||
-- sqlValue = pgFmtValue opCode val
|
||||
-- op = pgFmtOperator opCode
|
||||
|
||||
whiteList :: T.Text -> T.Text
|
||||
whiteList val = fromMaybe
|
||||
(cs (pgFmtLit val) <> "::unknown ")
|
||||
(L.find ((==) . T.toLower $ val) ["null","true","false"])
|
||||
|
||||
andq :: PStmt
|
||||
andq = B.Stmt " and " empty True
|
||||
-- andq :: PStmt
|
||||
-- andq = B.Stmt " and " empty True
|
||||
|
||||
parseJsonbPath :: T.Text -> Maybe JsonbPath
|
||||
parseJsonbPath p =
|
||||
case T.splitOn "->>" p of
|
||||
[a,b] ->
|
||||
let i:is = T.splitOn "->" a in
|
||||
Just $ DoubleArrow
|
||||
(foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
|
||||
(KeyIdentifier b)
|
||||
_ -> Nothing
|
||||
-- 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')
|
||||
@@ -352,16 +352,16 @@ pgFmtValue opCode val =
|
||||
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
|
||||
-- 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 =
|
||||
|
||||
@@ -139,3 +139,12 @@ requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
|
||||
"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 <> ".*"
|
||||
]
|
||||
|
||||
@@ -81,6 +81,7 @@ type SelectItem = (Field, Maybe Cast)
|
||||
type Path = [Text]
|
||||
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 ApiNode = (Query, (NodeName, Maybe Relation))
|
||||
|
||||
@@ -224,7 +224,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
|
||||
@@ -232,13 +233,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
|
||||
@@ -255,6 +258,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" []
|
||||
@@ -269,7 +273,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,
|
||||
|
||||
Reference in New Issue
Block a user