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

App.hs compiles (dubiously)

Browse Source 
Removed query body is no longer a maybe value
This commit is contained in:
Joe Nelson
2016-01-24 18:09:19 -08:00
parent 6122bc4108
commit cb3977679d
6 changed files with 68 additions and 67 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+32 -36
View File
@@ -10,8 +10,6 @@ import Control.Applicative
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (join) import Control.Monad (join)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity
import Data.List (find, sortBy, delete) import Data.List (find, sortBy, delete)
import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Maybe (fromMaybe, fromJust, mapMaybe)
import Data.Ord (comparing) import Data.Ord (comparing)
@@ -33,7 +31,7 @@ import Data.Aeson
import Data.Aeson.Types (emptyArray) import Data.Aeson.Types (emptyArray)
import Data.Monoid import Data.Monoid
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Hasql.Connection as H import qualified Hasql.Session as H
import PostgREST.Config (AppConfig (..)) import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers import PostgREST.Parsers
@@ -47,8 +45,7 @@ import PostgREST.Types
import PostgREST.Auth (tokenJWT) import PostgREST.Auth (tokenJWT)
import PostgREST.Error (errResponse) import PostgREST.Error (errResponse)
import PostgREST.QueryBuilder ( asJson import PostgREST.QueryBuilder ( callProc
, callProc
, addJoinConditions , addJoinConditions
, sourceCTEName , sourceCTEName
, requestToQuery , requestToQuery
@@ -56,11 +53,12 @@ import PostgREST.QueryBuilder ( asJson
, addRelations , addRelations
, createReadStatement , createReadStatement
, createWriteStatement , createWriteStatement
, ResultsWithCount
) )
import Prelude import Prelude
app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response
app dbStructure conf reqBody req = app dbStructure conf reqBody req =
let let
-- TODO: blow up for Left values (there is a middleware that checks the headers) -- TODO: blow up for Left values (there is a middleware that checks the headers)
@@ -80,17 +78,17 @@ app dbStructure conf reqBody req =
if range == emptyRange if range == emptyRange
then return $ errResponse status416 "HTTP Range error" then return $ errResponse status416 "HTTP Range error"
else do else do
row <- H.maybeEx stm row <- H.query () stm
let (tableTotal, queryTotal, _ , body) = extractQueryResult row let (tableTotal, queryTotal, _ , body) = row
if singular if singular
then return $ if queryTotal <= 0 then return $ if queryTotal <= 0
then responseLBS status404 [] "" then responseLBS status404 [] ""
else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) else responseLBS status200 [contentTypeH] (cs body)
else do else do
let frm = rangeOffset range let frm = toInteger $ rangeOffset range
to = frm+queryTotal-1 to = frm+(toInteger queryTotal)-1
contentRange = contentRangeH frm to tableTotal contentRange = contentRangeH frm to (toInteger <$> tableTotal)
status = rangeStatus frm to tableTotal status = rangeStatus frm to (toInteger <$> tableTotal)
canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
. sortBy (comparing fst) . sortBy (comparing fst)
. map (join (***) cs) . map (join (***) cs)
@@ -102,46 +100,47 @@ app dbStructure conf reqBody req =
"/" <> cs (qiName qi) <> "/" <> cs (qiName qi) <>
if Prelude.null canonical then "" else "?" <> cs canonical if Prelude.null canonical then "" else "?" <> cs canonical
) )
] (fromMaybe "[]" body) ] (cs body)
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),
Just payload@(PayloadJSON (UniformObjects rows))) -> Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ cs e Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do Right (sq,mq) -> do
let isSingle = (==1) $ V.length rows let isSingle = (==1) $ V.length rows
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
row <- H.maybeEx stm row <- H.query uniform stm
let (_, _, location, body) = extractQueryResult row let (_, _, location, body) = extractQueryResult row
return $ responseLBS status201 return $ responseLBS status201
[ [
contentTypeH, contentTypeH,
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) (hLocation, "/" <> cs table <> "?" <> cs location)
] ]
$ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" $ if iPreferRepresentation apiRequest == Full then cs body else ""
(ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON _)) -> (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ cs e Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do Right (sq,mq) -> do
let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload
row <- H.maybeEx stm row <- H.query uniform stm
let (_, queryTotal, _, body) = extractQueryResult row let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal) r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404 s = case () of _ | queryTotal == 0 -> status404
| iPreferRepresentation apiRequest == Full -> status200 | iPreferRepresentation apiRequest == Full -> status200
| otherwise -> status204 | otherwise -> status204
return $ responseLBS s [contentTypeH, r] return $ responseLBS s [contentTypeH, r]
$ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" $ if iPreferRepresentation apiRequest == Full then cs body else ""
(ActionDelete, TargetIdent qi, Nothing) -> (ActionDelete, TargetIdent qi, Nothing) ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ cs e Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do Right (sq,mq) -> do
let fakeload = PayloadJSON $ UniformObjects V.empty let emptyUniform = UniformObjects V.empty
let fakeload = PayloadJSON $ emptyUniform
let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload
row <- H.maybeEx stm row <- H.query emptyUniform stm
let (_, queryTotal, _, _) = extractQueryResult row let (_, queryTotal, _, _) = extractQueryResult row
return $ if queryTotal == 0 return $ if queryTotal == 0
then notFound then notFound
@@ -158,25 +157,23 @@ app dbStructure conf reqBody req =
(ActionInvoke, TargetIdent qi, (ActionInvoke, TargetIdent qi,
Just (PayloadJSON (UniformObjects payload))) -> do Just (PayloadJSON (UniformObjects payload))) -> do
exists <- doesProcExist qi exists <- H.query qi doesProcExist
if exists if exists
then do then do
let p = V.head payload let p = V.head payload
call = B.Stmt "select " V.empty True <>
asJson (callProc qi p)
jwtSecret = configJwtSecret conf jwtSecret = configJwtSecret conf
bodyJson :: Maybe (Identity Value) <- H.maybeEx call bodyJson <- H.query () (callProc qi p)
returnJWT <- doesProcReturnJWT qi returnJWT <- H.query qi doesProcReturnJWT
return $ responseLBS status200 [jsonH] return $ responseLBS status200 [jsonH]
(let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in (let body = fromMaybe emptyArray $ bodyJson in
if returnJWT if returnJWT
then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
else cs $ encode body) else cs $ encode body)
else return notFound else return notFound
(ActionRead, TargetRoot, Nothing) -> do (ActionRead, TargetRoot, Nothing) -> do
body <- encode <$> accessibleTables (cs schema) body <- encode <$> H.query schema accessibleTables
return $ responseLBS status200 [jsonH] $ cs body return $ responseLBS status200 [jsonH] $ cs body
(ActionUnknown _, _, _) -> return notFound (ActionUnknown _, _, _) -> return notFound
@@ -204,14 +201,14 @@ app dbStructure conf reqBody req =
readSqlParts = (,) <$> selectQuery <*> countQuery readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
rangeStatus _ _ Nothing = status200 rangeStatus _ _ Nothing = status200
rangeStatus frm to (Just total) rangeStatus frm to (Just total)
| frm > total = status416 | frm > total = status416
| (1 + to - frm) < total = status206 | (1 + to - frm) < total = status206
| otherwise = status200 | otherwise = status200
contentRangeH :: Int -> Int -> Maybe Int -> Header contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
contentRangeH frm to total = contentRangeH frm to total =
("Content-Range", cs headerValue) ("Content-Range", cs headerValue)
where where
@@ -333,6 +330,5 @@ instance ToJSON TableOptions where
, "pkey" .= tblOptpkey t ] , "pkey" .= tblOptpkey t ]
extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
-> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) extractQueryResult = fromMaybe (Nothing, 0, "", "")
extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")
src/PostgREST/Config.hs
+1 -1
View File
@@ -42,7 +42,7 @@ data AppConfig = AppConfig {
, configSchema :: String , configSchema :: String
, configJwtSecret :: Secret , configJwtSecret :: Secret
, configPool :: Int , configPool :: Int
, configMaxRows :: Maybe Int , configMaxRows :: Maybe Integer
} }
argParser :: Parser AppConfig argParser :: Parser AppConfig
src/PostgREST/DbStructure.hs
+1 -1
View File
@@ -26,7 +26,7 @@ import qualified Hasql.Session as H
import PostgREST.Types import PostgREST.Types
import GHC.Exts (groupWith) import GHC.Exts (groupWith)
import GHC.Int (Int32) import Data.Int (Int32)
import Prelude import Prelude
getDbStructure :: Schema -> H.Session DbStructure getDbStructure :: Schema -> H.Session DbStructure
src/PostgREST/QueryBuilder.hs
+27 -22
View File
@@ -15,7 +15,6 @@ Any function that outputs a SQL fragment should be in this module.
module PostgREST.QueryBuilder ( module PostgREST.QueryBuilder (
addRelations addRelations
, addJoinConditions , addJoinConditions
, asJson
, callProc , callProc
, createReadStatement , createReadStatement
, createWriteStatement , createWriteStatement
@@ -26,6 +25,7 @@ module PostgREST.QueryBuilder (
, requestToCountQuery , requestToCountQuery
, sourceCTEName , sourceCTEName
, unquoted , unquoted
, ResultsWithCount
) where ) where
import qualified Hasql.Query as H import qualified Hasql.Query as H
@@ -62,7 +62,7 @@ import PostgREST.ApiRequest (PreferRepresentation (..))
{-| The generic query result format used by API responses -} {-| The generic query result format used by API responses -}
type ResultsWithCount = (Int64, Int64, BS.ByteString, BS.ByteString) type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString)
{-| Read and Write api requests use a similar response format which includes {-| Read and Write api requests use a similar response format which includes
various record counts and possible location header. This is the decoder various record counts and possible location header. This is the decoder
@@ -72,7 +72,14 @@ decodeStandard :: HD.Result ResultsWithCount
decodeStandard = decodeStandard =
HD.singleRow standardRow HD.singleRow standardRow
where where
standardRow = (,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
<*> HD.value HD.bytea <*> HD.value HD.bytea
decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
decodeStandardMay =
HD.maybeRow standardRow
where
standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
<*> HD.value HD.bytea <*> HD.value HD.bytea <*> HD.value HD.bytea <*> HD.value HD.bytea
{-| JSON and CSV payloads from the client are given to us as {-| JSON and CSV payloads from the client are given to us as
@@ -105,11 +112,11 @@ createReadStatement selectQuery countQuery range isSingle countTotal asCsv =
createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->
PreferRepresentation -> [Text] -> Bool -> Payload -> PreferRepresentation -> [Text] -> Bool -> Payload ->
H.Query UniformObjects ResultsWithCount H.Query UniformObjects (Maybe ResultsWithCount)
createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined
createWriteStatement _ _ mutateQuery _ None createWriteStatement _ _ mutateQuery _ None
_ _ (PayloadJSON (UniformObjects _)) = _ _ (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True H.statement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery}) WITH {sourceCTEName} AS ({mutateQuery})
@@ -117,7 +124,7 @@ createWriteStatement _ _ mutateQuery _ None
createWriteStatement qi _ mutateQuery isSingle HeadersOnly createWriteStatement qi _ mutateQuery isSingle HeadersOnly
pKeys _ (PayloadJSON (UniformObjects _)) = pKeys _ (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True H.statement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)
@@ -132,7 +139,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly
createWriteStatement qi selectQuery mutateQuery isSingle Full createWriteStatement qi selectQuery mutateQuery isSingle Full
pKeys asCsv (PayloadJSON (UniformObjects _)) = pKeys asCsv (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True H.statement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)
@@ -196,19 +203,18 @@ addJoinConditions schema (Node (query, (n, r)) forest) =
updatedForest = mapM (addJoinConditions schema) forest updatedForest = mapM (addJoinConditions schema) forest
addCond query' con = query'{flt_=con ++ flt_ query'} addCond query' con = query'{flt_=con ++ flt_ query'}
asJson :: BS.ByteString -> BS.ByteString callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value)
asJson _sql = callProc qi params =
[q| SELECT array_to_json( H.statement sql HE.unit decodeObj True
coalesce(array_agg(row_to_json(t)), '{}')
)::character varying
from ({_sql}) t |]
callProc :: QualifiedIdentifier -> JSON.Object -> BS.ByteString
callProc qi params = do
[qc| select * from {fromQi qi}({args}) |]
where where
args = intercalate "," $ map assignment (HM.toList params) sql = [q| SELECT array_to_json(
assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v coalesce(array_agg(row_to_json(t)), '{}')
)::character varying
from ({_callSql}) t |]
_args = intercalate "," $ map _assignment (HM.toList params)
_assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
_callSql = [qc| select * from {fromQi qi}({_args}) |] :: BS.ByteString
decodeObj = HD.maybeRow (HD.value HD.json)
operators :: [(Text, SqlFragment)] operators :: [(Text, SqlFragment)]
operators = [ operators = [
@@ -327,7 +333,7 @@ requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects row
"INSERT INTO ", fromQi qi, "INSERT INTO ", fromQi qi,
" (" <> colsString <> ")" <> " (" <> colsString <> ")" <>
" SELECT " <> colsString <> " SELECT " <> colsString <>
" FROM json_populate_recordset(null::" , fromQi qi, ", ?)" " FROM json_populate_recordset(null::" , fromQi qi, ", $1)"
] ]
requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
case rows V.!? 0 of case rows V.!? 0 of
@@ -393,8 +399,7 @@ locationF pKeys =
if null pKeys if null pKeys
then "" then ""
else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')" else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"
) <> ) <> ")"
")"
limitF :: NonnegRange -> SqlFragment limitF :: NonnegRange -> SqlFragment
limitF r = "LIMIT " <> limit <> " OFFSET " <> offset limitF r = "LIMIT " <> limit <> " OFFSET " <> offset
src/PostgREST/RangeQuery.hs
+6 -6
View File
@@ -24,7 +24,7 @@ import Data.Maybe (fromMaybe, listToMaybe)
import Prelude import Prelude
type NonnegRange = Range Int type NonnegRange = Range Integer
rangeParse :: BS.ByteString -> NonnegRange rangeParse :: BS.ByteString -> NonnegRange
rangeParse range = do rangeParse range = do
@@ -41,28 +41,28 @@ rangeParse range = do
rangeRequested :: RequestHeaders -> NonnegRange rangeRequested :: RequestHeaders -> NonnegRange
rangeRequested = rangeParse . fromMaybe "" . lookup hRange rangeRequested = rangeParse . fromMaybe "" . lookup hRange
restrictRange :: Maybe Int -> NonnegRange -> NonnegRange restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
restrictRange Nothing r = r restrictRange Nothing r = r
restrictRange (Just limit) r = restrictRange (Just limit) r =
rangeIntersection r $ rangeIntersection r $
Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
rangeLimit :: NonnegRange -> Maybe Int rangeLimit :: NonnegRange -> Maybe Integer
rangeLimit range = rangeLimit range =
case [rangeLower range, rangeUpper range] of case [rangeLower range, rangeUpper range] of
[BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
_ -> Nothing _ -> Nothing
rangeOffset :: NonnegRange -> Int rangeOffset :: NonnegRange -> Integer
rangeOffset range = rangeOffset range =
case rangeLower range of case rangeLower range of
BoundaryBelow from -> from BoundaryBelow from -> from
_ -> error "range without lower bound" -- should never happen _ -> error "range without lower bound" -- should never happen
rangeGeq :: Int -> NonnegRange rangeGeq :: Integer -> NonnegRange
rangeGeq n = rangeGeq n =
Range (BoundaryBelow n) BoundaryAboveAll Range (BoundaryBelow n) BoundaryAboveAll
rangeLeq :: Int -> NonnegRange rangeLeq :: Integer -> NonnegRange
rangeLeq n = rangeLeq n =
Range BoundaryBelowAll (BoundaryAbove n) Range BoundaryBelowAll (BoundaryAbove n)
src/PostgREST/Types.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Aeson import Data.Aeson
import GHC.Int (Int32) import Data.Int (Int32)
data DbStructure = DbStructure { data DbStructure = DbStructure {
dbTables :: [Table] dbTables :: [Table]