diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 599d0ea0f..5b95418ce 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -78,6 +78,8 @@ data ApiRequest = ApiRequest { iAction :: Action -- | Requested range of rows within response , iRange :: M.HashMap ByteString NonnegRange + -- | Requested range of rows from the top level + , iTopLevelRange :: NonnegRange -- | The target, be it calling a proc or accessing a table , iTarget :: Target -- | Content types the client will accept, [CTAny] if no Accept header @@ -122,6 +124,7 @@ userApiRequest schema rootSpec req reqBody iAction = action , iTarget = target , iRange = ranges + , iTopLevelRange = topLevelRange , iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept" , iPayload = relevantPayload , iPreferRepresentation = representation @@ -186,7 +189,7 @@ userApiRequest schema rootSpec req reqBody Right $ ProcessedJSON (JSON.encode json) PJObject keys (ct, _) -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct - topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges + topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows action = case method of "GET" | target == TargetDefaultSpec -> ActionInspect diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b365a823b..3b7f300cc 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,3 +1,14 @@ +{-| +Module : PostgREST.App +Description : PostgREST main application + +This module is in charge of mapping HTTP requests to PostgreSQL queries. +Some of its functionality includes: + +- Mapping HTTP request methods to proper SQL statements. For example, a GET request is translated to executing a SELECT query in a read-only TRANSACTION. +- Producing HTTP Headers according to RFCs. +- Content Negotiation +-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,12 +55,12 @@ import PostgREST.Error (PgError (..), SimpleError (..), import PostgREST.Middleware import PostgREST.OpenAPI import PostgREST.Parsers (pRequestColumns) -import PostgREST.QueryBuilder (ResultsWithCount, callProc, +import PostgREST.QueryBuilder (callProc, createReadStatement, createWriteStatement, requestToCountQuery, requestToQuery) -import PostgREST.RangeQuery (allRange, rangeOffset) +import PostgREST.RangeQuery (allRange, contentRangeH, rangeStatusHeader) import PostgREST.Types import Protolude hiding (Proxy, intercalate) @@ -118,18 +129,13 @@ app dbStructure proc cols conf apiRequest = (contentType == CTTextCSV) bField row <- H.statement () stm let (tableTotal, queryTotal, _ , body) = row - (status, contentRange) = rangeHeader queryTotal tableTotal - canonical = iCanonicalQS apiRequest + (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal return $ if contentType == CTSingularJSON && queryTotal /= 1 then errorResponseFor . singularityError $ queryTotal else responseLBS status [toHeader contentType, contentRange, - ("Content-Location", - "/" <> toS (qiName qi) <> - if BS.null canonical then "" else "?" <> toS canonical - ) - ] (toS body) + contentLocationH (qiName qi) (iCanonicalQS apiRequest)] (toS body) (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> case mutateSqlParts tSchema tName of @@ -140,11 +146,11 @@ app dbStructure proc cols conf apiRequest = (contentType == CTSingularJSON) True (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols row <- H.statement (toS $ pjRaw pJson) stm - let (_, queryTotal, fs, body) = extractQueryResult row + let (_, queryTotal, fs, body) = row headers = catMaybes [ if null fs then Nothing - else Just (hLocation, "/" <> toS tName <> renderLocationFields fs) + else Just $ locationH tName fs , if iPreferRepresentation apiRequest == Full then Just $ toHeader contentType else Nothing @@ -173,7 +179,7 @@ app dbStructure proc cols conf apiRequest = (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] row <- H.statement (toS $ pjRaw pJson) stm - let (_, queryTotal, _, body) = extractQueryResult row + let (_, queryTotal, _, body) = row updateIsNoOp = S.null cols contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ @@ -215,7 +221,7 @@ app dbStructure proc cols conf apiRequest = row <- H.statement (toS pjRaw) $ createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] - let (_, queryTotal, _, body) = extractQueryResult row + let (_, queryTotal, _, body) = row -- Makes sure the querystring pk matches the payload pk -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done @@ -237,7 +243,7 @@ app dbStructure proc cols conf apiRequest = (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] row <- H.statement mempty stm - let (_, queryTotal, _, body) = extractQueryResult row + let (_, queryTotal, _, body) = row r = contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing if contentType == CTSingularJSON @@ -256,8 +262,9 @@ app dbStructure proc cols conf apiRequest = case mTable of Nothing -> return notFound Just table -> - let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in - return $ responseLBS status200 [allOrigins, acceptH] "" + let allowH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in + return $ responseLBS status200 [allOrigins, allowH] mempty (ActionInvoke _, TargetProc qi _, Just pJson) -> let returnsScalar = case proc of @@ -277,9 +284,8 @@ app dbStructure proc cols conf apiRequest = (contentType == CTTextCSV) (contentType `elem` rawContentTypes) bField (pgVersion dbStructure) - let (tableTotal, queryTotal, body, jsonHeaders) = - fromMaybe (Just 0, 0, "[]", "[]") row - (status, contentRange) = rangeHeader queryTotal tableTotal + let (tableTotal, queryTotal, body, jsonHeaders) = row + (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader] case decodedHeaders of Left _ -> return . errorResponseFor $ GucHeadersError @@ -308,17 +314,9 @@ app dbStructure proc cols conf apiRequest = where notFound = responseLBS status404 [] "" - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header shouldCount = iPreferCount apiRequest + topLevelRange = iTopLevelRange apiRequest schema = toS $ configSchema conf - topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest - rangeHeader queryTotal tableTotal = - let lower = rangeOffset topLevelRange - upper = lower + toInteger queryTotal - 1 - contentRange = contentRangeH lower upper (toInteger <$> tableTotal) - status = rangeStatus lower upper (toInteger <$> tableTotal) - in (status, contentRange) - readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) proc apiRequest fldNames = fieldNames <$> readReq readDbRequest = DbRead <$> readReq @@ -366,32 +364,18 @@ binaryField ct rawContentTypes fldNames else Left . errorResponseFor $ BinaryFieldError ct | otherwise = Right Nothing -splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) -splitKeyValue kv = (k, BS.tail v) - where (k, v) = BS.break (== '=') kv +locationH :: TableName -> [BS.ByteString] -> Header +locationH tName fields = + let + locationFields = renderSimpleQuery True $ map splitKeyValue fields + in + (hLocation, "/" <> toS tName <> locationFields) + where + splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) + splitKeyValue kv = + let (k, v) = BS.break (== '=') kv + in (k, BS.tail v) -renderLocationFields :: [BS.ByteString] -> BS.ByteString -renderLocationFields fields = - renderSimpleQuery True $ map splitKeyValue fields - -rangeStatus :: Integer -> Integer -> Maybe Integer -> Status -rangeStatus _ _ Nothing = status200 -rangeStatus lower upper (Just total) - | lower > total = status416 - | (1 + upper - lower) < total = status206 - | otherwise = status200 - -contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header -contentRangeH lower upper total = - ("Content-Range", headerValue) - where - headerValue = rangeString <> "/" <> totalString - rangeString - | totalNotZero && fromInRange = show lower <> "-" <> show upper - | otherwise = "*" - totalString = maybe "*" show total - totalNotZero = maybe True (0 /=) total - fromInRange = lower <= upper - -extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount -extractQueryResult = fromMaybe (Nothing, 0, [], "") +contentLocationH :: TableName -> ByteString -> Header +contentLocationH tName qString = + ("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString) diff --git a/src/PostgREST/QueryBuilder/Private.hs b/src/PostgREST/QueryBuilder/Private.hs index 1e8b6e989..6c654a472 100644 --- a/src/PostgREST/QueryBuilder/Private.hs +++ b/src/PostgREST/QueryBuilder/Private.hs @@ -40,6 +40,10 @@ param = HE.param . HE.nonNullable -} 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 + for that common type of query. +-} standardRow :: HD.Row ResultsWithCount standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 <*> column header <*> column HD.bytea @@ -49,18 +53,6 @@ standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 noLocationF :: Text noLocationF = "array[]::text[]" -{-| Read and Write api requests use a similar response format which includes - various record counts and possible location header. This is the decoder - for that common type of query. --} -decodeStandard :: HD.Result ResultsWithCount -decodeStandard = - HD.singleRow standardRow - -decodeStandardMay :: HD.Result (Maybe ResultsWithCount) -decodeStandardMay = - HD.rowMaybe standardRow - removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl diff --git a/src/PostgREST/QueryBuilder/Procedure.hs b/src/PostgREST/QueryBuilder/Procedure.hs index 0de487753..f89857a37 100644 --- a/src/PostgREST/QueryBuilder/Procedure.hs +++ b/src/PostgREST/QueryBuilder/Procedure.hs @@ -12,9 +12,10 @@ import Protolude hiding (cast, import Text.InterpolatedString.Perl6 (qc) type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) + callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> - H.Statement ByteString (Maybe ProcResults) + H.Statement ByteString ProcResults callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer = unicodeStatement sql (param HE.unknown) decodeProc True where @@ -79,7 +80,9 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 else "'[]'" :: Text - decodeProc = HD.rowMaybe procRow +decodeProc :: HD.Result ProcResults +decodeProc = + fromMaybe (Just 0, 0, "[]", "[]") <$> HD.rowMaybe procRow + where procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 <*> column HD.bytea <*> column HD.bytea - diff --git a/src/PostgREST/QueryBuilder/ReadStatement.hs b/src/PostgREST/QueryBuilder/ReadStatement.hs index 7f34f065b..d8e115826 100644 --- a/src/PostgREST/QueryBuilder/ReadStatement.hs +++ b/src/PostgREST/QueryBuilder/ReadStatement.hs @@ -2,6 +2,7 @@ module PostgREST.QueryBuilder.ReadStatement where import Data.Maybe import Data.Text (intercalate) +import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE import qualified Hasql.Statement as H import PostgREST.QueryBuilder.Private @@ -30,3 +31,7 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField | isSingle = asJsonSingleF | isJust binaryField = asBinaryF $ fromJust binaryField | otherwise = asJsonF + +decodeStandard :: HD.Result ResultsWithCount +decodeStandard = + HD.singleRow standardRow diff --git a/src/PostgREST/QueryBuilder/WriteStatement.hs b/src/PostgREST/QueryBuilder/WriteStatement.hs index ea93b32f5..a9bea5657 100644 --- a/src/PostgREST/QueryBuilder/WriteStatement.hs +++ b/src/PostgREST/QueryBuilder/WriteStatement.hs @@ -2,6 +2,7 @@ module PostgREST.QueryBuilder.WriteStatement where import Data.Maybe import Data.Text (intercalate, unwords) +import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE import qualified Hasql.Statement as H import PostgREST.ApiRequest (PreferRepresentation (..)) @@ -13,7 +14,7 @@ import Text.InterpolatedString.Perl6 (qc) createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] -> - H.Statement ByteString (Maybe ResultsWithCount) + H.Statement ByteString ResultsWithCount createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys = unicodeStatement sql (param HE.unknown) decodeStandardMay True @@ -51,3 +52,7 @@ createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys | asCsv = asCsvF | wantSingle = asJsonSingleF | otherwise = asJsonF + +decodeStandardMay :: HD.Result ResultsWithCount +decodeStandardMay = + fromMaybe (Nothing, 0, [], "") <$> HD.rowMaybe standardRow diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index 285487233..0aadafeb1 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -1,6 +1,6 @@ {-| Module : PostgREST.RangeQuery -Description : Logic regarding the `Range` header and `limit`, `offset` querystring arguments. +Description : Logic regarding the `Range`/`Content-Range` headers and `limit`/`offset` querystring arguments. -} module PostgREST.RangeQuery ( rangeParse @@ -11,6 +11,8 @@ module PostgREST.RangeQuery ( , rangeGeq , allRange , NonnegRange +, rangeStatusHeader +, contentRangeH ) where import qualified Data.ByteString.Char8 as BS @@ -22,6 +24,7 @@ import Control.Applicative import Data.Ranged.Boundaries import Data.Ranged.Ranges import Network.HTTP.Types.Header +import Network.HTTP.Types.Status import Protolude @@ -70,3 +73,30 @@ allRange = rangeGeq 0 rangeLeq :: Integer -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n) + +rangeStatusHeader :: NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header) +rangeStatusHeader topLevelRange queryTotal tableTotal = + let lower = rangeOffset topLevelRange + upper = lower + toInteger queryTotal - 1 + contentRange = contentRangeH lower upper (toInteger <$> tableTotal) + status = rangeStatus lower upper (toInteger <$> tableTotal) + in (status, contentRange) + where + rangeStatus :: Integer -> Integer -> Maybe Integer -> Status + rangeStatus _ _ Nothing = status200 + rangeStatus lower upper (Just total) + | lower > total = status416 -- 416 Range Not Satisfiable + | (1 + upper - lower) < total = status206 -- 206 Partial Content + | otherwise = status200 -- 200 OK + +contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header +contentRangeH lower upper total = + ("Content-Range", headerValue) + where + headerValue = rangeString <> "/" <> totalString + rangeString + | totalNotZero && fromInRange = show lower <> "-" <> show upper + | otherwise = "*" + totalString = maybe "*" show total + totalNotZero = maybe True (0 /=) total + fromInRange = lower <= upper