refactor: reorganize modules

* 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

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

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
+                  (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal
-                  canonical = iCanonicalQS apiRequest
               return $
                 if contentType == CTSingularJSON && queryTotal /= 1
                   then errorResponseFor . singularityError $ queryTotal
                   else responseLBS status
                     [toHeader contentType, contentRange,
-                      ("Content-Location",
+                     contentLocationH (qiName qi) (iCanonicalQS apiRequest)] (toS body)
-                        "/" <> toS (qiName qi) <>
-                          if BS.null canonical then "" else "?" <> toS canonical
-                      )
-                    ] (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
+              let allowH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET")
-              return $ responseLBS status200 [allOrigins, acceptH] ""
+                  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) =
+              let (tableTotal, queryTotal, body, jsonHeaders) = row
-                    fromMaybe (Just 0, 0, "[]", "[]") row
+                  (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal
-                  (status, contentRange) = rangeHeader 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)
+locationH :: TableName -> [BS.ByteString] -> Header
-splitKeyValue kv = (k, BS.tail v)
+locationH tName fields =
-  where (k, v) = BS.break (== '=') kv
+  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
+contentLocationH :: TableName -> ByteString -> Header
-renderLocationFields fields =
+contentLocationH tName qString =
-  renderSimpleQuery True $ map splitKeyValue fields
+  ("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString)
-
-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, [], "")

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
 

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
-

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

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

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