RangeQuery.hs

{-|
Module      : PostgREST.RangeQuery
Description : Logic regarding the `Range`/`Content-Range` headers and `limit`/`offset` querystring arguments.
-}
module PostgREST.RangeQuery (
  rangeParse
, rangeRequested
, rangeLimit
, rangeOffset
, restrictRange
, rangeGeq
, allRange
, limitZeroRange
, hasLimitZero
, convertToLimitZeroRange
, NonnegRange
, rangeStatusHeader
, contentRangeH
) where

import qualified Data.ByteString.Char8 as BS

import Data.List       (lookup)
import Text.Regex.TDFA ((=~))

import Control.Applicative
import Data.Ranged.Boundaries
import Data.Ranged.Ranges
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status

import Protolude

type NonnegRange = Range Integer

rangeParse :: BS.ByteString -> NonnegRange
rangeParse range = do
  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString

  case range =~ rangeRegex :: [[BS.ByteString]] of
    [[_, l, u]] ->
      let lower  = maybe emptyRange rangeGeq (readInteger l)
          upper  = maybe allRange rangeLeq (readInteger u) in
      rangeIntersection lower upper
    _ -> allRange
  where
    readInteger = readMaybe . BS.unpack

rangeRequested :: RequestHeaders -> NonnegRange
rangeRequested headers = maybe allRange rangeParse $ lookup hRange headers

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 Integer
rangeLimit range =
  case [rangeLower range, rangeUpper range] of
    [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower)
    _ -> Nothing

rangeOffset :: NonnegRange -> Integer
rangeOffset range =
  case rangeLower range of
    BoundaryBelow lower -> lower
    _                   -> panic "range without lower bound" -- should never happen

rangeGeq :: Integer -> NonnegRange
rangeGeq n =
  Range (BoundaryBelow n) BoundaryAboveAll

allRange :: NonnegRange
allRange = rangeGeq 0

rangeLeq :: Integer -> NonnegRange
rangeLeq n =
  Range BoundaryBelowAll (BoundaryAbove n)

-- Special case to allow limit 0 queries
-- https://github.com/PostgREST/postgrest/issues/1121
-- 0 <= x <= -1
limitZeroRange :: Range Integer
limitZeroRange = Range (BoundaryBelow 0) (BoundaryAbove (-1))

hasLimitZero :: Range Integer -> Bool
hasLimitZero r = rangeUpper r == rangeUpper limitZeroRange

-- Used to convert a range into a special limitZeroRange if it has a
-- limit=0 in order to bypass validations for empty ranges.
convertToLimitZeroRange :: Range Integer -> Range Integer -> Range Integer
convertToLimitZeroRange range fallbackRange =
  if hasLimitZero range then limitZeroRange else fallbackRange

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", toUtf8 headerValue)
    where
      headerValue   = rangeString <> "/" <> totalString :: Text
      rangeString
        | totalNotZero && fromInRange = show lower <> "-" <> show upper
        | otherwise = "*"
      totalString   = maybe "*" show total
      totalNotZero  = Just 0 /= total
      fromInRange   = lower <= upper