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

refactor: reorganize modules

Browse Source 
* Move range logic from App to RangeQuery

* Move decoder logic to Statement modules

* Move location headers logic to functions

* Add a comment for App.hs module
This commit is contained in:
steve-chavez
2019-09-03 13:38:53 -05:00
committed by Steve Chávez
parent 0846d4d7b2
commit e21b010c6e
7 changed files with 96 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/ApiRequest.hs
+4 -1
View File
@@ -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
src/PostgREST/App.hs
+40 -56
View File
@@ -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)
src/PostgREST/QueryBuilder/Private.hs
+4 -12
View File
@@ -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
src/PostgREST/QueryBuilder/Procedure.hs
+6 -3
View File
@@ -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
src/PostgREST/QueryBuilder/ReadStatement.hs
+5
View File
@@ -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
src/PostgREST/QueryBuilder/WriteStatement.hs
+6 -1
View File
@@ -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
src/PostgREST/RangeQuery.hs
+31 -1
View File
@@ -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