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.Monad (join)
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity
import Data.List (find, sortBy, delete)
import Data.Maybe (fromMaybe, fromJust, mapMaybe)
import Data.Ord (comparing)
@@ -33,7 +31,7 @@ import Data.Aeson
import Data.Aeson.Types (emptyArray)
import Data.Monoid
import qualified Data.Vector as V
import qualified Hasql.Connection as H
import qualified Hasql.Session as H
import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers
@@ -47,8 +45,7 @@ import PostgREST.Types
import PostgREST.Auth (tokenJWT)
import PostgREST.Error (errResponse)
import PostgREST.QueryBuilder ( asJson
, callProc
import PostgREST.QueryBuilder ( callProc
, addJoinConditions
, sourceCTEName
, requestToQuery
@@ -56,11 +53,12 @@ import PostgREST.QueryBuilder ( asJson
, addRelations
, createReadStatement
, createWriteStatement
, ResultsWithCount
)
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 =
let
-- 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
then return $ errResponse status416 "HTTP Range error"
else do
row <- H.maybeEx stm
let (tableTotal, queryTotal, _ , body) = extractQueryResult row
row <- H.query () stm
let (tableTotal, queryTotal, _ , body) = row
if singular
then return $ if queryTotal <= 0
then responseLBS status404 [] ""
else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
else responseLBS status200 [contentTypeH] (cs body)
else do
let frm = rangeOffset range
to = frm+queryTotal-1
contentRange = contentRangeH frm to tableTotal
status = rangeStatus frm to tableTotal
let frm = toInteger $ rangeOffset range
to = frm+(toInteger queryTotal)-1
contentRange = contentRangeH frm to (toInteger <$> tableTotal)
status = rangeStatus frm to (toInteger <$> tableTotal)
canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
. sortBy (comparing fst)
. map (join (***) cs)
@@ -102,46 +100,47 @@ app dbStructure conf reqBody req =
"/" <> cs (qiName qi) <>
if Prelude.null canonical then "" else "?" <> cs canonical
)
] (fromMaybe "[]" body)
] (cs body)
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),
Just payload@(PayloadJSON (UniformObjects rows))) ->
Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do
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 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
return $ responseLBS status201
[
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
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do
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
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404
| iPreferRepresentation apiRequest == Full -> status200
| otherwise -> status204
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) ->
case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
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
row <- H.maybeEx stm
row <- H.query emptyUniform stm
let (_, queryTotal, _, _) = extractQueryResult row
return $ if queryTotal == 0
then notFound
@@ -158,25 +157,23 @@ app dbStructure conf reqBody req =
(ActionInvoke, TargetIdent qi,
Just (PayloadJSON (UniformObjects payload))) -> do
exists <- doesProcExist qi
exists <- H.query qi doesProcExist
if exists
then do
let p = V.head payload
call = B.Stmt "select " V.empty True <>
asJson (callProc qi p)
jwtSecret = configJwtSecret conf
bodyJson :: Maybe (Identity Value) <- H.maybeEx call
returnJWT <- doesProcReturnJWT qi
bodyJson <- H.query () (callProc qi p)
returnJWT <- H.query qi doesProcReturnJWT
return $ responseLBS status200 [jsonH]
(let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
(let body = fromMaybe emptyArray $ bodyJson in
if returnJWT
then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
else cs $ encode body)
else return notFound
(ActionRead, TargetRoot, Nothing) -> do
body <- encode <$> accessibleTables (cs schema)
body <- encode <$> H.query schema accessibleTables
return $ responseLBS status200 [jsonH] $ cs body
(ActionUnknown _, _, _) -> return notFound
@@ -204,14 +201,14 @@ app dbStructure conf reqBody req =
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
rangeStatus :: Int -> Int -> Maybe Int -> Status
rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
rangeStatus _ _ Nothing = status200
rangeStatus frm to (Just total)
| frm > total = status416
| (1 + to - frm) < total = status206
| otherwise = status200
contentRangeH :: Int -> Int -> Maybe Int -> Header
contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
contentRangeH frm to total =
("Content-Range", cs headerValue)
where
@@ -333,6 +330,5 @@ instance ToJSON TableOptions where
, "pkey" .= tblOptpkey t ]
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 "")
extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
extractQueryResult = fromMaybe (Nothing, 0, "", "")
src/PostgREST/Config.hs
+1 -1
View File
@@ -42,7 +42,7 @@ data AppConfig = AppConfig {
, configSchema :: String
, configJwtSecret :: Secret
, configPool :: Int
, configMaxRows :: Maybe Int
, configMaxRows :: Maybe Integer
}
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 GHC.Exts (groupWith)
import GHC.Int (Int32)
import Data.Int (Int32)
import Prelude
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 (
addRelations
, addJoinConditions
, asJson
, callProc
, createReadStatement
, createWriteStatement
@@ -26,6 +25,7 @@ module PostgREST.QueryBuilder (
, requestToCountQuery
, sourceCTEName
, unquoted
, ResultsWithCount
) where
import qualified Hasql.Query as H
@@ -62,7 +62,7 @@ import PostgREST.ApiRequest (PreferRepresentation (..))
{-| 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
various record counts and possible location header. This is the decoder
@@ -72,7 +72,14 @@ decodeStandard :: HD.Result ResultsWithCount
decodeStandard =
HD.singleRow standardRow
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
{-| 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 ->
PreferRepresentation -> [Text] -> Bool -> Payload ->
H.Query UniformObjects ResultsWithCount
H.Query UniformObjects (Maybe ResultsWithCount)
createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined
createWriteStatement _ _ mutateQuery _ None
_ _ (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True
H.statement sql encodeUniformObjs decodeStandardMay True
where
sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery})
@@ -117,7 +124,7 @@ createWriteStatement _ _ mutateQuery _ None
createWriteStatement qi _ mutateQuery isSingle HeadersOnly
pKeys _ (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True
H.statement sql encodeUniformObjs decodeStandardMay True
where
sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)
@@ -132,7 +139,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly
createWriteStatement qi selectQuery mutateQuery isSingle Full
pKeys asCsv (PayloadJSON (UniformObjects _)) =
H.statement sql encodeUniformObjs decodeStandard True
H.statement sql encodeUniformObjs decodeStandardMay True
where
sql = [qc|
WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)
@@ -196,19 +203,18 @@ addJoinConditions schema (Node (query, (n, r)) forest) =
updatedForest = mapM (addJoinConditions schema) forest
addCond query' con = query'{flt_=con ++ flt_ query'}
asJson :: BS.ByteString -> BS.ByteString
asJson _sql =
[q| SELECT array_to_json(
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}) |]
callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value)
callProc qi params =
H.statement sql HE.unit decodeObj True
where
args = intercalate "," $ map assignment (HM.toList params)
assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
sql = [q| SELECT array_to_json(
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 = [
@@ -327,7 +333,7 @@ requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects row
"INSERT INTO ", fromQi qi,
" (" <> 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)) =
case rows V.!? 0 of
@@ -393,8 +399,7 @@ locationF pKeys =
if null pKeys
then ""
else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"
) <>
")"
) <> ")"
limitF :: NonnegRange -> SqlFragment
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
type NonnegRange = Range Int
type NonnegRange = Range Integer
rangeParse :: BS.ByteString -> NonnegRange
rangeParse range = do
@@ -41,28 +41,28 @@ rangeParse range = do
rangeRequested :: RequestHeaders -> NonnegRange
rangeRequested = rangeParse . fromMaybe "" . lookup hRange
restrictRange :: Maybe Int -> NonnegRange -> NonnegRange
restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
restrictRange Nothing r = r
restrictRange (Just limit) r =
rangeIntersection r $
Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
rangeLimit :: NonnegRange -> Maybe Int
rangeLimit :: NonnegRange -> Maybe Integer
rangeLimit range =
case [rangeLower range, rangeUpper range] of
[BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
_ -> Nothing
rangeOffset :: NonnegRange -> Int
rangeOffset :: NonnegRange -> Integer
rangeOffset range =
case rangeLower range of
BoundaryBelow from -> from
_ -> error "range without lower bound" -- should never happen
rangeGeq :: Int -> NonnegRange
rangeGeq :: Integer -> NonnegRange
rangeGeq n =
Range (BoundaryBelow n) BoundaryAboveAll
rangeLeq :: Int -> NonnegRange
rangeLeq :: Integer -> NonnegRange
rangeLeq 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.Vector as V
import Data.Aeson
import GHC.Int (Int32)
import Data.Int (Int32)
data DbStructure = DbStructure {
dbTables :: [Table]